view release on metacpan or  search on metacpan

Email-Address-XS.xs  view on Meta::CPAN

	if (taint)
		SvTAINTED_on(*group_scalar);

	addresses_array = newAV();
	*addresses_scalar = sv_2mortal(newRV_noinc((SV *)addresses_array));

	if (in_group)
		*address = (*address)->next;

	while (*address && (*address)->domain) {
		hash = newHV();

		set_perl_hash_value(aTHX_ hash, "phrase", (*address)->name, (*address)->name_len, utf8, taint);
		set_perl_hash_value(aTHX_ hash, "user", ( (*address)->mailbox && (*address)->mailbox[0] ) ? (*address)->mailbox : NULL, (*address)->mailbox_len, utf8, taint);
		set_perl_hash_value(aTHX_ hash, "host", ( (*address)->domain && (*address)->domain[0] ) ? (*address)->domain : NULL, (*address)->domain_len, utf8, taint);
		set_perl_hash_value(aTHX_ hash, "comment", (*address)->comment, (*address)->comment_len, utf8, taint);
		set_perl_hash_value(aTHX_ hash, "original", (*address)->original, (*address)->original_len, utf8, taint);

		if ((*address)->invalid_syntax)
			(void)hv_store(hash, "invalid", sizeof("invalid")-1, newSViv(1), 0);

		hash_ref = newRV_noinc((SV *)hash);
		object = sv_bless(hash_ref, class);

		av_push(addresses_array, object);

		*address = (*address)->next;
	}

	if (in_group && *address)
		*address = (*address)->next;

	return true;
}


MODULE = Email::Address::XS		PACKAGE = Email::Address::XS		

PROTOTYPES: DISABLE

void
format_email_groups(...)
PREINIT:
	I32 i;
	bool utf8;
	bool taint;
	char *string;
	size_t string_len;
	struct message_address *first_address;
	struct message_address *last_address;
	SV *string_scalar;
INPUT:
	const char *this_class_name = "$Package";
	STRLEN this_class_len = sizeof("$Package")-1;
INIT:
	if (items % 2 == 1) {
		carp(CARP_WARN, "Odd number of elements in argument list");
		XSRETURN_UNDEF;
	}
PPCODE:
	first_address = NULL;
	last_address = NULL;
	taint = false;
#ifndef WITHOUT_SvPV_nomg
	utf8 = false;
	for (i = 0; i < items; i += 2)
		if (perl_group_needs_utf8(aTHX_ ST(i), ST(i+1), (items == 2 ? -1 : i), this_class_name, this_class_len))
			utf8 = true;
#else
	utf8 = true;
#endif
	for (i = 0; i < items; i += 2)
		message_address_add_from_perl_group(aTHX_ &first_address, &last_address, utf8, &taint, ST(i), ST(i+1), (items == 2 ? -1 : i), this_class_name, this_class_len);
	message_address_write(&string, &string_len, first_address);
	message_address_free(&first_address);
	string_scalar = sv_2mortal(newSVpvn(string, string_len));
	string_free(string);
	if (utf8)
		sv_utf8_decode(string_scalar);
	if (taint)
		SvTAINTED_on(string_scalar);
	EXTEND(SP, 1);
	PUSHs(string_scalar);

void
parse_email_groups(...)
PREINIT:
	SV *string_scalar;
	SV *class_scalar;
	int count;
	HV *hv_class;
	SV *group_scalar;
	SV *addresses_scalar;
	bool utf8;
	bool taint;
	STRLEN input_len;
	const char *input;
	struct message_address *address;
	struct message_address *first_address;
INPUT:
	const char *this_class_name = "$Package";
	STRLEN this_class_len = sizeof("$Package")-1;
INIT:
	string_scalar = items >= 1 ? ST(0) : &PL_sv_undef;
	class_scalar = items >= 2 ? ST(1) : NULL;
	input = get_perl_scalar_string_value(aTHX_ string_scalar, &input_len, "string", false);
	utf8 = SvUTF8(string_scalar);
	taint = SvTAINTED(string_scalar);
	hv_class = get_perl_class_from_perl_scalar_or_cv(aTHX_ class_scalar, cv);
	if (class_scalar && !sv_derived_from_pvn(class_scalar, this_class_name, this_class_len, SVf_UTF8)) {
		carp(CARP_WARN, "Class %" SVf " is not derived from %s", SVfARG(class_scalar), this_class_name);
		XSRETURN_EMPTY;
	}
PPCODE:
	first_address = message_address_parse(input, input_len, UINT_MAX, MESSAGE_ADDRESS_PARSE_FLAG_NON_STRICT_DOTS_AS_INVALID);
	count = count_address_groups(first_address);
	EXTEND(SP, count * 2);
	address = first_address;
	while (get_next_perl_address_group(aTHX_ &address, &group_scalar, &addresses_scalar, hv_class, utf8, taint)) {
		PUSHs(group_scalar);
		PUSHs(addresses_scalar);
	}
	message_address_free(&first_address);

void
compose_address(...)
PREINIT:
	char *string;
	const char *mailbox;
	const char *domain;
	size_t string_len;
	STRLEN mailbox_len;
	STRLEN domain_len;
	bool mailbox_utf8;
	bool domain_utf8;
	bool utf8;
	bool taint;
	SV *mailbox_scalar;
	SV *domain_scalar;
	SV *string_scalar;
INIT:
	mailbox_scalar = items >= 1 ? ST(0) : &PL_sv_undef;
	domain_scalar = items >= 2 ? ST(1) : &PL_sv_undef;
	mailbox = get_perl_scalar_string_value(aTHX_ mailbox_scalar, &mailbox_len, "mailbox", false);
	domain = get_perl_scalar_string_value(aTHX_ domain_scalar, &domain_len, "domain", false);
	mailbox_utf8 = SvUTF8(mailbox_scalar);
	domain_utf8 = SvUTF8(domain_scalar);
	utf8 = (mailbox_utf8 || domain_utf8);
	if (utf8 && !mailbox_utf8)
		mailbox = get_perl_scalar_value(aTHX_ mailbox_scalar, &mailbox_len, true, true);
	if (utf8 && !domain_utf8)
		domain = get_perl_scalar_value(aTHX_ domain_scalar, &domain_len, true, true);
	taint = (SvTAINTED(mailbox_scalar) || SvTAINTED(domain_scalar));
PPCODE:
	compose_address(&string, &string_len, mailbox, mailbox_len, domain, domain_len);
	string_scalar = sv_2mortal(newSVpvn(string, string_len));
	string_free(string);
	if (utf8)
		sv_utf8_decode(string_scalar);
	if (taint)
		SvTAINTED_on(string_scalar);
	EXTEND(SP, 1);
	PUSHs(string_scalar);

void
split_address(...)
PREINIT:
	const char *string;
	char *mailbox;
	char *domain;
	STRLEN string_len;
	size_t mailbox_len;
	size_t domain_len;
	bool utf8;
	bool taint;
	SV *string_scalar;
	SV *mailbox_scalar;
	SV *domain_scalar;
INIT:
	string_scalar = items >= 1 ? ST(0) : &PL_sv_undef;
	string = get_perl_scalar_string_value(aTHX_ string_scalar, &string_len, "string", false);
	utf8 = SvUTF8(string_scalar);
	taint = SvTAINTED(string_scalar);
PPCODE:
	split_address(string, string_len, &mailbox, &mailbox_len, &domain, &domain_len);
	mailbox_scalar = mailbox ? sv_2mortal(newSVpvn(mailbox, mailbox_len)) : sv_newmortal();
	domain_scalar = domain ? sv_2mortal(newSVpvn(domain, domain_len)) : sv_newmortal();
	string_free(mailbox);
	string_free(domain);
	if (utf8) {
		sv_utf8_decode(mailbox_scalar);
		sv_utf8_decode(domain_scalar);
	}
	if (taint) {
		SvTAINTED_on(mailbox_scalar);
		SvTAINTED_on(domain_scalar);
	}
	EXTEND(SP, 2);
	PUSHs(mailbox_scalar);
	PUSHs(domain_scalar);

bool
is_obj(...)
PREINIT:
	SV *class = items >= 1 ? ST(0) : &PL_sv_undef;
	SV *object = items >= 2 ? ST(1) : &PL_sv_undef;
CODE:
	RETVAL = is_class_object(aTHX_ class, NULL, 0, object);
OUTPUT:
	RETVAL