Import Upstream version 1.05

Changes

@@ -0,0 +1,44 @@
+Revision history for Perl extension Email::Address::XS.
+
+1.05  Sun Aug 07 15:21:35 2022
+	- update dovecot parser from dovecot version 2.3.14
+	- mark the last parsed object as invalid if input string contains trailing garbage
+	  https://github.com/pali/Email-Address-XS/issues/5
+
+1.04  Sat Jun 09 18:20:28 2018
+	- fix docevot parser to disallow leading dot in dot-atom
+	- fix generating and validating email addresses with empty user part
+	- fix generating email address with leading or trailing dot in user part
+	- try to parse invalid email addresses and mark them as invalid
+	- when generating address do not escape an apostrophe character
+	- fix formatting email addresses which contain nul bytes, TAB, LF or CR
+	- fix formatting comments which contain nul bytes
+
+1.03  Thu Mar 15 21:55:30 2018
+	- update dovecot parser from dovecot version 2.3.0.1
+	- fix reading from uninitialized memory when formatting invalid address without user or host part
+	- fix formatting email address which user part starts with null byte
+	- do not generate invalid email addresses by format functions, rather return empty string
+
+1.02  Sat Feb 03 13:41:38 2018
+	- add support for parsing and generating addresses with nul character
+	- fix function compose_address when both user and host contains non-ASCII 8bit characters
+	- fix possible memory leak in dovecot parser
+
+1.01  Wed Oct 18 18:19:26 2017
+	- add new exportable functions: compose_address split_address
+	- add new class methods: parse_bare_address
+	- add new object methods: is_valid original as_string
+	- show warnings when strings contain nul characters
+	- update dovecot parser from dovecot version 2.2.31
+	- fix memory leak
+	- fix documentation
+	- improve warning messages
+
+1.00  Sat Feb 18 15:23:30 2017
+	- first public release
+
+0.01  Tue Aug 25 18:41:43 2015
+	- original version; created by h2xs 1.23 with options
+		--compat-version 5.6.2 --skip-ppport --omit-autoload --name Email::Address::XS
+

Email-Address-XS.xs

@@ -0,0 +1,779 @@
+/* Copyright (c) 2015-2018 by Pali <pali@cpan.org> */
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include "dovecot-parser.h"
+
+/* Perl pre 5.6.1 support */
+#if PERL_VERSION < 6 || (PERL_VERSION == 6 && PERL_SUBVERSION < 1)
+#define BROKEN_SvPVutf8
+#endif
+
+/* Perl pre 5.7.2 support */
+#ifndef SvPV_nomg
+#define WITHOUT_SvPV_nomg
+#endif
+
+/* Perl pre 5.8.0 support */
+#ifndef UTF8_IS_INVARIANT
+#define UTF8_IS_INVARIANT(c) (((U8)c) < 0x80)
+#endif
+
+/* Perl pre 5.9.5 support */
+#ifndef SVfARG
+#define SVfARG(p) ((void*)(p))
+#endif
+
+/* Perl pre 5.13.1 support */
+#ifndef warn_sv
+#define warn_sv(scalar) warn("%" SVf, SVfARG(scalar))
+#endif
+#ifndef croak_sv
+#define croak_sv(scalar) croak("%" SVf, SVfARG(scalar))
+#endif
+
+/* Perl pre 5.15.4 support */
+#ifndef sv_derived_from_pvn
+#define sv_derived_from_pvn(scalar, name, len, flags) sv_derived_from(scalar, name)
+#endif
+
+/* Exported i_panic function for other C files */
+void i_panic(const char *format, ...)
+{
+	dTHX;
+	va_list args;
+
+	va_start(args, format);
+	vcroak(format, &args);
+	va_end(args);
+}
+
+static void append_carp_shortmess(pTHX_ SV *scalar)
+{
+	dSP;
+	int count;
+
+	ENTER;
+	SAVETMPS;
+	PUSHMARK(SP);
+
+	count = call_pv("Carp::shortmess", G_SCALAR);
+
+	SPAGAIN;
+
+	if (count > 0)
+		sv_catsv(scalar, POPs);
+
+	PUTBACK;
+	FREETMPS;
+	LEAVE;
+}
+
+#define CARP_WARN false
+#define CARP_DIE true
+static void carp(bool fatal, const char *format, ...)
+{
+	dTHX;
+	va_list args;
+	SV *scalar;
+
+	va_start(args, format);
+	scalar = sv_2mortal(vnewSVpvf(format, &args));
+	va_end(args);
+
+	append_carp_shortmess(aTHX_ scalar);
+
+	if (!fatal)
+		warn_sv(scalar);
+	else
+		croak_sv(scalar);
+}
+
+static bool string_needs_utf8_upgrade(const char *str, STRLEN len)
+{
+	STRLEN i;
+
+	for (i = 0; i < len; ++i)
+		if (!UTF8_IS_INVARIANT(str[i]))
+			return true;
+
+	return false;
+}
+
+static const char *get_perl_scalar_value(pTHX_ SV *scalar, STRLEN *len, bool utf8, bool nomg)
+{
+	const char *string;
+
+#ifndef WITHOUT_SvPV_nomg
+	if (!nomg)
+		SvGETMAGIC(scalar);
+
+	if (!SvOK(scalar))
+		return NULL;
+
+	string = SvPV_nomg(scalar, *len);
+#else
+	COP cop;
+
+	if (!SvGMAGICAL(scalar) && !SvOK(scalar))
+		return NULL;
+
+	/* Temporary turn off all warnings because SvPV can throw uninitialized warning */
+	cop = *PL_curcop;
+	cop.cop_warnings = pWARN_NONE;
+
+	ENTER;
+	SAVEVPTR(PL_curcop);
+	PL_curcop = &cop;
+
+	string = SvPV(scalar, *len);
+
+	LEAVE;
+
+	if (SvGMAGICAL(scalar) && !SvOK(scalar))
+		return NULL;
+#endif
+
+	if (utf8 && !SvUTF8(scalar) && string_needs_utf8_upgrade(string, *len)) {
+		scalar = sv_2mortal(newSVpvn(string, *len));
+#ifdef BROKEN_SvPVutf8
+		sv_utf8_upgrade(scalar);
+		*len = SvCUR(scalar);
+		return SvPVX(scalar);
+#else
+		return SvPVutf8(scalar, *len);
+#endif
+	}
+
+	return string;
+}
+
+static const char *get_perl_scalar_string_value(pTHX_ SV *scalar, STRLEN *len, const char *name, bool utf8)
+{
+	const char *string;
+
+	string = get_perl_scalar_value(aTHX_ scalar, len, utf8, false);
+	if (!string) {
+		carp(CARP_WARN, "Use of uninitialized value for %s", name);
+		*len = 0;
+		return "";
+	}
+
+	return string;
+}
+
+static SV *get_perl_hash_scalar(pTHX_ HV *hash, const char *key)
+{
+	I32 klen;
+	SV **scalar_ptr;
+
+	klen = strlen(key);
+
+	if (!hv_exists(hash, key, klen))
+		return NULL;
+
+	scalar_ptr = hv_fetch(hash, key, klen, 0);
+	if (!scalar_ptr)
+		return NULL;
+
+	return *scalar_ptr;
+}
+
+static const char *get_perl_hash_value(pTHX_ HV *hash, const char *key, STRLEN *len, bool utf8, bool *taint)
+{
+	SV *scalar;
+
+	scalar = get_perl_hash_scalar(aTHX_ hash, key);
+	if (!scalar)
+		return NULL;
+
+	if (!*taint && SvTAINTED(scalar))
+		*taint = true;
+
+	return get_perl_scalar_value(aTHX_ scalar, len, utf8, true);
+}
+
+static void set_perl_hash_value(pTHX_ HV *hash, const char *key, const char *value, STRLEN len, bool utf8, bool taint)
+{
+	I32 klen;
+	SV *scalar;
+
+	klen = strlen(key);
+
+	if (!len && value && value[0])
+		value = NULL;
+
+	if (value)
+		scalar = newSVpvn(value, len);
+	else
+		scalar = newSV(0);
+
+	if (utf8 && value)
+		sv_utf8_decode(scalar);
+
+	if (taint)
+		SvTAINTED_on(scalar);
+
+	(void)hv_store(hash, key, klen, scalar, 0);
+}
+
+static HV *get_perl_class_from_perl_cv(pTHX_ CV *cv)
+{
+	GV *gv;
+	HV *class;
+
+	class = NULL;
+	gv = CvGV(cv);
+
+	if (gv)
+		class = GvSTASH(gv);
+
+	if (!class)
+		class = CvSTASH(cv);
+
+	if (!class)
+		class = PL_curstash;
+
+	if (!class)
+		carp(CARP_DIE, "Cannot retrieve class");
+
+	return class;
+}
+
+static HV *get_perl_class_from_perl_scalar(pTHX_ SV *scalar)
+{
+	HV *class;
+	STRLEN class_len;
+	const char *class_name;
+
+	class_name = get_perl_scalar_string_value(aTHX_ scalar, &class_len, "class", true);
+
+	if (class_len == 0) {
+		carp(CARP_WARN, "Explicit blessing to '' (assuming package main)");
+		class_name = "main";
+		class_len = strlen(class_name);
+	}
+
+	class = gv_stashpvn(class_name, class_len, GV_ADD | SVf_UTF8);
+	if (!class)
+		carp(CARP_DIE, "Cannot retrieve class %" SVf, SVfARG(scalar));
+
+	return class;
+}
+
+static HV *get_perl_class_from_perl_scalar_or_cv(pTHX_ SV *scalar, CV *cv)
+{
+	if (scalar)
+		return get_perl_class_from_perl_scalar(aTHX_ scalar);
+	else
+		return get_perl_class_from_perl_cv(aTHX_ cv);
+}
+
+static bool is_class_object(pTHX_ SV *class, const char *class_name, STRLEN class_len, SV *object)
+{
+	dSP;
+	SV *sv;
+	bool ret;
+	int count;
+
+	if (!sv_isobject(object))
+		return false;
+
+	ENTER;
+	SAVETMPS;
+
+	PUSHMARK(SP);
+	EXTEND(SP, 2);
+
+	if (class) {
+		sv = newSVsv(class);
+	} else {
+		sv = newSVpvn(class_name, class_len);
+		SvUTF8_on(sv);
+	}
+
+	PUSHs(sv_2mortal(newSVsv(object)));
+	PUSHs(sv_2mortal(sv));
+
+	PUTBACK;
+
+	count = call_method("isa", G_SCALAR);
+
+	SPAGAIN;
+
+	if (count > 0) {
+		sv = POPs;
+		ret = SvTRUE(sv);
+	} else {
+		ret = false;
+	}
+
+	PUTBACK;
+	FREETMPS;
+	LEAVE;
+
+	return ret;
+}
+
+static void fill_element_message(char *buffer, size_t len, I32 index1, I32 index2)
+{
+	static const char message[] = "Element at index ";
+
+	if (len < 10 || buffer[0])
+		return;
+
+	if (len+10+1+10 < sizeof(message)) {
+		buffer[0] = 0;
+		return;
+	}
+
+	if (index2 == -1) {
+		strcpy(buffer, "Argument");
+		return;
+	}
+
+	memcpy(buffer, message, sizeof(message));
+
+	if (index1 == -1)
+		sprintf(buffer+sizeof(message)-1, "%d", (int)index2);
+	else
+		sprintf(buffer+sizeof(message)-1, "%d/%d", (int)index1, (int)index2);
+}
+
+static HV* get_object_hash_from_perl_array(pTHX_ AV *array, I32 index1, I32 index2, const char *class_name, STRLEN class_len, bool warn)
+{
+	SV *scalar;
+	SV *object;
+	SV **object_ptr;
+	char buffer[40] = { 0 };
+
+#ifdef WITHOUT_SvPV_nomg
+	warn = true;
+#endif
+
+	object_ptr = av_fetch(array, (index2 == -1 ? 0 : index2), 0);
+	if (!object_ptr) {
+		if (warn) {
+			fill_element_message(buffer, sizeof(buffer), index1, index2);
+			carp(CARP_WARN, "%s is NULL", buffer);
+		}
+		return NULL;
+	}
+
+	object = *object_ptr;
+	if (!is_class_object(aTHX_ NULL, class_name, class_len, object)) {
+		if (warn) {
+			fill_element_message(buffer, sizeof(buffer), index1, index2);
+			carp(CARP_WARN, "%s is not %s object", buffer, class_name);
+		}
+		return NULL;
+	}
+
+	scalar = SvRV(object);
+	if (SvTYPE(scalar) != SVt_PVHV) {
+		if (warn) {
+			fill_element_message(buffer, sizeof(buffer), index1, index2);
+			carp(CARP_WARN, "%s is not HASH reference", buffer);
+		}
+		return NULL;
+	}
+
+	return (HV *)scalar;
+
+}
+
+static void message_address_add_from_perl_array(pTHX_ struct message_address **first_address, struct message_address **last_address, bool utf8, bool *taint, AV *array, I32 index1, I32 index2, const char *class_name, STRLEN class_len)
+{
+	HV *hash;
+	const char *name;
+	const char *mailbox;
+	const char *domain;
+	const char *comment;
+	STRLEN name_len;
+	STRLEN mailbox_len;
+	STRLEN domain_len;
+	STRLEN comment_len;
+	char buffer[40] = { 0 };
+
+	hash = get_object_hash_from_perl_array(aTHX_ array, index1, index2, class_name, class_len, false);
+	if (!hash)
+		return;
+
+	name = get_perl_hash_value(aTHX_ hash, "phrase", &name_len, utf8, taint);
+	mailbox = get_perl_hash_value(aTHX_ hash, "user", &mailbox_len, utf8, taint);
+	domain = get_perl_hash_value(aTHX_ hash, "host", &domain_len, utf8, taint);
+	comment = get_perl_hash_value(aTHX_ hash, "comment", &comment_len, utf8, taint);
+
+	if (domain && !domain[0] && domain_len == 0)
+		domain = NULL;
+
+	if (!mailbox && !domain) {
+		fill_element_message(buffer, sizeof(buffer), index1, index2);
+		carp(CARP_WARN, "%s contains empty address", buffer);
+		return;
+	}
+
+	if (!mailbox) {
+		fill_element_message(buffer, sizeof(buffer), index1, index2);
+		carp(CARP_WARN, "%s contains empty user portion of address", buffer);
+		return;
+	}
+
+	if (!domain) {
+		fill_element_message(buffer, sizeof(buffer), index1, index2);
+		carp(CARP_WARN, "%s contains empty host portion of address", buffer);
+		return;
+	}
+
+	message_address_add(first_address, last_address, name, name_len, NULL, 0, mailbox, mailbox_len, domain, domain_len, comment, comment_len);
+}
+
+static AV *get_perl_array_from_scalar(SV *scalar, const char *group_name, bool warn)
+{
+	SV *scalar_ref;
+
+#ifdef WITHOUT_SvPV_nomg
+	warn = true;
+#endif
+
+	if (scalar && !SvROK(scalar)) {
+		if (warn)
+			carp(CARP_WARN, "Value for group '%s' is not reference", group_name);
+		return NULL;
+	}
+
+	scalar_ref = SvRV(scalar);
+
+	if (!scalar_ref || SvTYPE(scalar_ref) != SVt_PVAV) {
+		if (warn)
+			carp(CARP_WARN, "Value for group '%s' is not ARRAY reference", group_name);
+		return NULL;
+	}
+
+	return (AV *)scalar_ref;
+}
+
+static void message_address_add_from_perl_group(pTHX_ struct message_address **first_address, struct message_address **last_address, bool utf8, bool *taint, SV *scalar_group, SV *scalar_list, I32 index1, const char *class_name, STRLEN class_len)
+{
+	I32 len;
+	I32 index2;
+	AV *array;
+	STRLEN group_len;
+	const char *group_name;
+
+	group_name = get_perl_scalar_value(aTHX_ scalar_group, &group_len, utf8, true);
+	array = get_perl_array_from_scalar(scalar_list, group_name, false);
+	len = array ? (av_len(array) + 1) : 0;
+
+	if (index1 == -1 && group_name)
+		index1 = 0;
+
+	if (group_name)
+		message_address_add(first_address, last_address, NULL, 0, NULL, 0, group_name, group_len, NULL, 0, NULL, 0);
+
+	for (index2 = 0; index2 < len; ++index2)
+		message_address_add_from_perl_array(aTHX_ first_address, last_address, utf8, taint, array, index1, ((index1 == -1 && len == 1) ? -1 : index2), class_name, class_len);
+
+	if (group_name)
+		message_address_add(first_address, last_address, NULL, 0, NULL, 0, NULL, 0, NULL, 0, NULL, 0);
+
+	if (!*taint && SvTAINTED(scalar_group))
+		*taint = true;
+}
+
+#ifndef WITHOUT_SvPV_nomg
+static bool perl_group_needs_utf8(pTHX_ SV *scalar_group, SV *scalar_list, I32 index1, const char *class_name, STRLEN class_len)
+{
+	I32 len;
+	I32 index2;
+	SV *scalar;
+	HV *hash;
+	AV *array;
+	STRLEN len_na;
+	bool utf8;
+	const char *group_name;
+	const char **hash_key_ptr;
+
+	static const char *hash_keys[] = { "phrase", "user", "host", "comment", NULL };
+
+	utf8 = false;
+
+	group_name = get_perl_scalar_value(aTHX_ scalar_group, &len_na, false, false);
+	if (SvUTF8(scalar_group))
+		utf8 = true;
+
+	if (index1 == -1 && group_name)
+		index1 = 0;
+
+	array = get_perl_array_from_scalar(scalar_list, group_name, true);
+	len = array ? (av_len(array) + 1) : 0;
+
+	for (index2 = 0; index2 < len; ++index2) {
+		hash = get_object_hash_from_perl_array(aTHX_ array, index1, ((index1 == -1 && len == 1) ? -1 : index2), class_name, class_len, true);
+		if (!hash)
+			continue;
+		for (hash_key_ptr = hash_keys; *hash_key_ptr; ++hash_key_ptr) {
+			scalar = get_perl_hash_scalar(aTHX_ hash, *hash_key_ptr);
+			if (scalar && get_perl_scalar_value(aTHX_ scalar, &len_na, false, false) && SvUTF8(scalar))
+				utf8 = true;
+		}
+	}
+
+	return utf8;
+}
+#endif
+
+static int count_address_groups(struct message_address *first_address)
+{
+	int count;
+	bool in_group;
+	struct message_address *address;
+
+	count = 0;
+	in_group = false;
+
+	for (address = first_address; address; address = address->next) {
+		if (!address->domain)
+			in_group = !in_group;
+		if (in_group)
+			continue;
+		++count;
+	}
+
+	return count;
+}
+
+static bool get_next_perl_address_group(pTHX_ struct message_address **address, SV **group_scalar, SV **addresses_scalar, HV *class, bool utf8, bool taint)
+{
+	HV *hash;
+	SV *object;
+	SV *hash_ref;
+	bool in_group;
+	AV *addresses_array;
+
+	if (!*address)
+		return false;
+
+	in_group = !(*address)->domain;
+
+	if (in_group && (*address)->mailbox)
+		*group_scalar = sv_2mortal(newSVpvn((*address)->mailbox, (*address)->mailbox_len));
+	else
+		*group_scalar = sv_newmortal();
+
+	if (utf8 && in_group && (*address)->mailbox)
+		sv_utf8_decode(*group_scalar);
+
+	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

MANIFEST

@@ -0,0 +1,12 @@
+Changes
+Makefile.PL
+MANIFEST
+README
+Email-Address-XS.xs
+t/Email-Address-XS.t
+t/taint-Email-Address-XS.t
+lib/Email/Address/XS.pm
+dovecot-parser.h
+dovecot-parser.c
+META.yml                                 Module YAML meta-data (added by MakeMaker)
+META.json                                Module JSON meta-data (added by MakeMaker)

META.json

@@ -0,0 +1,64 @@
+{
+   "abstract" : "Parse and format RFC 5322 email addresses and groups",
+   "author" : [
+      "Pali <pali@cpan.org>"
+   ],
+   "dynamic_config" : 0,
+   "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010",
+   "license" : [
+      "perl_5"
+   ],
+   "meta-spec" : {
+      "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+      "version" : 2
+   },
+   "name" : "Email-Address-XS",
+   "no_index" : {
+      "directory" : [
+         "t",
+         "inc"
+      ]
+   },
+   "prereqs" : {
+      "build" : {
+         "requires" : {
+            "ExtUtils::MakeMaker" : "0"
+         }
+      },
+      "configure" : {
+         "requires" : {
+            "ExtUtils::MakeMaker" : "0"
+         }
+      },
+      "runtime" : {
+         "requires" : {
+            "Carp" : "0",
+            "Exporter" : "0",
+            "XSLoader" : "0",
+            "base" : "0",
+            "overload" : "0",
+            "perl" : "5.006000",
+            "strict" : "0",
+            "warnings" : "0"
+         }
+      },
+      "test" : {
+         "requires" : {
+            "Test::More" : "0"
+         }
+      }
+   },
+   "release_status" : "stable",
+   "resources" : {
+      "bugtracker" : {
+         "web" : "https://github.com/pali/Email-Address-XS/issues"
+      },
+      "repository" : {
+         "type" : "git",
+         "url" : "git://github.com/pali/Email-Address-XS.git",
+         "web" : "https://github.com/pali/Email-Address-XS"
+      }
+   },
+   "version" : "1.05",
+   "x_serialization_backend" : "JSON::PP version 2.97001"
+}

META.yml

@@ -0,0 +1,34 @@
+---
+abstract: 'Parse and format RFC 5322 email addresses and groups'
+author:
+  - 'Pali <pali@cpan.org>'
+build_requires:
+  ExtUtils::MakeMaker: '0'
+  Test::More: '0'
+configure_requires:
+  ExtUtils::MakeMaker: '0'
+dynamic_config: 0
+generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010'
+license: perl
+meta-spec:
+  url: http://module-build.sourceforge.net/META-spec-v1.4.html
+  version: '1.4'
+name: Email-Address-XS
+no_index:
+  directory:
+    - t
+    - inc
+requires:
+  Carp: '0'
+  Exporter: '0'
+  XSLoader: '0'
+  base: '0'
+  overload: '0'
+  perl: '5.006000'
+  strict: '0'
+  warnings: '0'
+resources:
+  bugtracker: https://github.com/pali/Email-Address-XS/issues
+  repository: git://github.com/pali/Email-Address-XS.git
+version: '1.05'
+x_serialization_backend: 'CPAN::Meta::YAML version 0.018'

Makefile.PL

@@ -0,0 +1,46 @@
+#!/usr/bin/perl
+use ExtUtils::MakeMaker;
+WriteMakefile(
+	NAME             => 'Email::Address::XS',
+	VERSION_FROM     => 'lib/Email/Address/XS.pm',
+	ABSTRACT_FROM    => 'lib/Email/Address/XS.pm',
+	AUTHOR           => 'Pali <pali@cpan.org>',
+	H                => [ 'dovecot-parser.h' ],
+	C                => [ 'dovecot-parser.c', 'Email-Address-XS.c' ],
+	XS               => { 'Email-Address-XS.xs' => 'Email-Address-XS.c' },
+	OBJECT           => '$(O_FILES)',
+	NORECURS         => 1,
+	LICENSE          => 'perl_5',
+	MIN_PERL_VERSION => '5.6.0',
+
+	PREREQ_PM => {
+		'base'       => '0',
+		'overload'   => '0',
+		'strict'     => '0',
+		'warnings'   => '0',
+		'Carp'       => '0',
+		'Exporter'   => '0',
+		'XSLoader'   => '0',
+	},
+	TEST_REQUIRES => {
+		'Test::More' => '0',
+	},
+	eval { ExtUtils::MakeMaker->VERSION('6.68') } ? (
+	META_MERGE => {
+		'meta-spec' => {
+			version => 2,
+		},
+		'resources' => {
+			bugtracker => {
+				web  => 'https://github.com/pali/Email-Address-XS/issues',
+			},
+			repository => {
+				url  => 'git://github.com/pali/Email-Address-XS.git',
+				web  => 'https://github.com/pali/Email-Address-XS',
+				type => 'git',
+			},
+		},
+		'dynamic_config' => 0,
+	},
+	) : (),
+);

README

@@ -0,0 +1,55 @@
+Email-Address-XS
+================
+
+This module implements RFC 5322 parser and formatter of email addresses
+and groups. It parses an input string from email headers which contain
+a list of email addresses or a groups of email addresses (like From,
+To, Cc, Bcc, Reply-To, Sender, ...). Also it can generate a string
+value for those headers from a list of email addresses objects.
+Module is backward compatible with RFC 2822 and RFC 822.
+
+Parser and formatter functionality is implemented in XS and uses
+shared code from Dovecot IMAP server.
+
+It is a drop-in replacement for the Email::Address module which has
+several security issues. E.g. issue CVE-2015-7686 (Algorithmic
+complexity vulnerability) which allows remote attackers to cause
+denial of service, is still present in Email::Address version 1.908.
+
+Email::Address::XS module was created to finally fix CVE-2015-7686.
+
+Existing applications that use Email::Address module could be easily
+switched to Email::Address::XS module. In most cases only changing
+'use Email::Address' to 'use Email::Address::XS' and replacing every
+'Email::Address' occurrence with 'Email::Address::XS' is sufficient.
+
+So unlike Email::Address, this module does not use regular expressions
+for parsing but instead native XS implementation parses input string
+sequentially according to RFC 5322 grammar.
+
+Additionally it has support also for named groups and so can be use
+instead of the Email::Address::List module.
+
+INSTALLATION
+
+To install this module type the following:
+
+   perl Makefile.PL
+   make
+   make test
+   make install
+
+DEPENDENCIES
+
+None
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2015-2018 by Pali <pali@cpan.org>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.6.0 or,
+at your option, any later version of Perl 5 you may have available.
+
+Dovecot parser is licensed under The MIT License and copyrighted by
+Dovecot authors.

dovecot-parser.h

@@ -0,0 +1,64 @@
+#ifndef DOVECOT_PARSER_H
+#define DOVECOT_PARSER_H
+
+#include <stdbool.h>
+
+enum message_address_parse_flags {
+	/* If enabled, missing mailbox and domain are set to MISSING_MAILBOX
+	   and MISSING_DOMAIN strings. Otherwise they're set to "". */
+	MESSAGE_ADDRESS_PARSE_FLAG_FILL_MISSING = (1 << 0),
+	/* Require local-part to strictly adhere to RFC5322 when parsing dots.
+	   For example ".user", "us..ser" and "user." will be invalid. This
+	   isn't enabled by default, because these kind of invalid addresses
+	   are commonly used in Japan. */
+	MESSAGE_ADDRESS_PARSE_FLAG_STRICT_DOTS = (1 << 1),
+	/* Same as MESSAGE_ADDRESS_PARSE_FLAG_STRICT_DOTS, but accept also
+	   non-strict input. Flag invalid_syntax will be set to true. */
+	MESSAGE_ADDRESS_PARSE_FLAG_NON_STRICT_DOTS_AS_INVALID = (1 << 2),
+};
+
+/* group: ... ; will be stored like:
+   {name = NULL, NULL, "group", NULL}, ..., {NULL, NULL, NULL, NULL}
+*/
+struct message_address {
+	struct message_address *next;
+
+	/* display-name */
+	char *name;
+	size_t name_len;
+	/* route string contains the @ prefix */
+	char *route;
+	size_t route_len;
+	/* local-part */
+	char *mailbox;
+	size_t mailbox_len;
+	char *domain;
+	size_t domain_len;
+	char *comment;
+	size_t comment_len;
+	char *original;
+	size_t original_len;
+	/* there were errors when parsing this address */
+	bool invalid_syntax;
+};
+
+/* Parse message addresses from given data. Note that giving an empty string
+   will return NULL since there are no addresses. */
+struct message_address *
+message_address_parse(const char *str, size_t len, unsigned int max_addresses, enum message_address_parse_flags flags);
+
+void message_address_add(struct message_address **first, struct message_address **last,
+			 const char *name, size_t name_len, const char *route, size_t route_len,
+			 const char *mailbox, size_t mailbox_len, const char *domain, size_t domain_len,
+			 const char *comment, size_t comment_len);
+
+void message_address_free(struct message_address **addr);
+
+void message_address_write(char **str, size_t *len, const struct message_address *addr);
+
+void compose_address(char **output, size_t *output_len, const char *mailbox, size_t mailbox_len, const char *domain, size_t domain_len);
+void split_address(const char *input, size_t input_len, char **mailbox, size_t *mailbox_len, char **domain, size_t *domain_len);
+
+void string_free(char *string);
+
+#endif

lib/Email/Address/XS.pm

@@ -0,0 +1,680 @@
+# Copyright (c) 2015-2018 by Pali <pali@cpan.org>
+
+package Email::Address::XS;
+
+use 5.006;
+use strict;
+use warnings;
+
+our $VERSION = '1.05';
+
+use Carp;
+
+use base 'Exporter';
+our @EXPORT_OK = qw(parse_email_addresses parse_email_groups format_email_addresses format_email_groups compose_address split_address);
+
+use XSLoader;
+XSLoader::load(__PACKAGE__, $VERSION);
+
+=head1 NAME
+
+Email::Address::XS - Parse and format RFC 5322 email addresses and groups
+
+=head1 SYNOPSIS
+
+  use Email::Address::XS;
+
+  my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', user => 'winston.smith', host => 'recdep.minitrue', comment => 'Records Department');
+  print $winstons_address->address();
+  # winston.smith@recdep.minitrue
+
+  my $julias_address = Email::Address::XS->new('Julia', 'julia@ficdep.minitrue');
+  print $julias_address->format();
+  # Julia <julia@ficdep.minitrue>
+
+  my $users_address = Email::Address::XS->parse('user <user@oceania>');
+  print $users_address->host();
+  # oceania
+
+  my $goldsteins_address = Email::Address::XS->parse_bare_address('goldstein@brotherhood.oceania');
+  print $goldsteins_address->user();
+  # goldstein
+
+  my @addresses = Email::Address::XS->parse('"Winston Smith" <winston.smith@recdep.minitrue> (Records Department), Julia <julia@ficdep.minitrue>');
+  # ($winstons_address, $julias_address)
+
+
+  use Email::Address::XS qw(format_email_addresses format_email_groups parse_email_addresses parse_email_groups);
+
+  my $addresses_string = format_email_addresses($winstons_address, $julias_address, $users_address);
+  # "Winston Smith" <winston.smith@recdep.minitrue> (Records Department), Julia <julia@ficdep.minitrue>, user <user@oceania>
+
+  my @addresses = map { $_->address() } parse_email_addresses($addresses_string);
+  # ('winston.smith@recdep.minitrue', 'julia@ficdep.minitrue', 'user@oceania')
+
+  my $groups_string = format_email_groups('Brotherhood' => [ $winstons_address, $julias_address ], undef() => [ $users_address ]);
+  # Brotherhood: "Winston Smith" <winston.smith@recdep.minitrue> (Records Department), Julia <julia@ficdep.minitrue>;, user <user@oceania>
+
+  my @groups = parse_email_groups($groups_string);
+  # ('Brotherhood' => [ $winstons_address, $julias_address ], undef() => [ $users_address ])
+
+
+  use Email::Address::XS qw(compose_address split_address);
+
+  my ($user, $host) = split_address('julia(outer party)@ficdep.minitrue');
+  # ('julia', 'ficdep.minitrue')
+
+  my $string = compose_address('charrington"@"shop', 'thought.police.oceania');
+  # "charrington\"@\"shop"@thought.police.oceania
+
+=head1 DESCRIPTION
+
+This module implements L<RFC 5322|https://tools.ietf.org/html/rfc5322>
+parser and formatter of email addresses and groups. It parses an input
+string from email headers which contain a list of email addresses or
+a groups of email addresses (like From, To, Cc, Bcc, Reply-To, Sender,
+...). Also it can generate a string value for those headers from a
+list of email addresses objects. Module is backward compatible with
+L<RFC 2822|https://tools.ietf.org/html/rfc2822> and
+L<RFC 822|https://tools.ietf.org/html/rfc822>.
+
+Parser and formatter functionality is implemented in XS and uses
+shared code from Dovecot IMAP server.
+
+It is a drop-in replacement for L<the Email::Address module|Email::Address>
+which has several security issues. E.g. issue L<CVE-2015-7686 (Algorithmic complexity vulnerability)|https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2015-7686>,
+which allows remote attackers to cause denial of service, is still
+present in L<Email::Address|Email::Address> version 1.908.
+
+Email::Address::XS module was created to finally fix CVE-2015-7686.
+
+Existing applications that use Email::Address module could be easily
+switched to Email::Address::XS module. In most cases only changing
+C<use Email::Address> to C<use Email::Address::XS> and replacing every
+C<Email::Address> occurrence with C<Email::Address::XS> is sufficient.
+
+So unlike L<Email::Address|Email::Address>, this module does not use
+regular expressions for parsing but instead native XS implementation
+parses input string sequentially according to RFC 5322 grammar.
+
+Additionally it has support also for named groups and so can be use
+instead of L<the Email::Address::List module|Email::Address::List>.
+
+If you are looking for the module which provides object representation
+for the list of email addresses suitable for the MIME email headers,
+see L<Email::MIME::Header::AddressList|Email::MIME::Header::AddressList>.
+
+=head2 EXPORT
+
+None by default. Exportable functions are:
+L<C<parse_email_addresses>|/parse_email_addresses>,
+L<C<parse_email_groups>|/parse_email_groups>,
+L<C<format_email_addresses>|/format_email_addresses>,
+L<C<format_email_groups>|/format_email_groups>,
+L<C<compose_address>|/compose_address>,
+L<C<split_address>|/split_address>.
+
+=head2 Exportable Functions
+
+=over 4
+
+=item format_email_addresses
+
+  use Email::Address::XS qw(format_email_addresses);
+
+  my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston@recdep.minitrue');
+  my $julias_address = Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue');
+  my @addresses = ($winstons_address, $julias_address);
+  my $string = format_email_addresses(@addresses);
+  print $string;
+  # "Winston Smith" <winston@recdep.minitrue>, Julia <julia@ficdep.minitrue>
+
+Takes a list of email address objects and returns one formatted string
+of those email addresses.
+
+=cut
+
+sub format_email_addresses {
+	my (@args) = @_;
+	return format_email_groups(undef, \@args);
+}
+
+=item format_email_groups
+
+  use Email::Address::XS qw(format_email_groups);
+
+  my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', user => 'winston.smith', host => 'recdep.minitrue');
+  my $julias_address = Email::Address::XS->new('Julia', 'julia@ficdep.minitrue');
+  my $users_address = Email::Address::XS->new(address => 'user@oceania');
+
+  my $groups_string = format_email_groups('Brotherhood' => [ $winstons_address, $julias_address ], undef() => [ $users_address ]);
+  print $groups_string;
+  # Brotherhood: "Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>;, user@oceania
+
+  my $undisclosed_string = format_email_groups('undisclosed-recipients' => []);
+  print $undisclosed_string;
+  # undisclosed-recipients:;
+
+Like L<C<format_email_addresses>|/format_email_addresses> but this
+method takes pairs which consist of a group display name and a
+reference to address list. If a group is not undef then address
+list is formatted inside named group.
+
+=item parse_email_addresses
+
+  use Email::Address::XS qw(parse_email_addresses);
+
+  my $string = '"Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>, user@oceania';
+  my @addresses = parse_email_addresses($string);
+  # @addresses now contains three Email::Address::XS objects, one for each address
+
+Parses an input string and returns a list of Email::Address::XS
+objects. Optional second string argument specifies class name for
+blessing new objects.
+
+=cut
+
+sub parse_email_addresses {
+	my (@args) = @_;
+	my $t = 1;
+	return map { @{$_} } grep { $t ^= 1 } parse_email_groups(@args);
+}
+
+=item parse_email_groups
+
+  use Email::Address::XS qw(parse_email_groups);
+
+  my $string = 'Brotherhood: "Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>;, user@oceania, undisclosed-recipients:;';
+  my @groups = parse_email_groups($string);
+  # @groups now contains list ('Brotherhood' => [ $winstons_object, $julias_object ], undef() => [ $users_object ], 'undisclosed-recipients' => [])
+
+Like L<C<parse_email_addresses>|/parse_email_addresses> but this
+function returns a list of pairs: a group display name and a
+reference to a list of addresses which belongs to that named group.
+An undef value for a group means that a following list of addresses
+is not inside any named group. An output is in a same format as a
+input for the function L<C<format_email_groups>|/format_email_groups>.
+This function preserves order of groups and does not do any
+de-duplication or merging.
+
+=item compose_address
+
+  use Email::Address::XS qw(compose_address);
+  my $string_address = compose_address($user, $host);
+
+Takes an unescaped user part and unescaped host part of an address
+and returns escaped address.
+
+Available since version 1.01.
+
+=item split_address
+
+  use Email::Address::XS qw(split_address);
+  my ($user, $host) = split_address($string_address);
+
+Takes an escaped address and split it into pair of unescaped user
+part and unescaped host part of address. If splitting input address
+into these two parts is not possible then this function returns
+pair of undefs.
+
+Available since version 1.01.
+
+=back
+
+=head2 Class Methods
+
+=over 4
+
+=item new
+
+  my $empty_address = Email::Address::XS->new();
+  my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', user => 'winston.smith', host => 'recdep.minitrue', comment => 'Records Department');
+  my $julias_address = Email::Address::XS->new('Julia', 'julia@ficdep.minitrue');
+  my $users_address = Email::Address::XS->new(address => 'user@oceania');
+  my $only_name = Email::Address::XS->new(phrase => 'Name');
+  my $copy_of_winstons_address = Email::Address::XS->new(copy => $winstons_address);
+
+Constructs and returns a new C<Email::Address::XS> object. Takes named
+list of arguments: phrase, address, user, host, comment and copy.
+An argument address takes precedence over user and host.
+
+When an argument copy is specified then it is expected an
+Email::Address::XS object and a cloned copy of that object is
+returned. All other parameters are ignored.
+
+Old syntax L<from the Email::Address module|Email::Address/new> is
+supported too. Takes one to four positional arguments: phrase, address
+comment, and original string. Passing an argument original is
+deprecated, ignored and throws a warning.
+
+=cut
+
+sub new {
+	my ($class, @args) = @_;
+
+	my %hash_keys = (phrase => 1, address => 1, user => 1, host => 1, comment => 1, copy => 1);
+	my $is_hash;
+	if ( scalar @args == 2 and defined $args[0] ) {
+		$is_hash = 1 if exists $hash_keys{$args[0]};
+	} elsif ( scalar @args == 4 and defined $args[0] and defined $args[2] ) {
+		$is_hash = 1 if exists $hash_keys{$args[0]} and exists $hash_keys{$args[2]};
+	} elsif ( scalar @args > 4 ) {
+		$is_hash = 1;
+	}
+
+	my %args;
+	if ( $is_hash ) {
+		%args = @args;
+	} else {
+		carp 'Argument original is deprecated and ignored' if scalar @args > 3;
+		$args{comment} = $args[2] if scalar @args > 2;
+		$args{address} = $args[1] if scalar @args > 1;
+		$args{phrase} = $args[0] if scalar @args > 0;
+	}
+
+	my $invalid;
+	my $original;
+	if ( exists $args{copy} ) {
+		if ( $class->is_obj($args{copy}) ) {
+			$args{phrase} = $args{copy}->phrase();
+			$args{comment} = $args{copy}->comment();
+			$args{user} = $args{copy}->user();
+			$args{host} = $args{copy}->host();
+			$invalid = $args{copy}->{invalid};
+			$original = $args{copy}->{original};
+			delete $args{address};
+		} else {
+			carp 'Named argument copy does not contain a valid object';
+		}
+	}
+
+	my $self = bless {}, $class;
+
+	$self->phrase($args{phrase});
+	$self->comment($args{comment});
+
+	if ( exists $args{address} ) {
+		$self->address($args{address});
+	} else {
+		$self->user($args{user});
+		$self->host($args{host});
+	}
+
+	$self->{invalid} = 1 if $invalid;
+	$self->{original} = $original;
+
+	return $self;
+}
+
+=item parse
+
+  my $winstons_address = Email::Address::XS->parse('"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)');
+  my @users_addresses = Email::Address::XS->parse('user1@oceania, user2@oceania');
+
+Parses an input string and returns a list of an Email::Address::XS
+objects. Same as the function L<C<parse_email_addresses>|/parse_email_addresses>
+but this one is class method.
+
+In scalar context this function returns just first parsed object.
+If more then one object was parsed then L<C<is_valid>|/is_valid>
+method on returned object returns false. If no object was parsed
+then empty Email::Address::XS object is returned.
+
+Prior to version 1.01 return value in scalar context is undef when
+no object was parsed.
+
+=cut
+
+sub parse {
+	my ($class, $string) = @_;
+	my @addresses = parse_email_addresses($string, $class);
+	return @addresses if wantarray;
+	my $self = @addresses ? $addresses[0] : Email::Address::XS->new();
+	$self->{invalid} = 1 if scalar @addresses != 1;
+	$self->{original} = $string unless defined $self->{original};
+	return $self;
+}
+
+=item parse_bare_address
+
+  my $winstons_address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue');
+
+Parses an input string as one bare email address (addr spec) which
+does not allow phrase part or angle brackets around email address and
+returns an Email::Address::XS object. It is just a wrapper around
+L<C<address>|/address> method. Method L<C<is_valid>|/is_valid> can be
+used to check if parsing was successful.
+
+Available since version 1.01.
+
+=cut
+
+sub parse_bare_address {
+	my ($class, $string) = @_;
+	my $self = $class->new();
+	if ( defined $string ) {
+		$self->address($string);
+		$self->{original} = $string;
+	} else {
+		carp 'Use of uninitialized value for string';
+	}
+	return $self;
+}
+
+=back
+
+=head2 Object Methods
+
+=over 4
+
+=item format
+
+  my $string = $address->format();
+
+Returns formatted Email::Address::XS object as a string. This method
+throws a warning when L<C<user>|/user> or L<C<host>|/host> part of
+the email address is invalid or empty string.
+
+=cut
+
+sub format {
+	my ($self) = @_;
+	return format_email_addresses($self);
+}
+
+=item is_valid
+
+  my $is_valid = $address->is_valid();
+
+Returns true if the parse function or method which created this
+Email::Address::XS object had not received any syntax error on input
+string and also that L<C<user>|/user> and L<C<host>|/host> part of
+the email address are not empty strings.
+
+Thus this function can be used for checking if Email::Address::XS
+object is valid before calling L<C<format>|/format> method on it.
+
+Available since version 1.01.
+
+=cut
+
+sub is_valid {
+	my ($self) = @_;
+	my $user = $self->user();
+	my $host = $self->host();
+	return (defined $user and defined $host and length $host and not $self->{invalid});
+}
+
+=item phrase
+
+  my $phrase = $address->phrase();
+  $address->phrase('Winston Smith');
+
+Accessor and mutator for the phrase (display name).
+
+=cut
+
+sub phrase {
+	my ($self, @args) = @_;
+	return $self->{phrase} unless @args;
+	delete $self->{invalid} if exists $self->{invalid};
+	return $self->{phrase} = $args[0];
+}
+
+=item user
+
+  my $user = $address->user();
+  $address->user('winston.smith');
+
+Accessor and mutator for the unescaped user (local/mailbox) part of
+an address.
+
+=cut
+
+sub user {
+	my ($self, @args) = @_;
+	return $self->{user} unless @args;
+	delete $self->{cached_address} if exists $self->{cached_address};
+	delete $self->{invalid} if exists $self->{invalid};
+	return $self->{user} = $args[0];
+}
+
+=item host
+
+  my $host = $address->host();
+  $address->host('recdep.minitrue');
+
+Accessor and mutator for the unescaped host (domain) part of an address.
+
+Since version 1.03 this method checks if setting a new value is syntactically
+valid. If not undef is set and returned.
+
+=cut
+
+sub host {
+	my ($self, @args) = @_;
+	return $self->{host} unless @args;
+	delete $self->{cached_address} if exists $self->{cached_address};
+	delete $self->{invalid} if exists $self->{invalid};
+	if (defined $args[0] and $args[0] =~ /^(?:\[.*\]|[^\x00-\x20\x7F()<>\[\]:;@\\,"]+)$/) {
+		return $self->{host} = $args[0];
+	} else {
+		return $self->{host} = undef;
+	}
+}
+
+=item address
+
+  my $string_address = $address->address();
+  $address->address('winston.smith@recdep.minitrue');
+
+Accessor and mutator for the escaped address (addr spec).
+
+Internally this module stores a user and a host part of an address
+separately. Function L<C<compose_address>|/compose_address> is used
+for composing full address and function L<C<split_address>|/split_address>
+for splitting into a user and a host parts. If splitting new address
+into these two parts is not possible then this method returns undef
+and sets both parts to undef.
+
+=cut
+
+sub address {
+	my ($self, @args) = @_;
+	my $user;
+	my $host;
+	if ( @args ) {
+		delete $self->{invalid} if exists $self->{invalid};
+		($user, $host) = split_address($args[0]) if defined $args[0];
+		if ( not defined $user or not defined $host ) {
+			$user = undef;
+			$host = undef;
+		}
+		$self->{user} = $user;
+		$self->{host} = $host;
+	} else {
+		return $self->{cached_address} if exists $self->{cached_address};
+		$user = $self->user();
+		$host = $self->host();
+	}
+	if ( defined $user and defined $host and length $host ) {
+		return $self->{cached_address} = compose_address($user, $host);
+	} else {
+		return $self->{cached_address} = undef;
+	}
+}
+
+=item comment
+
+  my $comment = $address->comment();
+  $address->comment('Records Department');
+
+Accessor and mutator for the comment which is formatted after an
+address. A comment can contain another nested comments in round
+brackets. When setting new comment this method check if brackets are
+balanced. If not undef is set and returned.
+
+=cut
+
+sub comment {
+	my ($self, @args) = @_;
+	return $self->{comment} unless @args;
+	delete $self->{invalid} if exists $self->{invalid};
+	return $self->{comment} = undef unless defined $args[0];
+	my $count = 0;
+	my $cleaned = $args[0];
+	$cleaned =~ s/(?:\\.|[^\(\)\x00])//g;
+	foreach ( split //, $cleaned ) {
+		$count++ if $_ eq '(';
+		$count-- if $_ eq ')';
+		$count = -1 if $_ eq "\x00";
+		last if $count < 0;
+	}
+	return $self->{comment} = undef if $count != 0;
+	return $self->{comment} = $args[0];
+}
+
+=item name
+
+  my $name = $address->name();
+
+This method tries to return a name which belongs to the address. It
+returns either L<C<phrase>|/phrase> or L<C<comment>|/comment> or
+L<C<user>|/user> part of the address or empty string (first defined
+value in this order). But it never returns undef.
+
+=cut
+
+sub name {
+	my ($self) = @_;
+	my $phrase = $self->phrase();
+	return $phrase if defined $phrase and length $phrase;
+	my $comment = $self->comment();
+	return $comment if defined $comment and length $comment;
+	my $user = $self->user();
+	return $user if defined $user;
+	return '';
+}
+
+=item as_string
+
+  my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue');
+  my $stringified = $address->as_string();
+
+This method is used for object L<stringification|/stringify>. It
+returns string representation of object. By default object is
+stringified to L<C<format>|/format>.
+
+Available since version 1.01.
+
+=cut
+
+our $STRINGIFY; # deprecated
+
+sub as_string {
+	my ($self) = @_;
+	return $self->format() unless defined $STRINGIFY;
+	carp 'Variable $Email::Address::XS::STRINGIFY is deprecated; subclass instead';
+	my $method = $self->can($STRINGIFY);
+	croak 'Stringify method ' . $STRINGIFY . ' does not exist' unless defined $method;
+	return $method->($self);
+}
+
+=item original
+
+  my $address = Email::Address::XS->parse('(Winston) "Smith"   <winston.smith@recdep.minitrue> (Minitrue)');
+  my $original = $address->original();
+  # (Winston) "Smith"   <winston.smith@recdep.minitrue> (Minitrue)
+  my $format = $address->format();
+  # Smith <winston.smith@recdep.minitrue> (Minitrue)
+
+This method returns original part of the string which was used for
+parsing current Email::Address::XS object. If object was not created
+by parsing input string, then this method returns undef.
+
+Note that L<C<format>|/format> method does not have to return same
+original string.
+
+Available since version 1.01.
+
+=cut
+
+sub original {
+	my ($self) = @_;
+	return $self->{original};
+}
+
+=back
+
+=head2 Overloaded Operators
+
+=over 4
+
+=item stringify
+
+  my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue');
+  print "Winston's address is $address.";
+  # Winston's address is "Winston Smith" <winston.smith@recdep.minitrue>.
+
+Stringification is done by method L<C<as_string>|/as_string>.
+
+=cut
+
+use overload '""' => \&as_string;
+
+=back
+
+=head2 Deprecated Functions and Variables
+
+For compatibility with L<the Email::Address module|Email::Address>
+there are defined some deprecated functions and variables.
+Do not use them in new code. Their usage throws warnings.
+
+Altering deprecated variable C<$Email::Address::XS::STRINGIFY> changes
+method which is called for objects stringification.
+
+Deprecated cache functions C<purge_cache>, C<disable_cache> and
+C<enable_cache> are noop and do nothing.
+
+=cut
+
+sub purge_cache {
+	carp 'Function purge_cache is deprecated and does nothing';
+}
+
+sub disable_cache {
+	carp 'Function disable_cache is deprecated and does nothing';
+}
+
+sub enable_cache {
+	carp 'Function enable_cache is deprecated and does nothing';
+}
+
+=head1 SEE ALSO
+
+L<RFC 822|https://tools.ietf.org/html/rfc822>,
+L<RFC 2822|https://tools.ietf.org/html/rfc2822>,
+L<RFC 5322|https://tools.ietf.org/html/rfc5322>,
+L<Email::MIME::Header::AddressList>,
+L<Email::Address>,
+L<Email::Address::List>,
+L<Email::AddressParser>
+
+=head1 AUTHOR
+
+Pali E<lt>pali@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2015-2018 by Pali E<lt>pali@cpan.orgE<gt>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.6.0 or,
+at your option, any later version of Perl 5 you may have available.
+
+Dovecot parser is licensed under The MIT License and copyrighted by
+Dovecot authors.
+
+=cut
+
+1;

t/taint-Email-Address-XS.t

@@ -0,0 +1,194 @@
+#!/usr/bin/perl -T
+# Copyright (c) 2015-2017 by Pali <pali@cpan.org>
+
+#########################
+
+use strict;
+use warnings;
+
+local $SIG{__WARN__} = sub { fail('following test does not throw warning'); warn $_[0]; };
+
+use Carp;
+$Carp::Internal{'Test::Builder'} = 1;
+$Carp::Internal{'Test::More'} = 1;
+
+use Test::More tests => 137;
+use Test::Builder;
+
+#########################
+
+sub is_tainted {
+	local $@;   # Don't pollute caller's value.
+	return ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 };
+}
+
+sub test_tainted {
+	my ($got, $expected, $subtest) = @_;
+	local $Test::Builder::Level = $Test::Builder::Level + 1;
+	ok(is_tainted($got), $subtest);
+	is($got, $expected, $subtest);
+}
+
+sub test_not_tainted {
+	my ($got, $expected, $subtest) = @_;
+	local $Test::Builder::Level = $Test::Builder::Level + 1;
+	ok(!is_tainted($got), $subtest);
+	is($got, $expected, $subtest);
+}
+
+sub taint {
+	my ($str) = @_;
+	return substr($ENV{PATH}, 0, 0) . $str;
+}
+
+#########################
+
+BEGIN {
+	use_ok('Email::Address::XS');
+};
+
+#########################
+
+my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue', comment => 'Records Department');
+
+{
+	my $subtest = 'no tainted arguments';
+	test_not_tainted($address->phrase(), 'Winston Smith', $subtest);
+	test_not_tainted($address->user(), 'winston.smith', $subtest);
+	test_not_tainted($address->host(), 'recdep.minitrue', $subtest);
+	test_not_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
+	test_not_tainted($address->comment(), 'Records Department', $subtest);
+	test_not_tainted($address->name(), 'Winston Smith', $subtest);
+	test_not_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
+}
+
+$address->phrase(taint('Winston Smith'));
+
+{
+	my $subtest = 'tainted phrase argument';
+	test_tainted($address->phrase(), 'Winston Smith', $subtest);
+	test_not_tainted($address->user(), 'winston.smith', $subtest);
+	test_not_tainted($address->host(), 'recdep.minitrue', $subtest);
+	test_not_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
+	test_not_tainted($address->comment(), 'Records Department', $subtest);
+	test_tainted($address->name(), 'Winston Smith', $subtest);
+	test_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
+}
+
+$address->phrase('Winston Smith');
+
+$address->user(taint('winston.smith'));
+
+{
+	my $subtest = 'tainted user argument';
+	test_not_tainted($address->phrase(), 'Winston Smith', $subtest);
+	test_tainted($address->user(), 'winston.smith', $subtest);
+	test_not_tainted($address->host(), 'recdep.minitrue', $subtest);
+	test_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
+	test_not_tainted($address->comment(), 'Records Department', $subtest);
+	test_not_tainted($address->name(), 'Winston Smith', $subtest);
+	test_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
+}
+
+$address->user('winston.smith');
+
+$address->host(taint('recdep.minitrue'));
+
+{
+	my $subtest = 'tainted host argument';
+	test_not_tainted($address->phrase(), 'Winston Smith', $subtest);
+	test_not_tainted($address->user(), 'winston.smith', $subtest);
+	test_tainted($address->host(), 'recdep.minitrue', $subtest);
+	test_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
+	test_not_tainted($address->comment(), 'Records Department', $subtest);
+	test_not_tainted($address->name(), 'Winston Smith', $subtest);
+	test_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
+}
+
+$address->host('recdep.minitrue');
+
+$address->address(taint('winston.smith@recdep.minitrue'));
+
+{
+	my $subtest = 'tainted address argument';
+	test_not_tainted($address->phrase(), 'Winston Smith', $subtest);
+	test_tainted($address->user(), 'winston.smith', $subtest);
+	test_tainted($address->host(), 'recdep.minitrue', $subtest);
+	test_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
+	test_not_tainted($address->comment(), 'Records Department', $subtest);
+	test_not_tainted($address->name(), 'Winston Smith', $subtest);
+	test_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
+}
+
+$address->address('winston.smith@recdep.minitrue');
+
+$address->comment(taint('Records Department'));
+
+{
+	my $subtest = 'tainted address argument';
+	test_not_tainted($address->phrase(), 'Winston Smith', $subtest);
+	test_not_tainted($address->user(), 'winston.smith', $subtest);
+	test_not_tainted($address->host(), 'recdep.minitrue', $subtest);
+	test_not_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
+	test_tainted($address->comment(), 'Records Department', $subtest);
+	test_not_tainted($address->name(), 'Winston Smith', $subtest);
+	test_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
+}
+
+undef $address;
+
+$address = Email::Address::XS->parse('"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)');
+
+{
+	my $subtest = 'no tainted parse';
+	test_not_tainted($address->phrase(), 'Winston Smith', $subtest);
+	test_not_tainted($address->user(), 'winston.smith', $subtest);
+	test_not_tainted($address->host(), 'recdep.minitrue', $subtest);
+	test_not_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
+	test_not_tainted($address->comment(), 'Records Department', $subtest);
+	test_not_tainted($address->name(), 'Winston Smith', $subtest);
+	test_not_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
+	test_not_tainted($address->original(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
+}
+
+undef $address;
+
+$address = Email::Address::XS->parse(taint('"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)'));
+
+{
+	my $subtest = 'tainted parse';
+	test_tainted($address->phrase(), 'Winston Smith', $subtest);
+	test_tainted($address->user(), 'winston.smith', $subtest);
+	test_tainted($address->host(), 'recdep.minitrue', $subtest);
+	test_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
+	test_tainted($address->comment(), 'Records Department', $subtest);
+	test_tainted($address->name(), 'Winston Smith', $subtest);
+	test_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
+	test_tainted($address->original(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
+}
+
+undef $address;
+
+$address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue');
+
+{
+	my $subtest = 'no tainted parse_bare_address';
+	test_not_tainted($address->user(), 'winston.smith', $subtest);
+	test_not_tainted($address->host(), 'recdep.minitrue', $subtest);
+	test_not_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
+	test_not_tainted($address->format(), 'winston.smith@recdep.minitrue', $subtest);
+	test_not_tainted($address->original(), 'winston.smith@recdep.minitrue', $subtest);
+}
+
+undef $address;
+
+$address = Email::Address::XS->parse_bare_address(taint('winston.smith@recdep.minitrue'));
+
+{
+	my $subtest = 'tainted parse_bare_address';
+	test_tainted($address->user(), 'winston.smith', $subtest);
+	test_tainted($address->host(), 'recdep.minitrue', $subtest);
+	test_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
+	test_tainted($address->format(), 'winston.smith@recdep.minitrue', $subtest);
+	test_tainted($address->original(), 'winston.smith@recdep.minitrue', $subtest);
+}