commit ea95dfa58a682eae0dc153f0bac3625949b34fec Author: su-fang Date: Thu Sep 22 11:25:38 2022 +0800 Import Upstream version 1.05 diff --git a/Changes b/Changes new file mode 100644 index 0000000..32cf454 --- /dev/null +++ b/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 + diff --git a/Email-Address-XS.xs b/Email-Address-XS.xs new file mode 100644 index 0000000..806fc0e --- /dev/null +++ b/Email-Address-XS.xs @@ -0,0 +1,779 @@ +/* Copyright (c) 2015-2018 by Pali */ + +#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 diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..25ad781 --- /dev/null +++ b/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) diff --git a/META.json b/META.json new file mode 100644 index 0000000..4bdd49d --- /dev/null +++ b/META.json @@ -0,0 +1,64 @@ +{ + "abstract" : "Parse and format RFC 5322 email addresses and groups", + "author" : [ + "Pali " + ], + "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" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..5171e29 --- /dev/null +++ b/META.yml @@ -0,0 +1,34 @@ +--- +abstract: 'Parse and format RFC 5322 email addresses and groups' +author: + - 'Pali ' +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' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..4a31e95 --- /dev/null +++ b/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 ', + 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, + }, + ) : (), +); diff --git a/README b/README new file mode 100644 index 0000000..31e4144 --- /dev/null +++ b/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 + +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. diff --git a/dovecot-parser.c b/dovecot-parser.c new file mode 100644 index 0000000..474ffeb --- /dev/null +++ b/dovecot-parser.c @@ -0,0 +1,1566 @@ +/* + * Copyright (c) 2002-2018 Dovecot authors + * Copyright (c) 2015-2018 Pali + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ + +#include +#include +#include +#include +#include + +#include "dovecot-parser.h" + +#ifndef SIZE_MAX +#define SIZE_MAX ((size_t)-1) +#endif + +void i_panic(const char *format, ...); + +#ifdef DEBUG +#define i_assert(expr) \ + do { if (!(expr)) \ + i_panic("file %s: line %d (%s): assertion failed: (%s)", \ + __FILE__, \ + __LINE__, \ + __FUNCTION__, \ + #expr); \ + } while ( 0 ) +#else +#define i_assert(expr) +#endif + +typedef struct { + char *buf; + size_t len; + size_t size; +} string_t; + +struct rfc822_parser_context { + const unsigned char *data, *end; + string_t *last_comment; + + /* Replace NUL characters with this string */ + const char *nul_replacement_str; +}; + +struct message_address_parser_context { + struct rfc822_parser_context parser; + + struct message_address *first_addr, *last_addr, addr; + string_t *str; + + bool fill_missing, non_strict_dots, non_strict_dots_as_invalid; +}; + +static string_t *str_new(size_t initial_size) +{ + char *buf; + string_t *str; + + if (!initial_size) + initial_size = 1; + + if (initial_size >= SIZE_MAX / 2) + i_panic("str_new() failed: %s", "initial_size is too big"); + + buf = malloc(initial_size); + if (!buf) + i_panic("malloc() failed: %s", strerror(errno)); + + str = malloc(sizeof(string_t)); + if (!str) + i_panic("malloc() failed: %s", strerror(errno)); + + buf[0] = 0; + + str->buf = buf; + str->len = 0; + str->size = initial_size; + + return str; +} + +static void str_free(string_t **str) +{ + free((*str)->buf); + free(*str); + *str = NULL; +} + +static const char *str_c(string_t *str) +{ + return str->buf; +} + +static char *str_ccopy(string_t *str) +{ + char *copy; + + copy = malloc(str->len+1); + if (!copy) + i_panic("malloc() failed: %s", strerror(errno)); + + memcpy(copy, str->buf, str->len); + copy[str->len] = 0; + return copy; +} + +static size_t str_len(const string_t *str) +{ + return str->len; +} + +static void str_append_data(string_t *str, const void *data, size_t len) +{ + char *new_buf; + size_t need_size; + + need_size = str->len + len + 1; + + if (len >= SIZE_MAX / 2 || need_size >= SIZE_MAX / 2) + i_panic("%s() failed: %s", __FUNCTION__, "len is too big"); + + if (need_size > str->size) { + str->size = 1; + while (str->size < need_size) + str->size <<= 1; + + new_buf = realloc(str->buf, str->size); + if (!new_buf) + i_panic("realloc() failed: %s", strerror(errno)); + + str->buf = new_buf; + } + + memcpy(str->buf + str->len, data, len); + str->len += len; + str->buf[str->len] = 0; +} + +static void str_append(string_t *str, const char *cstr) +{ + str_append_data(str, cstr, strlen(cstr)); +} + +static void str_append_c(string_t *str, unsigned char chr) +{ + str_append_data(str, &chr, 1); +} + +static void str_truncate(string_t *str, size_t len) +{ + if (str->size - 1 <= len || str->len <= len) + return; + + str->len = len; + str->buf[len] = 0; +} + +/* + atext = ALPHA / DIGIT / ; Any character except controls, + "!" / "#" / ; SP, and specials. + "$" / "%" / ; Used for atoms + "&" / "'" / + "*" / "+" / + "-" / "/" / + "=" / "?" / + "^" / "_" / + "`" / "{" / + "|" / "}" / + "~" + + MIME: + + token := 1* + tspecials := "(" / ")" / "<" / ">" / "@" / + "," / ";" / ":" / "\" / <"> + "/" / "[" / "]" / "?" / "=" + + So token is same as dot-atom, except stops also at '/', '?' and '='. +*/ + +/* atext chars are marked with 1, alpha and digits with 2, + atext-but-mime-tspecials with 4 */ +unsigned char rfc822_atext_chars[256] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0-15 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 16-31 */ + 0, 1, 0, 1, 1, 1, 1, 1, 0, 0, 1, 1, 0, 1, 0, 4, /* 32-47 */ + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, 0, 0, 4, 0, 4, /* 48-63 */ + 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, /* 64-79 */ + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, 0, 0, 1, 1, /* 80-95 */ + 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, /* 96-111 */ + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 0, /* 112-127 */ + + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 +}; + +#define IS_ATEXT(c) \ + (rfc822_atext_chars[(int)(unsigned char)(c)] != 0) +#define IS_ATEXT_NON_TSPECIAL(c) \ + ((rfc822_atext_chars[(int)(unsigned char)(c)] & 3) != 0) + +/* + qtext = %d33 / ; Printable US-ASCII + %d35-91 / ; characters not including + %d93-126 / ; "\" or the quote character + obs-qtext + + obs-qtext = obs-NO-WS-CTL + + obs-NO-WS-CTL = %d1-8 / ; US-ASCII control + %d11 / ; characters that do not + %d12 / ; include the carriage + %d14-31 / ; return, line feed, and + %d127 ; white space characters + + So qtext is everything expects '\0', '\t', '\n', '\r', ' ', '"', '\\'. +*/ + +/* non-qtext characters */ +#define CHAR_NEEDS_ESCAPE(c) ((c) == '"' || (c) == '\\' || (c) == '\0' || (c) == '\t' || (c) == '\n' || (c) == '\r') + +/* quote with "" and escape all needed characters */ +static void str_append_maybe_escape(string_t *str, const char *data, size_t len, bool quote_dot) +{ + const char *p; + const char *end; + + if (len == 0) { + str_append(str, "\"\""); + return; + } + + /* leading or trailing dot needs to be always quoted */ + if (data[0] == '.' || data[len-1] == '.') + quote_dot = true; + + end = data + len; + + /* see if we need to quote it */ + for (p = data; p != end; p++) { + if (!IS_ATEXT(*p) && (quote_dot || *p != '.')) + break; + } + + if (p == end) { + str_append_data(str, data, len); + return; + } + + /* see if we need to escape it */ + for (p = data; p != end; p++) { + if (CHAR_NEEDS_ESCAPE(*p)) + break; + } + + if (p == end) { + /* only quote */ + str_append_c(str, '"'); + str_append_data(str, data, len); + str_append_c(str, '"'); + return; + } + + /* quote and escape */ + str_append_c(str, '"'); + str_append_data(str, data, (size_t) (p - data)); + + for (; p != end; p++) { + if (CHAR_NEEDS_ESCAPE(*p)) + str_append_c(str, '\\'); + str_append_c(str, *p); + } + + str_append_c(str, '"'); +} + +/* Parse given data using RFC 822 token parser. */ +static void rfc822_parser_init(struct rfc822_parser_context *ctx, + const unsigned char *data, size_t size, + string_t *last_comment) +{ + memset(ctx, 0, sizeof(*ctx)); + ctx->data = data; + ctx->end = data + size; + ctx->last_comment = last_comment; +} + +static void rfc822_parser_deinit(struct rfc822_parser_context *ctx) +{ + /* make sure the parsing didn't trigger a bug that caused reading + past the end pointer. */ + i_assert(ctx->data <= ctx->end); + /* make sure the parser is no longer accessed */ + ctx->data = ctx->end = NULL; +} + +/* The functions below return 1 = more data available, 0 = no more data + available (but a value might have been returned now), -1 = invalid input. + + LWSP is automatically skipped after value, but not before it. So typically + you begin with skipping LWSP and then start using the parse functions. */ + +/* Parse comment. Assumes parser's data points to '(' */ +static int rfc822_skip_comment(struct rfc822_parser_context *ctx) +{ + const unsigned char *start; + size_t len; + int level = 1; + + i_assert(*ctx->data == '('); + + if (ctx->last_comment != NULL) + str_truncate(ctx->last_comment, 0); + + start = ++ctx->data; + for (; ctx->data < ctx->end; ctx->data++) { + switch (*ctx->data) { + case '\0': + if (ctx->nul_replacement_str != NULL) { + if (ctx->last_comment != NULL) { + str_append_data(ctx->last_comment, start, + ctx->data - start); + str_append(ctx->last_comment, + ctx->nul_replacement_str); + start = ctx->data + 1; + } + } else { + return -1; + } + break; + case '(': + level++; + break; + case ')': + if (--level == 0) { + if (ctx->last_comment != NULL) { + str_append_data(ctx->last_comment, start, + ctx->data - start); + } + ctx->data++; + return ctx->data < ctx->end ? 1 : 0; + } + break; + case '\n': + /* folding whitespace, remove the (CR)LF */ + if (ctx->last_comment == NULL) + break; + len = ctx->data - start; + if (len > 0 && start[len-1] == '\r') + len--; + str_append_data(ctx->last_comment, start, len); + start = ctx->data + 1; + break; + case '\\': + ctx->data++; + if (ctx->data >= ctx->end) + return -1; +#if 0 + if (*ctx->data == '\r' || *ctx->data == '\n' || + *ctx->data == '\0') { + /* quoted-pair doesn't allow CR/LF/NUL. + They are part of the obs-qp though, so don't + return them as error. */ + ctx->data--; + break; + } +#endif + if (ctx->last_comment != NULL) { + str_append_data(ctx->last_comment, start, + ctx->data - start - 1); + } + start = ctx->data; + break; + } + } + + /* missing ')' */ + return -1; +} + +/* Skip LWSP if there is any */ +static int rfc822_skip_lwsp(struct rfc822_parser_context *ctx) +{ + for (; ctx->data < ctx->end;) { + if (*ctx->data == ' ' || *ctx->data == '\t' || + *ctx->data == '\r' || *ctx->data == '\n') { + ctx->data++; + continue; + } + + if (*ctx->data != '(') + break; + + if (rfc822_skip_comment(ctx) < 0) + return -1; + } + return ctx->data < ctx->end ? 1 : 0; +} + +/* Stop at next non-atext char */ +int rfc822_parse_atom(struct rfc822_parser_context *ctx, string_t *str) +{ + const unsigned char *start; + + /* + atom = [CFWS] 1*atext [CFWS] + atext = + ; Any character except controls, SP, and specials. + */ + if (ctx->data >= ctx->end || !IS_ATEXT(*ctx->data)) + return -1; + + for (start = ctx->data++; ctx->data < ctx->end; ctx->data++) { + if (IS_ATEXT(*ctx->data)) + continue; + + str_append_data(str, start, ctx->data - start); + return rfc822_skip_lwsp(ctx); + } + + str_append_data(str, start, ctx->data - start); + return 0; +} + +/* Like parse_atom() but don't stop at '.' */ +static int rfc822_parse_dot_atom(struct rfc822_parser_context *ctx, string_t *str, bool stop_trailing_dot) +{ + const unsigned char *start; + const unsigned char *last_dot_ptr; + bool last_is_dot; + bool dot_problem; + int ret; + + /* + dot-atom = [CFWS] dot-atom-text [CFWS] + dot-atom-text = 1*atext *("." 1*atext) + + atext = + ; Any character except controls, SP, and specials. + + For RFC-822 compatibility allow LWSP around '.' + */ + if (ctx->data >= ctx->end || !IS_ATEXT(*ctx->data)) + return -1; + + last_dot_ptr = ctx->data; + last_is_dot = false; + dot_problem = false; + + for (start = ctx->data++; ctx->data < ctx->end; ) { + if (IS_ATEXT(*ctx->data)) { + ctx->data++; + continue; + } + +#if 0 + if (start == ctx->data) + dot_problem = true; +#endif + str_append_data(str, start, ctx->data - start); + + if (ctx->data - start > 0) + last_is_dot = false; + + if ((ret = rfc822_skip_lwsp(ctx)) <= 0) + return (dot_problem && ret >= 0) ? -2 : ret; + + if (*ctx->data != '.') { + if (last_is_dot && stop_trailing_dot) { + ctx->data = last_dot_ptr; + return dot_problem ? -2 : 1; + } + return (last_is_dot || dot_problem) ? -2 : 1; + } + + if (last_is_dot) + dot_problem = true; + + last_dot_ptr = ctx->data; + ctx->data++; + str_append_c(str, '.'); + last_is_dot = true; + + if (rfc822_skip_lwsp(ctx) <= 0) + return (dot_problem && ret >= 0) ? -2 : ret; + start = ctx->data; + } + +#if 0 + i_assert(start != ctx->data); +#endif + str_append_data(str, start, ctx->data - start); + return dot_problem ? -2 : 0; +} + +/* "quoted string" */ +static int rfc822_parse_quoted_string(struct rfc822_parser_context *ctx, string_t *str) +{ + const unsigned char *start; + bool char_problem; + int ret; + size_t len; + + i_assert(ctx->data < ctx->end); + i_assert(*ctx->data == '"'); + ctx->data++; + char_problem = false; + + for (start = ctx->data; ctx->data < ctx->end; ctx->data++) { + switch (*ctx->data) { + case '\0': + if (ctx->nul_replacement_str != NULL) { + str_append_data(str, start, ctx->data - start); + str_append(str, ctx->nul_replacement_str); + start = ctx->data + 1; + } else { + char_problem = true; + } + break; + case '"': + str_append_data(str, start, ctx->data - start); + ctx->data++; + ret = rfc822_skip_lwsp(ctx); + return (char_problem && ret >= 0) ? -2 : ret; + case '\r': + if (ctx->data+1 < ctx->end && *(ctx->data+1) != '\n') + char_problem = true; + break; + case '\n': +#if 0 + /* folding whitespace, remove the (CR)LF */ + len = ctx->data - start; + if (len > 0 && start[len-1] == '\r') + len--; + str_append_data(str, start, len); + start = ctx->data + 1; +#endif + len = ctx->data - start; + if (len <= 0 || start[len-1] != '\r') + char_problem = true; + break; + case '\\': + ctx->data++; + if (ctx->data >= ctx->end) + return -1; +#if 0 + if (*ctx->data == '\r' || *ctx->data == '\n' || + *ctx->data == '\0') { + /* quoted-pair doesn't allow CR/LF/NUL. + They are part of the obs-qp though, so don't + return them as error. */ + ctx->data--; + break; + } +#endif + str_append_data(str, start, ctx->data - start - 1); + str_append_c(str, *ctx->data); + start = ctx->data+1; + break; + } + } + + /* missing '"' */ + return -1; +} + +static int +rfc822_parse_atom_or_dot(struct rfc822_parser_context *ctx, string_t *str) +{ + const unsigned char *start; + + /* + atom = [CFWS] 1*atext [CFWS] + atext = + ; Any character except controls, SP, and specials. + + The difference between this function and rfc822_parse_dot_atom() + is that this doesn't just silently skip over all the whitespace. + */ + for (start = ctx->data; ctx->data < ctx->end; ctx->data++) { + if (IS_ATEXT(*ctx->data) || *ctx->data == '.') + continue; + + str_append_data(str, start, ctx->data - start); + return rfc822_skip_lwsp(ctx); + } + + str_append_data(str, start, ctx->data - start); + return 0; +} + +/* atom or quoted-string */ +static int rfc822_parse_phrase(struct rfc822_parser_context *ctx, string_t *str) +{ + int ret; + bool char_problem; + + char_problem = false; + + /* + phrase = 1*word / obs-phrase + word = atom / quoted-string + obs-phrase = word *(word / "." / CFWS) + */ + + if (ctx->data >= ctx->end) + return 0; + if (*ctx->data == '.') + return -1; + + for (;;) { + if (*ctx->data == '"') + ret = rfc822_parse_quoted_string(ctx, str); + else + ret = rfc822_parse_atom_or_dot(ctx, str); + + if (ret <= 0 && ret != -2) + return (char_problem && ret == 0) ? -2 : ret; + + if (ret == -2) { + char_problem = true; + if (ctx->data >= ctx->end) + return -2; + } + + if (!IS_ATEXT(*ctx->data) && *ctx->data != '"' + && *ctx->data != '.') + break; + str_append_c(str, ' '); + } + ret = rfc822_skip_lwsp(ctx); + return (char_problem && ret >= 0) ? -2 : ret; +} + +static int +rfc822_parse_domain_literal(struct rfc822_parser_context *ctx, string_t *str) +{ + const unsigned char *start; + size_t len; + + /* + domain-literal = [CFWS] "[" *([FWS] dcontent) [FWS] "]" [CFWS] + dcontent = dtext / quoted-pair + dtext = NO-WS-CTL / ; Non white space controls + %d33-90 / ; The rest of the US-ASCII + %d94-126 ; characters not including "[", + ; "]", or "\" + */ + i_assert(ctx->data < ctx->end); + i_assert(*ctx->data == '['); + + for (start = ctx->data++; ctx->data < ctx->end; ctx->data++) { + switch (*ctx->data) { + case '\0': + if (ctx->nul_replacement_str != NULL) { + str_append_data(str, start, ctx->data - start); + str_append(str, ctx->nul_replacement_str); + start = ctx->data + 1; + } else { + return -1; + } + break; + case '[': + /* not allowed */ + return -1; + case ']': + str_append_data(str, start, ctx->data - start + 1); + ctx->data++; + return rfc822_skip_lwsp(ctx); + case '\n': + /* folding whitespace, remove the (CR)LF */ + len = ctx->data - start; + if (len > 0 && start[len-1] == '\r') + len--; + str_append_data(str, start, len); + start = ctx->data + 1; + break; + case '\\': + /* note: the '\' is preserved in the output */ + ctx->data++; + if (ctx->data >= ctx->end) + return -1; +#if 0 + if (*ctx->data == '\r' || *ctx->data == '\n' || + *ctx->data == '\0') { + /* quoted-pair doesn't allow CR/LF/NUL. + They are part of the obs-qp though, so don't + return them as error. */ + str_append_data(str, start, ctx->data - start); + start = ctx->data; + ctx->data--; + break; + } +#endif + break; + } + } + + /* missing ']' */ + return -1; +} + +/* dot-atom / domain-literal */ +static int rfc822_parse_domain(struct rfc822_parser_context *ctx, string_t *str) +{ + /* + domain = dot-atom / domain-literal / obs-domain + domain-literal = [CFWS] "[" *([FWS] dcontent) [FWS] "]" [CFWS] + obs-domain = atom *("." atom) + */ + i_assert(ctx->data < ctx->end); + i_assert(*ctx->data == '@'); + ctx->data++; + + if (rfc822_skip_lwsp(ctx) <= 0) + return -1; + + if (*ctx->data == '[') + return rfc822_parse_domain_literal(ctx, str); + else + return rfc822_parse_dot_atom(ctx, str, false); +} + +static void add_address(struct message_address_parser_context *ctx) +{ + struct message_address *addr; + + addr = malloc(sizeof(struct message_address)); + if (!addr) + i_panic("malloc() failed: %s", strerror(errno)); + + memcpy(addr, &ctx->addr, sizeof(ctx->addr)); + memset(&ctx->addr, 0, sizeof(ctx->addr)); + + if (ctx->first_addr == NULL) + ctx->first_addr = addr; + else + ctx->last_addr->next = addr; + ctx->last_addr = addr; +} + +static int +parse_nonstrict_dot_atom(struct rfc822_parser_context *ctx, string_t *str) +{ + int ret = -1; + + do { + while (*ctx->data == '.') { + str_append_c(str, '.'); + ctx->data++; + if (ctx->data == ctx->end) { + /* @domain is missing, but local-part + parsing was successful */ + return 0; + } + ret = 1; + } + if (*ctx->data == '@') + break; + ret = rfc822_parse_atom(ctx, str); + } while (ret > 0 && *ctx->data == '.'); + return ret; +} + +static int parse_local_part(struct message_address_parser_context *ctx) +{ + int ret; + bool char_problem; + + /* + local-part = dot-atom / quoted-string / obs-local-part + obs-local-part = word *("." word) + */ + i_assert(ctx->parser.data < ctx->parser.end); + + str_truncate(ctx->str, 0); + char_problem = false; + + while (ctx->parser.data < ctx->parser.end) { + if (*ctx->parser.data == '"') + ret = rfc822_parse_quoted_string(&ctx->parser, ctx->str); + else if (!ctx->non_strict_dots || ctx->non_strict_dots_as_invalid) + ret = rfc822_parse_dot_atom(&ctx->parser, ctx->str, true); + else + ret = parse_nonstrict_dot_atom(&ctx->parser, ctx->str); + if (ret < 0 && (ret != -2 || (!ctx->non_strict_dots && !ctx->non_strict_dots_as_invalid))) + return -1; + if (ret == -2) + char_problem = true; + if (ctx->parser.data >= ctx->parser.end) + break; + if ((ret = rfc822_skip_lwsp(&ctx->parser)) <= 0) + break; + if (*ctx->parser.data != '.') + break; + ctx->parser.data++; + if (ctx->parser.data >= ctx->parser.end) { + char_problem = true; + break; + } + if ((ret = rfc822_skip_lwsp(&ctx->parser)) <= 0) + break; + if (ctx->parser.data >= ctx->parser.end || *ctx->parser.data == '@') { + char_problem = true; + break; + } + } + + if (char_problem || ret < 0) + ctx->addr.invalid_syntax = true; + + ctx->addr.mailbox = str_ccopy(ctx->str); + ctx->addr.mailbox_len = str_len(ctx->str); + return ret; +} + +static int parse_domain(struct message_address_parser_context *ctx) +{ + int ret; + + str_truncate(ctx->str, 0); + if ((ret = rfc822_parse_domain(&ctx->parser, ctx->str)) < 0 && (ret != -2 || (!ctx->non_strict_dots && !ctx->non_strict_dots_as_invalid))) + return -1; + + ctx->addr.domain = str_ccopy(ctx->str); + ctx->addr.domain_len = str_len(ctx->str); + return ret; +} + +static int parse_domain_list(struct message_address_parser_context *ctx) +{ + int ret; + bool dot_problem; + + /* obs-domain-list = "@" domain *(*(CFWS / "," ) [CFWS] "@" domain) */ + str_truncate(ctx->str, 0); + dot_problem = false; + for (;;) { + if (ctx->parser.data >= ctx->parser.end) + return dot_problem ? -2 : 0; + + if (*ctx->parser.data != '@') + break; + + if (str_len(ctx->str) > 0) + str_append_c(ctx->str, ','); + + str_append_c(ctx->str, '@'); + if ((ret = rfc822_parse_domain(&ctx->parser, ctx->str)) <= 0 && (ret != -2 || (!ctx->non_strict_dots && !ctx->non_strict_dots_as_invalid))) + return ret; + + if (ret == -2) + dot_problem = true; + + while (rfc822_skip_lwsp(&ctx->parser) > 0 && + *ctx->parser.data == ',') + ctx->parser.data++; + } + ctx->addr.route = str_ccopy(ctx->str); + ctx->addr.route_len = str_len(ctx->str); + return dot_problem ? -2 : 1; +} + +static int parse_angle_addr(struct message_address_parser_context *ctx, + bool parsing_path) +{ + int ret; + + /* "<" [ "@" route ":" ] local-part "@" domain ">" */ + i_assert(*ctx->parser.data == '<'); + ctx->parser.data++; + + if (rfc822_skip_lwsp(&ctx->parser) <= 0) + return -1; + + if (*ctx->parser.data == '@') { + if ((ret = parse_domain_list(ctx)) > 0 && *ctx->parser.data == ':') { + ctx->parser.data++; + } else if (parsing_path && (ctx->parser.data >= ctx->parser.end || *ctx->parser.data != ':')) { + return -1; + } else { + if (ctx->fill_missing && ret != -2) + ctx->addr.route = strdup("INVALID_ROUTE"); + ctx->addr.invalid_syntax = true; + if (ctx->parser.data >= ctx->parser.end) + return -1; + if (ret == -2) + ctx->parser.data++; + /* try to continue anyway */ + } + if (rfc822_skip_lwsp(&ctx->parser) <= 0) + return -1; + } + + if (*ctx->parser.data == '>') { + /* <> address isn't valid */ + } else { + if ((ret = parse_local_part(ctx)) <= 0 && (ret != -2 || (!ctx->non_strict_dots && !ctx->non_strict_dots_as_invalid))) + return -1; + if (ret == -2) + ctx->addr.invalid_syntax = true; + if (ctx->parser.data >= ctx->parser.end) + return 0; + if (*ctx->parser.data == '@') { + if ((ret = parse_domain(ctx)) <= 0 && (ret != -2 || (!ctx->non_strict_dots && !ctx->non_strict_dots_as_invalid))) + return -1; + if (ret == -2) + ctx->addr.invalid_syntax = true; + if (ctx->parser.data >= ctx->parser.end) + return 0; + } + } + + if (*ctx->parser.data != '>') + return -1; + ctx->parser.data++; + + return rfc822_skip_lwsp(&ctx->parser); +} + +static int parse_name_addr(struct message_address_parser_context *ctx) +{ + int ret; + + /* + name-addr = [display-name] angle-addr + display-name = phrase + */ + str_truncate(ctx->str, 0); + ret = rfc822_parse_phrase(&ctx->parser, ctx->str); + if ((ret <= 0 && (ret != -2 || (!ctx->non_strict_dots && !ctx->non_strict_dots_as_invalid))) || + *ctx->parser.data != '<') + return -1; + + if (ret == -2) + ctx->addr.invalid_syntax = true; + + if (str_len(ctx->str) == 0) { + /* Cope with "
" without display name */ + ctx->addr.name = NULL; + } else { + ctx->addr.name = str_ccopy(ctx->str); + ctx->addr.name_len = str_len(ctx->str); + } + + if (ctx->parser.last_comment != NULL) + str_truncate(ctx->parser.last_comment, 0); + + if (parse_angle_addr(ctx, false) < 0) { + /* broken */ + if (ctx->fill_missing) + ctx->addr.domain = strdup("SYNTAX_ERROR"); + ctx->addr.invalid_syntax = true; + } + + if (ctx->parser.last_comment != NULL) { + if (str_len(ctx->parser.last_comment) > 0) { + ctx->addr.comment = + str_ccopy(ctx->parser.last_comment); + ctx->addr.comment_len = + str_len(ctx->parser.last_comment); + } + } + + return ctx->parser.data < ctx->parser.end ? 1 : 0; +} + +static int parse_addr_spec(struct message_address_parser_context *ctx) +{ + /* addr-spec = local-part "@" domain */ + int ret, ret2 = -3; + + i_assert(ctx->parser.data < ctx->parser.end); + + if (ctx->parser.last_comment != NULL) + str_truncate(ctx->parser.last_comment, 0); + +#if 0 + bool quoted_string = *ctx->parser.data == '"'; +#endif + ret = parse_local_part(ctx); + if (ret <= 0) { + /* end of input or parsing local-part failed */ + ctx->addr.invalid_syntax = true; + } + if (ret != 0 && ctx->parser.data < ctx->parser.end && + *ctx->parser.data == '@') { + ret2 = parse_domain(ctx); + if (ret2 <= 0 && ret != -2) + ret = ret2; + if (ret2 == -2) { + ctx->addr.invalid_syntax = true; + if (ctx->parser.data >= ctx->parser.end) + ret = 0; + } + } + + if (ctx->parser.last_comment != NULL && str_len(ctx->parser.last_comment) > 0) { + ctx->addr.comment = str_ccopy(ctx->parser.last_comment); + ctx->addr.comment_len = str_len(ctx->parser.last_comment); + } else if (ret2 == -3) { +#if 0 + /* So far we've read user without @domain and without + (Display Name). We'll assume that a single "user" (already + read into addr.mailbox) is a mailbox, but if it's followed + by anything else it's a display-name. */ + str_append_c(ctx->str, ' '); + size_t orig_str_len = str_len(ctx->str); + (void)rfc822_parse_phrase(&ctx->parser, ctx->str); + if (str_len(ctx->str) != orig_str_len) { + ctx->addr.mailbox = NULL; + ctx->addr.name = str_ccopy(ctx->str); + ctx->addr.name_len = str_len(ctx->str); + } else { + if (!quoted_string) + ctx->addr.domain = strdup(""); + } + ctx->addr.invalid_syntax = true; + ret = -1; +#endif + } + return ret; +} + +static void add_fixed_address(struct message_address_parser_context *ctx) +{ + if (ctx->addr.mailbox == NULL) { + ctx->addr.mailbox = strdup(!ctx->fill_missing ? "" : "MISSING_MAILBOX"); + ctx->addr.invalid_syntax = true; + } + if (ctx->addr.domain == NULL || ctx->addr.domain_len == 0) { + free(ctx->addr.domain); + ctx->addr.domain = strdup(!ctx->fill_missing ? "" : "MISSING_DOMAIN"); + ctx->addr.invalid_syntax = true; + } + add_address(ctx); +} + +static int parse_mailbox(struct message_address_parser_context *ctx) +{ + const unsigned char *start; + size_t len; + int ret; + + /* mailbox = name-addr / addr-spec */ + start = ctx->parser.data; + if ((ret = parse_name_addr(ctx)) < 0) { + /* nope, should be addr-spec */ + if (ctx->addr.name != NULL) { + free(ctx->addr.name); + ctx->addr.name = NULL; + } + if (ctx->addr.route != NULL) { + free(ctx->addr.route); + ctx->addr.route = NULL; + } + if (ctx->addr.mailbox != NULL) { + free(ctx->addr.mailbox); + ctx->addr.mailbox = NULL; + } + if (ctx->addr.domain != NULL) { + free(ctx->addr.domain); + ctx->addr.domain = NULL; + } + if (ctx->addr.comment != NULL) { + free(ctx->addr.comment); + ctx->addr.comment = NULL; + } + if (ctx->addr.original != NULL) { + free(ctx->addr.original); + ctx->addr.original = NULL; + } + ctx->parser.data = start; + ret = parse_addr_spec(ctx); + if (ctx->addr.invalid_syntax && ctx->addr.name == NULL && + ctx->addr.mailbox != NULL && ctx->addr.domain == NULL) { + ctx->addr.name = ctx->addr.mailbox; + ctx->addr.name_len = ctx->addr.mailbox_len; + ctx->addr.mailbox = NULL; + ctx->addr.mailbox_len = 0; + } + } + + if (ret < 0) + ctx->addr.invalid_syntax = true; + + len = ctx->parser.data - start; + ctx->addr.original = malloc(len + 1); + if (!ctx->addr.original) + i_panic("malloc() failed: %s", strerror(errno)); + + memcpy(ctx->addr.original, start, len); + ctx->addr.original[len] = 0; + ctx->addr.original_len = len; + + add_fixed_address(ctx); + + free(ctx->addr.original); + ctx->addr.original = NULL; + return ret; +} + +static int parse_group(struct message_address_parser_context *ctx) +{ + int ret; + + /* + group = display-name ":" [mailbox-list / CFWS] ";" [CFWS] + display-name = phrase + */ + str_truncate(ctx->str, 0); + ret = rfc822_parse_phrase(&ctx->parser, ctx->str); + if ((ret <= 0 && (ret != -2 || (!ctx->non_strict_dots && !ctx->non_strict_dots_as_invalid))) || + *ctx->parser.data != ':') + return -1; + + if (ret == -2) + ctx->addr.invalid_syntax = true; + + /* from now on don't return -1 even if there are problems, so that + the caller knows this is a group */ + ctx->parser.data++; + if ((ret = rfc822_skip_lwsp(&ctx->parser)) <= 0) + ctx->addr.invalid_syntax = true; + + ctx->addr.mailbox = str_ccopy(ctx->str); + ctx->addr.mailbox_len = str_len(ctx->str); + add_address(ctx); + + if (ret > 0 && *ctx->parser.data != ';') { + for (;;) { + /* mailbox-list = + (mailbox *("," mailbox)) / obs-mbox-list */ + if (parse_mailbox(ctx) <= 0) { + /* broken mailbox - try to continue anyway. */ + } + if (ctx->parser.data >= ctx->parser.end || + *ctx->parser.data != ',') + break; + ctx->parser.data++; + if (rfc822_skip_lwsp(&ctx->parser) <= 0) { + ret = -1; + break; + } + } + } + if (ret >= 0) { + if (ctx->parser.data >= ctx->parser.end || + *ctx->parser.data != ';') + ret = -1; + else { + ctx->parser.data++; + ret = rfc822_skip_lwsp(&ctx->parser); + } + } + if (ret < 0) + ctx->addr.invalid_syntax = true; + + add_address(ctx); + return ret == 0 ? 0 : 1; +} + +static int parse_address(struct message_address_parser_context *ctx) +{ + const unsigned char *start; + int ret; + + /* address = mailbox / group */ + start = ctx->parser.data; + if ((ret = parse_group(ctx)) < 0) { + /* not a group, try mailbox */ + ctx->parser.data = start; + ret = parse_mailbox(ctx); + } + return ret; +} + +static int parse_address_list(struct message_address_parser_context *ctx, + unsigned int max_addresses) +{ + const unsigned char *start; + size_t len; + int ret = 0; + + /* address-list = (address *("," address)) / obs-addr-list */ + while (max_addresses > 0) { + max_addresses--; + if ((ret = parse_address(ctx)) == 0) + break; + if (ctx->parser.data >= ctx->parser.end || + *ctx->parser.data != ',') { + ctx->last_addr->invalid_syntax = true; + ret = -1; + break; + } + ctx->parser.data++; + start = ctx->parser.data; + if ((ret = rfc822_skip_lwsp(&ctx->parser)) <= 0) { + if (ret < 0) { + /* ends with some garbage */ + len = ctx->parser.data - start; + ctx->addr.original = malloc(len + 1); + if (!ctx->addr.original) + i_panic("malloc() failed: %s", strerror(errno)); + + memcpy(ctx->addr.original, start, len); + ctx->addr.original[len] = 0; + ctx->addr.original_len = len; + + add_fixed_address(ctx); + + free(ctx->addr.original); + ctx->addr.original = NULL; + } + break; + } + } + return ret; +} + +static char *mem_copy(const char *mem, size_t len) +{ + char *copy; + + copy = malloc(len+1); + if (!copy) + i_panic("malloc() failed: %s", strerror(errno)); + + memcpy(copy, mem, len); + copy[len] = 0; + return copy; +} + +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) +{ + struct message_address *message; + + message = malloc(sizeof(struct message_address)); + if (!message) + i_panic("malloc() failed: %s", strerror(errno)); + + message->name = name ? mem_copy(name, name_len) : NULL; + message->name_len = name_len; + message->route = route ? mem_copy(route, route_len) : NULL; + message->route_len = route_len; + message->mailbox = mailbox ? mem_copy(mailbox, mailbox_len) : NULL; + message->mailbox_len = mailbox_len; + message->domain = domain ? mem_copy(domain, domain_len) : NULL; + message->domain_len = domain_len; + message->comment = comment ? mem_copy(comment, comment_len) : NULL; + message->comment_len = comment_len; + message->original = NULL; + message->original_len = 0; + message->next = NULL; + + if (!*first) + *first = message; + else + (*last)->next = message; + + *last = message; +} + +void message_address_free(struct message_address **addr) +{ + struct message_address *current; + struct message_address *next; + + current = *addr; + + while (current) { + next = current->next; + free(current->name); + free(current->route); + free(current->mailbox); + free(current->domain); + free(current->comment); + free(current->original); + free(current); + current = next; + } + + *addr = NULL; +} + +struct message_address * +message_address_parse(const char *input, size_t input_len, + unsigned int max_addresses, + enum message_address_parse_flags flags) +{ + string_t *str; + struct message_address_parser_context ctx; + + memset(&ctx, 0, sizeof(ctx)); + + str = str_new(128); + + rfc822_parser_init(&ctx.parser, (const unsigned char *)input, input_len, str); + + if (rfc822_skip_lwsp(&ctx.parser) <= 0) { + /* no addresses */ + str_free(&str); + return NULL; + } + + ctx.str = str_new(128); + ctx.fill_missing = (flags & MESSAGE_ADDRESS_PARSE_FLAG_FILL_MISSING) != 0; + ctx.non_strict_dots = (flags & MESSAGE_ADDRESS_PARSE_FLAG_STRICT_DOTS) == 0; + ctx.non_strict_dots_as_invalid = (flags & MESSAGE_ADDRESS_PARSE_FLAG_NON_STRICT_DOTS_AS_INVALID) != 0; + + (void)parse_address_list(&ctx, max_addresses); + + str_free(&ctx.str); + str_free(&str); + + rfc822_parser_deinit(&ctx.parser); + + return ctx.first_addr; +} + +static bool has_mime_word(const char *str, size_t len) +{ + const char *ptr; + const char *end; + + ptr = str; + end = str+len; + + while ((ptr = memchr(ptr, '=', end - ptr)) != NULL) { + ptr++; + if (*ptr == '?') + return true; + } + + return false; +} + +void message_address_write(char **output, size_t *output_len, const struct message_address *addr) +{ + string_t *str; + const char *tmp; + bool first = true, in_group = false; + + str = str_new(128); + +#if 0 + if (addr == NULL) + return; + + /* <> path */ + if (addr->mailbox == NULL && addr->domain == NULL) { + i_assert(addr->next == NULL); + str_append(str, "<>"); + return; + } +#endif + + /* a) mailbox@domain + b) name <@route:mailbox@domain> + c) group: .. ; */ + + while (addr != NULL) { + if (first) + first = false; + else + str_append(str, ", "); + + if (addr->domain == NULL) { + if (!in_group) { + /* beginning of group. mailbox is the group + name, others are NULL. */ + if (addr->mailbox != NULL && addr->mailbox_len != 0) { + /* check for MIME encoded-word */ + if (has_mime_word(addr->mailbox, addr->mailbox_len)) + /* MIME encoded-word MUST NOT appear within a 'quoted-string' + so escaping and quoting of phrase is not possible, instead + use obsolete RFC822 phrase syntax which allow spaces */ + str_append_data(str, addr->mailbox, addr->mailbox_len); + else + str_append_maybe_escape(str, addr->mailbox, addr->mailbox_len, true); + } else { + /* empty group name needs to be quoted */ + str_append(str, "\"\""); + } + str_append(str, ": "); + first = true; + } else { + /* end of group. all fields should be NULL. */ + i_assert(addr->mailbox == NULL); + + /* cut out the ", " */ + tmp = str_c(str)+str_len(str)-2; + i_assert((tmp[0] == ',' || tmp[0] == ':') && tmp[1] == ' '); + if (tmp[0] == ',' && tmp[1] == ' ') + str_truncate(str, str_len(str)-2); + else if (tmp[0] == ':' && tmp[1] == ' ') + str_truncate(str, str_len(str)-1); + str_append_c(str, ';'); + } + + in_group = !in_group; + } else if ((addr->name == NULL || addr->name_len == 0) && + addr->route == NULL) { + /* no name and no route. use only mailbox@domain */ + i_assert(addr->mailbox != NULL); + + str_append_maybe_escape(str, addr->mailbox, addr->mailbox_len, false); + str_append_c(str, '@'); + str_append_data(str, addr->domain, addr->domain_len); + + if (addr->comment != NULL) { + str_append(str, " ("); + str_append_data(str, addr->comment, addr->comment_len); + str_append_c(str, ')'); + } + } else { + /* name and/or route. use full Name */ + i_assert(addr->mailbox != NULL); + + if (addr->name != NULL && addr->name_len != 0) { + /* check for MIME encoded-word */ + if (has_mime_word(addr->name, addr->name_len)) + /* MIME encoded-word MUST NOT appear within a 'quoted-string' + so escaping and quoting of phrase is not possible, instead + use obsolete RFC822 phrase syntax which allow spaces */ + str_append_data(str, addr->name, addr->name_len); + else + str_append_maybe_escape(str, addr->name, addr->name_len, true); + } + if (addr->route != NULL || + addr->mailbox_len != 0 || + addr->domain_len != 0) { + if (addr->name != NULL && addr->name_len != 0) + str_append_c(str, ' '); + str_append_c(str, '<'); + if (addr->route != NULL) { + str_append_data(str, addr->route, addr->route_len); + str_append_c(str, ':'); + } + str_append_maybe_escape(str, addr->mailbox, addr->mailbox_len, false); + if (addr->domain_len != 0) { + str_append_c(str, '@'); + str_append_data(str, addr->domain, addr->domain_len); + } + str_append_c(str, '>'); + } + if (addr->comment != NULL) { + str_append(str, " ("); + str_append_data(str, addr->comment, addr->comment_len); + str_append_c(str, ')'); + } + } + + addr = addr->next; + } + + *output = str_ccopy(str); + *output_len = str_len(str); + str_free(&str); +} + +void compose_address(char **output, size_t *output_len, const char *mailbox, size_t mailbox_len, const char *domain, size_t domain_len) +{ + string_t *str; + + str = str_new(128); + + str_append_maybe_escape(str, mailbox, mailbox_len, false); + str_append_c(str, '@'); + str_append_data(str, domain, domain_len); + + *output = str_ccopy(str); + *output_len = str_len(str); + str_free(&str); +} + +void split_address(const char *input, size_t input_len, char **mailbox, size_t *mailbox_len, char **domain, size_t *domain_len) +{ + struct message_address_parser_context ctx; + int ret; + + if (!input || !input[0]) { + *mailbox = NULL; + *mailbox_len = 0; + *domain = NULL; + *domain_len = 0; + return; + } + + memset(&ctx, 0, sizeof(ctx)); + + rfc822_parser_init(&ctx.parser, (const unsigned char *)input, input_len, NULL); + + ctx.str = str_new(128); + ctx.fill_missing = false; + ctx.non_strict_dots = false; + ctx.non_strict_dots_as_invalid = false; + + ret = rfc822_skip_lwsp(&ctx.parser); + + if (ret > 0) + ret = parse_addr_spec(&ctx); + else + ret = -1; + + if (ret >= 0) + ret = rfc822_skip_lwsp(&ctx.parser); + + if (ret < 0 || ctx.parser.data != ctx.parser.end || ctx.addr.invalid_syntax) { + free(ctx.addr.mailbox); + free(ctx.addr.domain); + *mailbox = NULL; + *mailbox_len = 0; + *domain = NULL; + *domain_len = 0; + } else { + *mailbox = ctx.addr.mailbox; + *mailbox_len = ctx.addr.mailbox_len; + *domain = ctx.addr.domain; + *domain_len = ctx.addr.domain_len; + } + + free(ctx.addr.comment); + free(ctx.addr.route); + free(ctx.addr.name); + free(ctx.addr.original); + + rfc822_parser_deinit(&ctx.parser); + + str_free(&ctx.str); +} + +void string_free(char *string) +{ + free(string); +} diff --git a/dovecot-parser.h b/dovecot-parser.h new file mode 100644 index 0000000..e5a2f9c --- /dev/null +++ b/dovecot-parser.h @@ -0,0 +1,64 @@ +#ifndef DOVECOT_PARSER_H +#define DOVECOT_PARSER_H + +#include + +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 diff --git a/lib/Email/Address/XS.pm b/lib/Email/Address/XS.pm new file mode 100644 index 0000000..dfd97f9 --- /dev/null +++ b/lib/Email/Address/XS.pm @@ -0,0 +1,680 @@ +# Copyright (c) 2015-2018 by Pali + +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 + + my $users_address = Email::Address::XS->parse('user '); + 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" (Records Department), Julia '); + # ($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" (Records Department), Julia , user + + 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" (Records Department), Julia ;, user + + 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 +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 and +L. + +Parser and formatter functionality is implemented in XS and uses +shared code from Dovecot IMAP server. + +It is a drop-in replacement for L +which has several security issues. E.g. issue L, +which allows remote attackers to cause denial of service, is still +present in L 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 to C and replacing every +C occurrence with C is sufficient. + +So unlike L, 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. + +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. + +=head2 EXPORT + +None by default. Exportable functions are: +L|/parse_email_addresses>, +L|/parse_email_groups>, +L|/format_email_addresses>, +L|/format_email_groups>, +L|/compose_address>, +L|/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" , Julia + +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" , Julia ;, user@oceania + + my $undisclosed_string = format_email_groups('undisclosed-recipients' => []); + print $undisclosed_string; + # undisclosed-recipients:; + +Like L|/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" , Julia , 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" , Julia ;, 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|/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|/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 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 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" (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|/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|/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|/address> method. Method L|/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|/user> or L|/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|/user> and L|/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|/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|/compose_address> is used +for composing full address and function L|/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|/phrase> or L|/comment> or +L|/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. It +returns string representation of object. By default object is +stringified to L|/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" (Minitrue)'); + my $original = $address->original(); + # (Winston) "Smith" (Minitrue) + my $format = $address->format(); + # Smith (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|/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" . + +Stringification is done by method L|/as_string>. + +=cut + +use overload '""' => \&as_string; + +=back + +=head2 Deprecated Functions and Variables + +For compatibility with L +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, C and +C 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, +L, +L, +L, +L, +L, +L + +=head1 AUTHOR + +Pali Epali@cpan.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2015-2018 by Pali Epali@cpan.orgE + +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; diff --git a/t/Email-Address-XS.t b/t/Email-Address-XS.t new file mode 100755 index 0000000..9dd4e58 --- /dev/null +++ b/t/Email-Address-XS.t @@ -0,0 +1,1545 @@ +#!/usr/bin/perl +# Copyright (c) 2015-2018 by Pali + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl Email-Address-XS.t' + +######################### + +use strict; +use warnings; + +# perl version which needs "use utf8;" for comparing utf8 and latin1 strings +BEGIN { + require utf8 if $] < 5.006001; + utf8->import() if $] < 5.006001; +}; + +use Carp; +$Carp::Internal{'Test::Builder'} = 1; +$Carp::Internal{'Test::More'} = 1; + +use Test::More tests => 516; +use Test::Builder; + +local $SIG{__WARN__} = sub { + local $Test::Builder::Level = $Test::Builder::Level + 1; + fail('following test does not throw warning'); + warn $_[0]; +}; + +sub with_warning(&) { + my ($code) = @_; + local $Test::Builder::Level = $Test::Builder::Level + 1; + my $warn; + local $SIG{__WARN__} = sub { $warn = 1; }; + my @ret = wantarray ? $code->() : scalar $code->(); + ok($warn, 'following test throws warning'); + return wantarray ? @ret : $ret[0]; +} + +sub obj_to_hashstr { + my ($self) = @_; + my $out = ""; + foreach ( qw(user host phrase comment) ) { + next unless exists $self->{$_}; + $out .= $_ . ':' . (defined $self->{$_} ? $self->{$_} : '(undef)') . ';'; + } + return $out; +} + +######################### + +BEGIN { + use_ok('Email::Address::XS', qw(parse_email_addresses parse_email_groups format_email_addresses format_email_groups)); +}; + +######################### + +require overload; +my $obj_to_origstr = overload::Method 'Email::Address::XS', '""'; +my $obj_to_hashstr = \&obj_to_hashstr; + +# set stringify and eq operators for comparision used in is_deeply +{ + local $SIG{__WARN__} = sub { }; + overload::OVERLOAD 'Email::Address::XS', '""' => $obj_to_hashstr; + overload::OVERLOAD 'Email::Address::XS', 'eq' => sub { obj_to_hashstr($_[0]) eq obj_to_hashstr($_[1]) }; +} + +######################### + +{ + + { + my $subtest = 'test method new() without arguments'; + my $address = Email::Address::XS->new(); + ok(!$address->is_valid(), $subtest); + is($address->phrase(), undef, $subtest); + is($address->user(), undef, $subtest); + is($address->host(), undef, $subtest); + is($address->address(), undef, $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), '', $subtest); + is(with_warning { $address->format() }, '', $subtest); + } + + { + my $subtest = 'test method new() with one argument'; + my $address = Email::Address::XS->new('Addressless Outer Party Member'); + ok(!$address->is_valid(), $subtest); + is($address->phrase(), 'Addressless Outer Party Member', $subtest); + is($address->user(), undef, $subtest); + is($address->host(), undef, $subtest); + is($address->address(), undef, $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), 'Addressless Outer Party Member', $subtest); + is(with_warning { $address->format() }, '', $subtest); + } + + { + my $subtest = 'test method new() with two arguments as array'; + my $address = Email::Address::XS->new(undef, 'user@oceania'); + ok($address->is_valid(), $subtest); + is($address->phrase(), undef, $subtest); + is($address->user(), 'user', $subtest); + is($address->host(), 'oceania', $subtest); + is($address->address(), 'user@oceania', $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), 'user', $subtest); + is($address->format(), 'user@oceania', $subtest); + } + + { + my $subtest = 'test method new() with two arguments as hash'; + my $address = Email::Address::XS->new(address => 'winston.smith@recdep.minitrue'); + ok($address->is_valid(), $subtest); + is($address->phrase(), undef, $subtest); + is($address->user(), 'winston.smith', $subtest); + is($address->host(), 'recdep.minitrue', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), 'winston.smith', $subtest); + is($address->format(), 'winston.smith@recdep.minitrue', $subtest); + } + + { + my $subtest = 'test method new() with two arguments as array'; + my $address = Email::Address::XS->new(Julia => 'julia@ficdep.minitrue'); + ok($address->is_valid(), $subtest); + is($address->phrase(), 'Julia', $subtest); + is($address->user(), 'julia', $subtest); + is($address->host(), 'ficdep.minitrue', $subtest); + is($address->address(), 'julia@ficdep.minitrue', $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), 'Julia', $subtest); + is($address->format(), 'Julia ', $subtest); + } + + { + my $subtest = 'test method new() with three arguments'; + my $address = Email::Address::XS->new('Winston Smith', 'winston.smith@recdep.minitrue', 'Records Department'); + ok($address->is_valid(), $subtest); + is($address->phrase(), 'Winston Smith', $subtest); + is($address->user(), 'winston.smith', $subtest); + is($address->host(), 'recdep.minitrue', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + is($address->comment(), 'Records Department', $subtest); + is($address->name(), 'Winston Smith', $subtest); + is($address->format(), '"Winston Smith" (Records Department)', $subtest); + } + + { + my $subtest = 'test method new() with four arguments user & host as hash'; + my $address = Email::Address::XS->new(user => 'julia', host => 'ficdep.minitrue'); + ok($address->is_valid(), $subtest); + is($address->phrase(), undef, $subtest); + is($address->user(), 'julia', $subtest); + is($address->host(), 'ficdep.minitrue', $subtest); + is($address->address(), 'julia@ficdep.minitrue', $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), 'julia', $subtest); + is($address->format(), 'julia@ficdep.minitrue', $subtest); + } + + { + my $subtest = 'test method new() with four arguments phrase & address as hash'; + my $address = Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'); + ok($address->is_valid(), $subtest); + is($address->phrase(), 'Julia', $subtest); + is($address->user(), 'julia', $subtest); + is($address->host(), 'ficdep.minitrue', $subtest); + is($address->address(), 'julia@ficdep.minitrue', $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), 'Julia', $subtest); + is($address->format(), 'Julia ', $subtest); + } + + { + my $subtest = 'test method new() with four arguments as array'; + my $address = with_warning { Email::Address::XS->new('Julia', 'julia@ficdep.minitrue', 'Fiction Department', 'deprecated_original_string') }; + ok($address->is_valid(), $subtest); + is($address->phrase(), 'Julia', $subtest); + is($address->user(), 'julia', $subtest); + is($address->host(), 'ficdep.minitrue', $subtest); + is($address->address(), 'julia@ficdep.minitrue', $subtest); + is($address->comment(), 'Fiction Department', $subtest); + is($address->name(), 'Julia', $subtest); + is($address->format(), 'Julia (Fiction Department)', $subtest); + } + + { + my $subtest = 'test method new() with four arguments as hash (phrase is string "address")'; + my $address = Email::Address::XS->new(phrase => 'address', address => 'user@oceania'); + ok($address->is_valid(), $subtest); + is($address->phrase(), 'address', $subtest); + is($address->user(), 'user', $subtest); + is($address->host(), 'oceania', $subtest); + is($address->address(), 'user@oceania', $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), 'address', $subtest); + is($address->format(), 'address ', $subtest); + } + + { + my $subtest = 'test method new() with copy argument'; + my $address = Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'); + my $copy = Email::Address::XS->new(copy => $address); + ok($address->is_valid(), $subtest); + ok($copy->is_valid(), $subtest); + is($copy->phrase(), 'Julia', $subtest); + is($copy->user(), 'julia', $subtest); + is($copy->host(), 'ficdep.minitrue', $subtest); + is($copy->address(), 'julia@ficdep.minitrue', $subtest); + is($copy->comment(), undef, $subtest); + $copy->phrase('Winston Smith'); + $copy->address('winston.smith@recdep.minitrue'); + $copy->comment('Records Department'); + is($address->phrase(), 'Julia', $subtest); + is($address->user(), 'julia', $subtest); + is($address->host(), 'ficdep.minitrue', $subtest); + is($address->address(), 'julia@ficdep.minitrue', $subtest); + is($address->comment(), undef, $subtest); + $address->phrase(undef); + $address->address(undef); + $address->comment(undef); + is($copy->phrase(), 'Winston Smith', $subtest); + is($copy->user(), 'winston.smith', $subtest); + is($copy->host(), 'recdep.minitrue', $subtest); + is($copy->address(), 'winston.smith@recdep.minitrue', $subtest); + is($copy->comment(), 'Records Department', $subtest); + } + + { + my $subtest = 'test method new() with invalid email address'; + my $address = Email::Address::XS->new(address => 'invalid_address'); + ok(!$address->is_valid(), $subtest); + is($address->phrase(), undef, $subtest); + is($address->user(), undef, $subtest); + is($address->host(), undef, $subtest); + is($address->address(), undef, $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), '', $subtest); + is(with_warning { $address->format() }, '', $subtest); + } + + { + my $subtest = 'test method new() with copy argument of invalid email address'; + my $address = Email::Address::XS->new(address => 'invalid_address'); + my $copy = Email::Address::XS->new(copy => $address); + ok(!$address->is_valid(), $subtest); + ok(!$copy->is_valid(), $subtest); + } + + { + my $subtest = 'test method new() with empty strings for user and non empty for host and phrase'; + my $address = Email::Address::XS->new(user => '', host => 'host', phrase => 'phrase'); + ok($address->is_valid(), $subtest); + is($address->phrase(), 'phrase', $subtest); + is($address->user(), '', $subtest); + is($address->host(), 'host', $subtest); + is($address->address(), '""@host', $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), 'phrase', $subtest); + is($address->format(), 'phrase <""@host>', $subtest); + } + + { + my $subtest = 'test method new() with empty strings for host and non empty for user and phrase'; + my $address = Email::Address::XS->new(user => 'user', host => '', phrase => 'phrase'); + ok(!$address->is_valid(), $subtest); + is($address->phrase(), 'phrase', $subtest); + is($address->user(), 'user', $subtest); + is($address->host(), undef, $subtest); + is($address->address(), undef, $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), 'phrase', $subtest); + is(with_warning { $address->format() }, '', $subtest); + } + + { + my $subtest = 'test method new() with all named arguments'; + my $address = Email::Address::XS->new(phrase => 'Julia', user => 'julia', host => 'ficdep.minitrue', comment => 'Fiction Department'); + ok($address->is_valid(), $subtest); + is($address->phrase(), 'Julia', $subtest); + is($address->user(), 'julia', $subtest); + is($address->host(), 'ficdep.minitrue', $subtest); + is($address->address(), 'julia@ficdep.minitrue', $subtest); + is($address->comment(), 'Fiction Department', $subtest); + is($address->name(), 'Julia', $subtest); + is($address->format(), 'Julia (Fiction Department)', $subtest); + } + + { + my $subtest = 'test method new() that address takes precedence over user and host'; + my $address = Email::Address::XS->new(user => 'winston.smith', host => 'recdep.minitrue', address => 'julia@ficdep.minitrue' ); + is($address->user(), 'julia', $subtest); + is($address->host(), 'ficdep.minitrue', $subtest); + is($address->address(), 'julia@ficdep.minitrue', $subtest); + } + + { + my $subtest = 'test method new() with UNICODE characters'; + my $address = Email::Address::XS->new(phrase => "\x{2606} \x{2602}", user => "\x{263b} \x{265e}", host => "\x{262f}.\x{262d}", comment => "\x{2622} \x{20ac}"); + ok($address->is_valid(), $subtest); + is($address->phrase(), "\x{2606} \x{2602}", $subtest); + is($address->user(), "\x{263b} \x{265e}", $subtest); + is($address->host(), "\x{262f}.\x{262d}", $subtest); + is($address->address(), "\"\x{263b} \x{265e}\"\@\x{262f}.\x{262d}", $subtest); + is($address->comment(), "\x{2622} \x{20ac}", $subtest); + is($address->name(), "\x{2606} \x{2602}", $subtest); + is($address->format(), "\"\x{2606} \x{2602}\" <\"\x{263b} \x{265e}\"\@\x{262f}.\x{262d}> (\x{2622} \x{20ac})", $subtest); + } + + { + my $subtest = 'test method new() with Latin1 characters'; + my $address = Email::Address::XS->new(user => "L\x{e1}tin1", host => "L\x{e1}tin1"); + ok($address->is_valid(), $subtest); + is($address->phrase(), undef, $subtest); + is($address->user(), "L\x{e1}tin1", $subtest); + is($address->host(), "L\x{e1}tin1", $subtest); + is($address->address(), "L\x{e1}tin1\@L\x{e1}tin1", $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), "L\x{e1}tin1", $subtest); + is($address->format(), "L\x{e1}tin1\@L\x{e1}tin1", $subtest); + } + + { + my $subtest = 'test method new() with mix of Latin1 and UNICODE characters'; + my $address = Email::Address::XS->new(user => "L\x{e1}tin1", host => "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"); + ok($address->is_valid(), $subtest); + is($address->phrase(), undef, $subtest); + is($address->user(), "L\x{e1}tin1", $subtest); + is($address->host(), "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}", $subtest); + is($address->address(), "L\x{e1}tin1\@\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}", $subtest); + is($address->comment(), undef, $subtest); + is($address->name(), "L\x{e1}tin1", $subtest); + is($address->format(), "L\x{e1}tin1\@\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}", $subtest); + } + +} + +######################### + +{ + + my $address = Email::Address::XS->new(); + is($address->phrase(), undef, 'test method phrase()'); + + is($address->phrase('Winston Smith'), 'Winston Smith', 'test method phrase()'); + is($address->phrase(), 'Winston Smith', 'test method phrase()'); + + is($address->phrase('Julia'), 'Julia', 'test method phrase()'); + is($address->phrase(), 'Julia', 'test method phrase()'); + + is($address->phrase(undef), undef, 'test method phrase()'); + is($address->phrase(), undef, 'test method phrase()'); + +} + +######################### + +{ + + my $address = Email::Address::XS->new(); + is($address->user(), undef, 'test method user()'); + + is($address->user('winston'), 'winston', 'test method user()'); + is($address->user(), 'winston', 'test method user()'); + + is($address->user('julia'), 'julia', 'test method user()'); + is($address->user(), 'julia', 'test method user()'); + + is($address->user(undef), undef, 'test method user()'); + is($address->user(), undef, 'test method user()'); + +} + +######################### + +{ + + my $address = Email::Address::XS->new(); + is($address->host(), undef, 'test method host()'); + + is($address->host('eurasia'), 'eurasia', 'test method host()'); + is($address->host(), 'eurasia', 'test method host()'); + + is($address->host('eastasia'), 'eastasia', 'test method host()'); + is($address->host(), 'eastasia', 'test method host()'); + + is($address->host(undef), undef, 'test method host()'); + is($address->host(), undef, 'test method host()'); + +} + +######################### + +{ + + my $address = Email::Address::XS->new(); + is($address->address(), undef, 'test method address()'); + + is($address->address('winston.smith@recdep.minitrue'), 'winston.smith@recdep.minitrue', 'test method address()'); + is($address->address(), 'winston.smith@recdep.minitrue', 'test method address()'); + is($address->user(), 'winston.smith', 'test method address()'); + is($address->host(), 'recdep.minitrue', 'test method address()'); + + is($address->user('julia@outer"party'), 'julia@outer"party', 'test method address()'); + is($address->user(), 'julia@outer"party', 'test method address()'); + is($address->host(), 'recdep.minitrue', 'test method address()'); + is($address->address(), '"julia@outer\\"party"@recdep.minitrue', 'test method address()'); + + is($address->address('julia@ficdep.minitrue'), 'julia@ficdep.minitrue', 'test method address()'); + is($address->address(), 'julia@ficdep.minitrue', 'test method address()'); + is($address->user(), 'julia', 'test method address()'); + is($address->host(), 'ficdep.minitrue', 'test method address()'); + + is($address->address(undef), undef, 'test method address()'); + is($address->address(), undef, 'test method address()'); + is($address->user(), undef, 'test method address()'); + is($address->host(), undef, 'test method address()'); + + is($address->address('julia@ficdep.minitrue'), 'julia@ficdep.minitrue', 'test method address()'); + is($address->address('invalid_address'), undef, 'test method address()'); + is($address->address(), undef, 'test method address()'); + +} + +######################### + +{ + + my $address = Email::Address::XS->new(); + is($address->comment(), undef, 'test method comment()'); + + is($address->comment('Fiction Department'), 'Fiction Department', 'test method comment()'); + is($address->comment(), 'Fiction Department', 'test method comment()'); + + is($address->comment('Records Department'), 'Records Department', 'test method comment()'); + is($address->comment(), 'Records Department', 'test method comment()'); + + is($address->comment(undef), undef, 'test method comment()'); + is($address->comment(), undef, 'test method comment()'); + + is($address->comment('(comment)'), '(comment)', 'test method comment()'); + is($address->comment(), '(comment)', 'test method comment()'); + + is($address->comment('string (comment) string'), 'string (comment) string', 'test method comment()'); + is($address->comment(), 'string (comment) string', 'test method comment()'); + + is($address->comment('string (comment (nested ()comment)another comment)()'), 'string (comment (nested ()comment)another comment)()', 'test method comment()'); + is($address->comment(), 'string (comment (nested ()comment)another comment)()', 'test method comment()'); + + is($address->comment('string (comment \(not nested ()comment\)\)(nested\(comment()))'), 'string (comment \(not nested ()comment\)\)(nested\(comment()))', 'test method comment()'); + is($address->comment(), 'string (comment \(not nested ()comment\)\)(nested\(comment()))', 'test method comment()'); + + is($address->comment('string\\\\()'), 'string\\\\()', 'test method comment()'); + is($address->comment(), 'string\\\\()', 'test method comment()'); + + is($address->comment('string\\\\\\\\()'), 'string\\\\\\\\()', 'test method comment()'); + is($address->comment(), 'string\\\\\\\\()', 'test method comment()'); + + is($address->comment('string ((not balanced comment)'), undef, 'test method comment()'); + is($address->comment(), undef, 'test method comment()'); + + is($address->comment('string )(()not balanced'), undef, 'test method comment()'); + is($address->comment(), undef, 'test method comment()'); + + is($address->comment('string \()not balanced'), undef, 'test method comment()'); + is($address->comment(), undef, 'test method comment()'); + + is($address->comment('string(\)not balanced'), undef, 'test method comment()'); + is($address->comment(), undef, 'test method comment()'); + + is($address->comment('string(\\\\\)not balanced'), undef, 'test method comment()'); + is($address->comment(), undef, 'test method comment()'); + + is($address->comment("string\x00string"), undef, 'test method comment()'); + is($address->comment(), undef, 'test method comment()'); + + is($address->comment("string\\\x00string"), "string\\\x00string", 'test method comment()'); + is($address->comment(), "string\\\x00string", 'test method comment()'); + +} + +######################### + +{ + + my $address = Email::Address::XS->new(); + is($address->name(), '', 'test method name()'); + + $address->user('user1'); + is($address->name(), 'user1', 'test method name()'); + + $address->user('user2'); + is($address->name(), 'user2', 'test method name()'); + + $address->host('host'); + is($address->name(), 'user2', 'test method name()'); + + $address->address('winston.smith@recdep.minitrue'); + is($address->name(), 'winston.smith', 'test method name()'); + + $address->comment('Winston'); + is($address->name(), 'Winston', 'test method name()'); + + $address->phrase('Long phrase'); + is($address->name(), 'Long phrase', 'test method name()'); + + $address->phrase('Long phrase 2'); + is($address->name(), 'Long phrase 2', 'test method name()'); + + $address->user('user3'); + is($address->name(), 'Long phrase 2', 'test method name()'); + + $address->comment('winston'); + is($address->name(), 'Long phrase 2', 'test method name()'); + + $address->phrase(undef); + is($address->name(), 'winston', 'test method name()'); + + $address->comment(undef); + is($address->name(), 'user3', 'test method name()'); + + $address->address(undef); + is($address->name(), '', 'test method name()'); + + $address->phrase('Long phrase 3'); + is($address->phrase(), 'Long phrase 3', 'test method name()'); + +} + +######################### + +{ + + # set original stringify operator + { + local $SIG{__WARN__} = sub { }; + overload::OVERLOAD 'Email::Address::XS', '""' => $obj_to_origstr; + } + + my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'); + is("$address", '"Winston Smith" ', 'test object stringify'); + + $address->phrase('Winston'); + is("$address", 'Winston ', 'test object stringify'); + + $address->address('winston@recdep.minitrue'); + is("$address", 'Winston ', 'test object stringify'); + + $address->phrase(undef); + is("$address", 'winston@recdep.minitrue', 'test object stringify'); + + $address->address(undef); + is(with_warning { "$address" }, '', 'test object stringify'); + + # revert back + { + local $SIG{__WARN__} = sub { }; + overload::OVERLOAD 'Email::Address::XS', '""' => $obj_to_hashstr; + } + +} + +######################### + +{ + + my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'); + is($address->format(), '"Winston Smith" ', 'test method format()'); + + $address->phrase('Julia'); + is($address->format(), 'Julia ', 'test method format()'); + + $address->address('julia@ficdep.minitrue'); + is($address->format(), 'Julia ', 'test method format()'); + + $address->phrase(undef); + is($address->format(), 'julia@ficdep.minitrue', 'test method format()'); + + $address->address(undef); + is(with_warning { $address->format() }, '', 'test method format()'); + + $address->user('julia'); + is(with_warning { $address->format() }, '', 'test method format()'); + + $address->host('ficdep.minitrue'); + is($address->format(), 'julia@ficdep.minitrue', 'test method format()'); + + $address->user(undef); + is(with_warning { $address->format() }, '', 'test method format()'); + +} + +######################### + +{ + + is_deeply( + [ with_warning { Email::Address::XS->parse() } ], + [], + 'test method parse() without argument', + ); + + is_deeply( + [ with_warning { Email::Address::XS->parse(undef) } ], + [], + 'test method parse() with undef argument', + ); + + is_deeply( + [ Email::Address::XS->parse('') ], + [], + 'test method parse() on empty string', + ); + + { + my $subtest = 'test method parse() on invalid not parsable line'; + my @addresses = Email::Address::XS->parse('invalid_line'); + is_deeply( + \@addresses, + [ Email::Address::XS->new(phrase => 'invalid_line') ], + $subtest, + ) and do { + ok(!$addresses[0]->is_valid(), $subtest); + is($addresses[0]->original(), 'invalid_line', $subtest); + }; + } + + { + my $subtest = 'test method parse() on string with valid addresses'; + my @addresses = Email::Address::XS->parse('"Winston Smith" , Julia , user@oceania'); + is_deeply( + \@addresses, + [ + Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'), + Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'), + Email::Address::XS->new(address => 'user@oceania') + ], + $subtest, + ) and do { + ok($addresses[0]->is_valid(), $subtest); + ok($addresses[1]->is_valid(), $subtest); + ok($addresses[2]->is_valid(), $subtest); + is($addresses[0]->original(), '"Winston Smith" ', $subtest); + is($addresses[1]->original(), 'Julia ', $subtest); + is($addresses[2]->original(), 'user@oceania', $subtest); + }; + } + + { + my $subtest = 'test method parse() in scalar context on empty string'; + my $address = Email::Address::XS->parse(''); + ok(!$address->is_valid(), $subtest); + is($address->original(), '', $subtest); + is($address->phrase(), undef, $subtest); + is($address->address(), undef, $subtest); + } + + { + my $subtest = 'test method parse() in scalar context with one address'; + my $address = Email::Address::XS->parse('"Winston Smith" '); + ok($address->is_valid(), $subtest); + is($address->original(), '"Winston Smith" ', $subtest); + is($address->phrase(), 'Winston Smith', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + } + + { + my $subtest = 'test method parse() in scalar context with more addresses'; + my $address = Email::Address::XS->parse('"Winston Smith" , Julia , user@oceania'); + ok(!$address->is_valid(), $subtest); + is($address->original(), '"Winston Smith" ', $subtest); + is($address->phrase(), 'Winston Smith', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + } + + { + my $subtest = 'test method parse() in scalar context with invalid, but parsable angle address'; + my $address = Email::Address::XS->parse('"Winston Smith" '); + ok(!$address->is_valid(), $subtest); + is($address->original(), '"Winston Smith" ', $subtest); + is($address->phrase(), 'Winston Smith', $subtest); + is($address->user(), 'winston.smith.', $subtest); + is($address->host(), 'recdep.minitrue', $subtest); + is($address->address(), '"winston.smith."@recdep.minitrue', $subtest); + } + + { + my $subtest = 'test method parse() in scalar context with invalid, but parsable bare address'; + my $address = Email::Address::XS->parse('winston.smith.@recdep.minitrue'); + ok(!$address->is_valid(), $subtest); + is($address->original(), 'winston.smith.@recdep.minitrue', $subtest); + is($address->user(), 'winston.smith.', $subtest); + is($address->host(), 'recdep.minitrue', $subtest); + is($address->address(), '"winston.smith."@recdep.minitrue', $subtest); + } + + { + my $subtest = 'test method parse() in scalar context with valid address followed by garbage'; + my $address = Email::Address::XS->parse('winston.smith@recdep.minitrue garbage'); + ok(!$address->is_valid(), $subtest); + is($address->original(), 'winston.smith@recdep.minitrue ', $subtest); + is($address->user(), 'winston.smith', $subtest); + is($address->host(), 'recdep.minitrue', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + } + +} + +######################### + +{ + + { + my $subtest = 'test method parse_bare_address() without argument'; + my $address = with_warning { Email::Address::XS->parse_bare_address() }; + ok(!$address->is_valid(), $subtest); + is($address->original(), undef, $subtest); + is($address->address(), undef, $subtest); + } + + { + my $subtest = 'test method parse_bare_address() with undef argument'; + my $address = with_warning { Email::Address::XS->parse_bare_address(undef) }; + ok(!$address->is_valid(), $subtest); + is($address->original(), undef, $subtest); + is($address->address(), undef, $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on empty string'; + my $address = Email::Address::XS->parse_bare_address(''); + ok(!$address->is_valid(), $subtest); + is($address->original(), '', $subtest); + is($address->address(), undef, $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on invalid not parsable address'; + my $address = Email::Address::XS->parse_bare_address('invalid_line'); + ok(!$address->is_valid(), $subtest); + is($address->original(), 'invalid_line', $subtest); + is($address->address(), undef, $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on invalid input string - address with angle brackets'; + my $address = Email::Address::XS->parse_bare_address(''); + ok(!$address->is_valid(), $subtest); + is($address->original(), '', $subtest); + is($address->address(), undef, $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on invalid input string - phrase with address'; + my $address = Email::Address::XS->parse_bare_address('Winston Smith '); + ok(!$address->is_valid(), $subtest); + is($address->original(), 'Winston Smith ', $subtest); + is($address->address(), undef, $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on invalid input string - two addresses'; + my $address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue, julia@ficdep.minitrue'); + ok(!$address->is_valid(), $subtest); + is($address->original(), 'winston.smith@recdep.minitrue, julia@ficdep.minitrue', $subtest); + is($address->address(), undef, $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on valid input string'; + my $address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue'); + ok($address->is_valid(), $subtest); + is($address->original(), 'winston.smith@recdep.minitrue', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on valid input string with comment'; + my $address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue(comment)'); + ok($address->is_valid(), $subtest); + is($address->original(), 'winston.smith@recdep.minitrue(comment)', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on valid input string with comment'; + my $address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue (comment)'); + ok($address->is_valid(), $subtest); + is($address->original(), 'winston.smith@recdep.minitrue (comment)', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on valid input string with comment'; + my $address = Email::Address::XS->parse_bare_address('(comment)winston.smith@recdep.minitrue'); + ok($address->is_valid(), $subtest); + is($address->original(), '(comment)winston.smith@recdep.minitrue', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on valid input string with comment'; + my $address = Email::Address::XS->parse_bare_address('(comment) winston.smith@recdep.minitrue'); + ok($address->is_valid(), $subtest); + is($address->original(), '(comment) winston.smith@recdep.minitrue', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on valid input string with two comments'; + my $address = Email::Address::XS->parse_bare_address('(comment)winston.smith@recdep.minitrue(comment)'); + ok($address->is_valid(), $subtest); + is($address->original(), '(comment)winston.smith@recdep.minitrue(comment)', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on valid input string with two comments'; + my $address = Email::Address::XS->parse_bare_address('(comment) winston.smith@recdep.minitrue (comment)'); + ok($address->is_valid(), $subtest); + is($address->original(), '(comment) winston.smith@recdep.minitrue (comment)', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + } + + { + my $subtest = 'test method parse_bare_address() on valid input string with lot of comments'; + my $address = Email::Address::XS->parse_bare_address('(comm(e)nt) (co(m)ment) winston (comment) . smith@recdep.minitrue (c(o)mment) (comment)'); + ok($address->is_valid(), $subtest); + is($address->original(), '(comm(e)nt) (co(m)ment) winston (comment) . smith@recdep.minitrue (c(o)mment) (comment)', $subtest); + is($address->address(), 'winston.smith@recdep.minitrue', $subtest); + } + +} + +######################### + +{ + + is( + format_email_addresses(), + '', + 'test function format_email_addresses() with empty list of addresses', + ); + + is( + with_warning { format_email_addresses('invalid string') }, + '', + 'test function format_email_addresses() with invalid string argument', + ); + + is( + format_email_addresses(Email::Address::XS::Derived->new(user => 'user', host => 'host')), + 'user_derived_suffix@host', + 'test function format_email_addresses() with derived object class', + ); + + is( + with_warning { format_email_addresses(Email::Address::XS::NotDerived->new(user => 'user', host => 'host')) }, + '', + 'test function format_email_addresses() with not derived object class', + ); + + is( + with_warning { format_email_addresses(bless([], 'invalid_object_class')) }, + '', + 'test function format_email_addresses() with invalid object class', + ); + + is( + format_email_addresses( + Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'), + Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'), + Email::Address::XS->new(phrase => "O'Brien", user => "o'brien", host => 'thought.police.oceania'), + Email::Address::XS->new(phrase => 'Mr. Charrington', user => 'charrington"@"shop', host => 'thought.police.oceania'), + Email::Address::XS->new(phrase => 'Emmanuel Goldstein', address => 'goldstein@brotherhood.oceania'), + Email::Address::XS->new(address => 'user@oceania'), + Email::Address::XS->new(phrase => 'Escape " also , characters ;', address => 'user2@oceania'), + Email::Address::XS->new(phrase => 'user5@oceania" , "', address => 'user4@oceania'), + Email::Address::XS->new(user => '.user7', host => 'oceania'), + Email::Address::XS->new(user => 'user8.', host => 'oceania'), + Email::Address::XS->new(phrase => '"', address => 'user9@oceania'), + Email::Address::XS->new(phrase => "Mr. '", address => 'user10@oceania'), + ), + q("Winston Smith" , Julia , O'Brien , "Mr. Charrington" <"charrington\"@\"shop"@thought.police.oceania>, "Emmanuel Goldstein" , user@oceania, "Escape \" also , characters ;" , "user5@oceania\" , \"" , ".user7"@oceania, "user8."@oceania, "\"" , "Mr. '" ), + 'test function format_email_addresses() with list of different type of addresses', + ); + +} + +######################### + +{ + + is_deeply( + [ with_warning { parse_email_addresses(undef) } ], + [], + 'test function parse_email_addresses() with undef argument', + ); + + is_deeply( + [ parse_email_addresses('') ], + [], + 'test function parse_email_addresses() on empty string', + ); + + is_deeply( + [ parse_email_addresses('incorrect') ], + [ Email::Address::XS->new(phrase => 'incorrect') ], + 'test function parse_email_addresses() on incorrect string', + ); + + is_deeply( + [ parse_email_addresses('Winston Smith ') ], + [ Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue') ], + 'test function parse_email_addresses() on string with unquoted phrase', + ); + + is_deeply( + [ parse_email_addresses('"Winston Smith" ') ], + [ Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue') ], + 'test function parse_email_addresses() on string with quoted phrase', + ); + + is_deeply( + [ parse_email_addresses('"Winston Smith" "suffix" suffix2 ') ], + [ Email::Address::XS->new(phrase => 'Winston Smith suffix suffix2', address => 'winston.smith@recdep.minitrue') ], + 'test function parse_email_addresses() on string with more words in phrase', + ); + + is_deeply( + [ parse_email_addresses('winston.smith@recdep.minitrue') ], + [ Email::Address::XS->new(address => 'winston.smith@recdep.minitrue') ], + 'test function parse_email_addresses() on string with just address', + ); + + is_deeply( + [ parse_email_addresses('winston.smith@recdep.minitrue (Winston Smith)') ], + [ Email::Address::XS->new(address => 'winston.smith@recdep.minitrue', comment => 'Winston Smith') ], + 'test function parse_email_addresses() on string with comment after address', + ); + + is_deeply( + [ parse_email_addresses('') ], + [ Email::Address::XS->new(address => 'winston.smith@recdep.minitrue') ], + 'test function parse_email_addresses() on string with just address in angle brackets', + ); + + is_deeply( + [ parse_email_addresses('"user@oceania" : winston.smith@recdep.minitrue') ], + [ Email::Address::XS->new(address => 'winston.smith@recdep.minitrue') ], + 'test function parse_email_addresses() on string with character @ inside group name', + ); + + is_deeply( + [ parse_email_addresses('"user@oceania" ') ], + [ Email::Address::XS->new(phrase => 'user@oceania', address => 'winston.smith@recdep.minitrue') ], + 'test function parse_email_addresses() on string with character @ inside phrase', + ); + + is_deeply( + [ parse_email_addresses('"User " ') ], + [ Email::Address::XS->new(phrase => 'User ', address => 'winston.smith@recdep.minitrue') ], + 'test function parse_email_addresses() on string with email address inside phrase', + ); + + is_deeply( + [ parse_email_addresses('"julia@outer\\"party"@ficdep.minitrue') ], + [ Email::Address::XS->new(user => 'julia@outer"party', host => 'ficdep.minitrue') ], + 'test function parse_email_addresses() on string with quoted and escaped mailbox part of address', + ); + + is_deeply( + [ parse_email_addresses('"Winston Smith" , Julia ') ], + [ + Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'), + Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'), + ], + 'test function parse_email_addresses() on string with two items', + ); + + is_deeply( + [ parse_email_addresses('"Winston Smith" , Julia , user@oceania') ], + [ + Email::Address::XS->new('Winston Smith', 'winston.smith@recdep.minitrue'), + Email::Address::XS->new('Julia', 'julia@ficdep.minitrue'), Email::Address::XS->new(address => 'user@oceania'), + ], + 'test function parse_email_addresses() on string with three items', + ); + + is_deeply( + [ parse_email_addresses('(leading comment)"Winston (Smith)" (comment after), Julia (Unknown) (additional comment)') ], + [ + Email::Address::XS->new(phrase => 'Winston (Smith)', address => 'winston.smith@recdep.minitrue', comment => 'comment after'), + Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue', comment => 'additional comment'), + ], + 'test function parse_email_addresses() on string with a lots of comments', + ); + + is_deeply( + [ parse_email_addresses('Winston Smith( , Julia) ') ], + [ Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue') ], + 'test function parse_email_addresses() on string with comma in comment', + ); + + is_deeply( + [ parse_email_addresses('"Winston Smith" ( , (Julia) , ) ' ) ], + [ Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue') ], + 'test function parse_email_addresses() on string with nested comments', + ); + + is_deeply( + [ parse_email_addresses('Winston Smith ' ) ], + [ Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue', comment => 'comment') ], + 'test function parse_email_addresses() on string with obsolate white spaces', + ); + + is_deeply( + [ parse_email_addresses("\302\257\302\257`\302\267.\302\245\302\253P\302\256\303\216\303\221\303\247\342\202\254\303\230fTh\342\202\254\303\220\303\205\302\256K\302\273\302\245.\302\267`\302\257\302\257 , \"(> \\\" \\\" <) ( ='o'= ) (\\\")___(\\\") sWeEtAnGeLtHePrInCeSsOfThEsKy\" , \"(i)cRiStIaN(i)\" , \"(S)MaNu_vuOLeAmMazZaReNimOe(*)MiAo(\@)\" \n") ], + [ + Email::Address::XS->new(phrase => "\302\257\302\257`\302\267.\302\245\302\253P\302\256\303\216\303\221\303\247\342\202\254\303\230fTh\342\202\254\303\220\303\205\302\256K\302\273\302\245.\302\267`\302\257\302\257", user => 'email', host => 'example.com'), + Email::Address::XS->new(phrase => '(> " " <) ( =\'o\'= ) (")___(") sWeEtAnGeLtHePrInCeSsOfThEsKy', user => 'email2', host => 'example.com'), + Email::Address::XS->new(phrase => '(i)cRiStIaN(i)', user => 'email3', host => 'example.com'), + Email::Address::XS->new(phrase => '(S)MaNu_vuOLeAmMazZaReNimOe(*)MiAo(@)', user => 'email4', host => 'example.com'), + ], + 'test function parse_email_addresses() on CVE-2015-7686 string', + ); + + is_deeply( + [ parse_email_addresses('aaaa@') ], + [ Email::Address::XS->new(user => 'aaaa') ], + 'test function parse_email_addresses() on CVE-2017-14461 string', + ); + + is_deeply( + [ parse_email_addresses('a(aa') ], + [ Email::Address::XS->new() ], + 'test function parse_email_addresses() on CVE-2017-14461 string', + ); + + is_deeply( + [ parse_email_addresses('"Winston Smith" , Julia , O\'Brien , "Mr. Charrington" <"charrington\"@\"shop"@thought.police.oceania>, "Emmanuel Goldstein" , user@oceania, "Escape \" also , characters ;" , "user5@oceania\" , \"" ') ], + [ + Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'), + Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'), + Email::Address::XS->new(phrase => "O'Brien", user => "o'brien", host => 'thought.police.oceania'), + Email::Address::XS->new(phrase => 'Mr. Charrington', user => 'charrington"@"shop', host => 'thought.police.oceania'), + Email::Address::XS->new(phrase => 'Emmanuel Goldstein', address => 'goldstein@brotherhood.oceania'), + Email::Address::XS->new(address => 'user@oceania'), + Email::Address::XS->new(phrase => 'Escape " also , characters ;', address => 'user2@oceania'), + Email::Address::XS->new(phrase => 'user5@oceania" , "', address => 'user4@oceania'), + ], + 'test function parse_email_addresses() on string with lots of different types of addresses', + ); + + is_deeply( + [ parse_email_addresses('winston.smith@recdep.minitrue', 'Email::Address::XS::Derived') ], + [ bless({ phrase => undef, user => 'winston.smith', host => 'recdep.minitrue', comment => undef }, 'Email::Address::XS::Derived') ], + 'test function parse_email_addresses() with second derived class name argument', + ); + + is_deeply( + [ with_warning { parse_email_addresses('winston.smith@recdep.minitrue', 'Email::Address::XS::NotDerived') } ], + [], + 'test function parse_email_addresses() with second not derived class name argument', + ); + +} + +######################### + +{ + + my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'); + my $julias_address = Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'); + my $obriens_address = Email::Address::XS->new(phrase => "O'Brien", user => "o'brien", host => 'thought.police.oceania'); + my $charringtons_address = Email::Address::XS->new(phrase => 'Mr. Charrington', user => 'charrington"@"shop', host => 'thought.police.oceania'); + my $goldsteins_address = Email::Address::XS->new(phrase => 'Emmanuel Goldstein', address => 'goldstein@brotherhood.oceania'); + my $users_address = Email::Address::XS->new(address => 'user@oceania'); + my $user2s_address = Email::Address::XS->new(phrase => 'Escape " also , characters', address => 'user2@oceania'); + my $user3s_address = Email::Address::XS->new(address => 'user3@oceania'); + my $user4s_address = Email::Address::XS->new(phrase => 'user5@oceania" , "', address => 'user4@oceania'); + + my $winstons_mime_address = Email::Address::XS->new(phrase => '=?US-ASCII?Q?Winston?= Smith', address => 'winston.smith@recdep.minitrue'); + my $julias_mime_address = Email::Address::XS->new(phrase => '=?US-ASCII?Q?Julia?=', address => 'julia@ficdep.minitrue'); + + my $derived_object = Email::Address::XS::Derived->new(user => 'user', host => 'host'); + my $not_derived_object = Email::Address::XS::NotDerived->new(user => 'user', host => 'host'); + + my $nameless_group = ''; + my $brotherhood_group = 'Brotherhood'; + my $minitrue_group = 'Ministry of "Truth"'; + my $thoughtpolice_group = 'Thought Police'; + my $users_group = 'users@oceania'; + my $undisclosed_group = 'undisclosed-recipients'; + my $mime_group = '=?US-ASCII?Q?MIME?='; + + is( + with_warning { format_email_groups('first', 'second', 'third') }, + undef, + 'test function format_email_groups() with odd number of arguments', + ); + + is( + with_warning { format_email_groups('name', undef) }, + 'name:;', + 'test function format_email_groups() with invalid type second argument (undef)', + ); + + is( + with_warning { format_email_groups('name', 'string') }, + 'name:;', + 'test function format_email_groups() with invalid type second argument (string)', + ); + + is( + format_email_groups(), + '', + 'test function format_email_groups() with empty list of groups', + ); + + is( + format_email_groups(undef() => []), + '', + 'test function format_email_groups() with empty list of addresses in one undef group', + ); + + is( + format_email_groups(undef() => [ $users_address ]), + 'user@oceania', + 'test function format_email_groups() with one email address in undef group', + ); + + is( + format_email_groups($nameless_group => [ $users_address ]), + '"": user@oceania;', + 'test function format_email_groups() with one email address in nameless group', + ); + + is( + format_email_groups($undisclosed_group => []), + 'undisclosed-recipients:;', + 'test function format_email_groups() with empty list of addresses in one named group', + ); + + is( + format_email_groups(undef() => [ $derived_object ]), + 'user_derived_suffix@host', + 'test function format_email_groups() with derived object class', + ); + + is( + with_warning { format_email_groups(undef() => [ $not_derived_object ]) }, + '', + 'test function format_email_groups() with not derived object class', + ); + + is( + format_email_groups($brotherhood_group => [ $winstons_address, $julias_address ]), + 'Brotherhood: "Winston Smith" , Julia ;', + 'test function format_email_groups() with two addresses in one named group', + ); + + is( + format_email_groups( + $brotherhood_group => [ $winstons_address, $julias_address ], + undef() => [ $users_address ] + ), + 'Brotherhood: "Winston Smith" , Julia ;, user@oceania', + 'test function format_email_groups() with addresses in two groups', + ); + + is( + format_email_groups( + $mime_group => [ $winstons_mime_address, $julias_mime_address ], + ), + '=?US-ASCII?Q?MIME?=: =?US-ASCII?Q?Winston?= Smith , =?US-ASCII?Q?Julia?= ;', + 'test function format_email_groups() that does not quote MIME encoded strings', + ); + + is( + format_email_groups("\x{2764} \x{2600}" => [ Email::Address::XS->new(phrase => "\x{2606} \x{2602}", user => "\x{263b} \x{265e}", host => "\x{262f}.\x{262d}", comment => "\x{2622} \x{20ac}") ]), + "\"\x{2764} \x{2600}\": \"\x{2606} \x{2602}\" <\"\x{263b} \x{265e}\"\@\x{262f}.\x{262d}> (\x{2622} \x{20ac});", + 'test function format_email_groups() that preserves unicode characters and UTF-8 status flag', + ); + + is( + format_email_groups("ASCII" => [], "L\x{e1}tin1" => []), + "ASCII:;, L\x{e1}tin1:;", + 'test function format_email_groups() that correctly compose Latin1 string from ASCII and Latin1 parts', + ); + + is( + format_email_groups("ASCII" => [ Email::Address::XS->new(user => "L\x{e1}tin1", host => "L\x{e1}tin1") ]), + "ASCII: L\x{e1}tin1\@L\x{e1}tin1;", + 'test function format_email_groups() that correctly compose Latin1 string from Latin1 parts', + ); + + is( + format_email_groups("ASCII" => [ Email::Address::XS->new(user => "L\x{e1}tin1", host => "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}") ]), + "ASCII: L\x{e1}tin1\@\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404};", + 'test function format_email_groups() that correctly compose UNICODE string from ASCII, Latin1 and UNICODE parts', + ); + + is( + format_email_groups( + $minitrue_group => [ $winstons_address, $julias_address ], + $thoughtpolice_group => [ $obriens_address, $charringtons_address ], + undef() => [ $users_address, $user2s_address ], + $undisclosed_group => [], + undef() => [ $user3s_address ], + $brotherhood_group => [ $goldsteins_address ], + $users_group => [ $user4s_address ], + ), + '"Ministry of \\"Truth\\"": "Winston Smith" , Julia ;, "Thought Police": O\'Brien , "Mr. Charrington" <"charrington\\"@\\"shop"@thought.police.oceania>;, user@oceania, "Escape \" also , characters" , undisclosed-recipients:;, user3@oceania, Brotherhood: "Emmanuel Goldstein" ;, "users@oceania": "user5@oceania\\" , \\"" ;', + 'test function format_email_groups() with different type of addresses in more groups', + ); + +} + +######################### + +{ + tie my $str1, 'TieScalarCounter', 'str1'; + tie my $str2, 'TieScalarCounter', 'str2'; + tie my $str3, 'TieScalarCounter', 'str3'; + tie my $str4, 'TieScalarCounter', 'str4'; + tie my $str5, 'TieScalarCounter', undef; + my $list1 = [ Email::Address::XS->new(), Email::Address::XS->new() ]; + my $list2 = [ Email::Address::XS->new(), Email::Address::XS->new() ]; + my $list3 = [ Email::Address::XS->new() ]; + my $list4 = [ Email::Address::XS->new() ]; + tie $list1->[0]->{user}, 'TieScalarCounter', 'ASCII'; + tie $list1->[0]->{host}, 'TieScalarCounter', 'ASCII'; + tie $list1->[0]->{phrase}, 'TieScalarCounter', 'ASCII'; + tie $list1->[0]->{comment}, 'TieScalarCounter', 'ASCII'; + tie $list1->[1]->{user}, 'TieScalarCounter', 'ASCII'; + tie $list1->[1]->{host}, 'TieScalarCounter', "L\x{e1}tin1"; + tie $list1->[1]->{phrase}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; + tie $list1->[1]->{comment}, 'TieScalarCounter', 'ASCII'; + tie $list2->[0]->{user}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; + tie $list2->[0]->{host}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; + tie $list2->[0]->{phrase}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; + tie $list2->[0]->{comment}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; + tie $list2->[1]->{user}, 'TieScalarCounter', "L\x{e1}tin1"; + tie $list2->[1]->{host}, 'TieScalarCounter', "L\x{e1}tin1"; + tie $list2->[1]->{phrase}, 'TieScalarCounter', "L\x{e1}tin1"; + tie $list2->[1]->{comment}, 'TieScalarCounter', "L\x{e1}tin1"; + tie $list3->[0]->{user}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; + tie $list3->[0]->{host}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; + tie $list3->[0]->{phrase}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; + tie $list3->[0]->{comment}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; + tie $list4->[0]->{user}, 'TieScalarCounter', "L\x{e1}tin1"; + tie $list4->[0]->{host}, 'TieScalarCounter', "L\x{e1}tin1"; + tie $list4->[0]->{phrase}, 'TieScalarCounter', "L\x{e1}tin1"; + tie $list4->[0]->{comment}, 'TieScalarCounter', "L\x{e1}tin1"; + is( + format_email_groups($str1 => $list1, $str2 => $list2), + "str1: ASCII (ASCII), \x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404} (ASCII);, str2: \x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404} <\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}\@\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}> (\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}), L\x{e1}tin1 (L\x{e1}tin1);", + 'test function format_email_groups() with magic scalars in ASCII, Latin1 and UNICODE', + ); + is( + format_email_groups($str3 => $list3), + "str3: \x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404} <\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}\@\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}> (\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404});", + 'test function format_email_groups() with magic scalars in UNICODE', + ); + is( + format_email_groups($str4 => $list4), + "str4: L\x{e1}tin1 (L\x{e1}tin1);", + 'test function format_email_groups() with magic scalars in Latin1', + ); + is( + format_email_groups($str5 => []), + '', + 'test function format_email_groups() with magic scalar which is undef', + ); + is(tied($str1)->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); + is(tied($str2)->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); + is(tied($str3)->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); + is(tied($str4)->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); + is(tied($str1)->{store}, 0, 'test function format_email_groups() that did not call SET magic'); + is(tied($str2)->{store}, 0, 'test function format_email_groups() that did not call SET magic'); + is(tied($str3)->{store}, 0, 'test function format_email_groups() that did not call SET magic'); + is(tied($str4)->{store}, 0, 'test function format_email_groups() that did not call SET magic'); + is(tied($str5)->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); + is(tied($str5)->{store}, 0, 'test function format_email_groups() that did not call SET magic'); + foreach ( @{$list1}, @{$list2}, @{$list3}, @{$list4} ) { + is(tied($_->{user})->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); + is(tied($_->{host})->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); + is(tied($_->{phrase})->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); + is(tied($_->{comment})->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); + is(tied($_->{user})->{store}, 0, 'test function format_email_groups() that did not call SET magic'); + is(tied($_->{host})->{store}, 0, 'test function format_email_groups() that did not call SET magic'); + is(tied($_->{phrase})->{store}, 0, 'test function format_email_groups() that did not call SET magic'); + is(tied($_->{comment})->{store}, 0, 'test function format_email_groups() that did not call SET magic'); + } +} + +######################### + +{ + + is_deeply( + [ with_warning { parse_email_groups(undef) } ], + [], + 'test function parse_email_groups() with undef argument', + ); + + is_deeply( + [ parse_email_groups('') ], + [], + 'test function parse_email_groups() on empty string', + ); + + is_deeply( + [ parse_email_groups('incorrect') ], + [ + undef() => [ + Email::Address::XS->new(phrase => 'incorrect'), + ], + ], + 'test function parse_email_groups() on incorrect string', + ); + + is_deeply( + [ parse_email_groups('winston.smith@recdep.minitrue', 'Email::Address::XS::Derived') ], + [ + undef() => [ + bless({ phrase => undef, user => 'winston.smith', host => 'recdep.minitrue', comment => undef }, 'Email::Address::XS::Derived'), + ], + ], + 'test function parse_email_groups() with second derived class name argument', + ); + + is_deeply( + [ with_warning { parse_email_groups('winston.smith@recdep.minitrue', 'Email::Address::XS::NotDerived') } ], + [], + 'test function parse_email_groups() with second not derived class name argument', + ); + + is_deeply( + [ parse_email_groups('=?US-ASCII?Q?MIME=3A=3B?= : =?US-ASCII?Q?Winston=3A_Smith?= , =?US-ASCII?Q?Julia=3A=3B_?= ;') ], + [ + '=?US-ASCII?Q?MIME=3A=3B?=' => [ + Email::Address::XS->new(phrase => '=?US-ASCII?Q?Winston=3A_Smith?=', address => 'winston.smith@recdep.minitrue'), + Email::Address::XS->new(phrase => '=?US-ASCII?Q?Julia=3A=3B_?=', address => 'julia@ficdep.minitrue'), + ], + ], + 'test function parse_email_groups() on MIME string with encoded colons and semicolons', + ); + + is_deeply( + [ parse_email_groups("\"\x{2764} \x{2600}\": \"\x{2606} \x{2602}\" <\"\x{263b} \x{265e}\"\@\x{262f}.\x{262d}> (\x{2622} \x{20ac});") ], + [ "\x{2764} \x{2600}" => [ Email::Address::XS->new(phrase => "\x{2606} \x{2602}", user => "\x{263b} \x{265e}", host => "\x{262f}.\x{262d}", comment => "\x{2622} \x{20ac}") ] ], + 'test function parse_email_groups() that preserve unicode characters and UTF-8 status flag', + ); + + is_deeply( + [ parse_email_groups('"Ministry of \\"Truth\\"": "Winston Smith" ( , (Julia _ (Unknown)) , ) , (leading comment) Julia ;, "Thought Police" (group name comment) : O\'Brien , Mr. (c)Charrington <(mr.)"charrington\\"@\\"shop"@thought.police.oceania> (junk shop);, user@oceania (unknown_display_name in comment), "Escape \" also , characters" , undisclosed-recipients:;, user3@oceania (nested (comment)), Brotherhood(s):"Emmanuel Goldstein"; , "users@oceania" : "user5@oceania\\" , \\"" ;, "":;' ) ], + [ + 'Ministry of "Truth"' => [ + Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'), + Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'), + ], + 'Thought Police' => [ + Email::Address::XS->new(phrase => "O'Brien", user => "o'brien", host => 'thought.police.oceania'), + Email::Address::XS->new(phrase => 'Mr. Charrington', user => 'charrington"@"shop', host => 'thought.police.oceania', comment => 'junk shop'), + ], + undef() => [ + Email::Address::XS->new(address => 'user@oceania', comment => 'unknown_display_name in comment'), + Email::Address::XS->new(phrase => 'Escape " also , characters', address => 'user2@oceania'), + ], + 'undisclosed-recipients' => [], + undef() => [ + Email::Address::XS->new(address => 'user3@oceania', comment => 'nested (comment)'), + ], + Brotherhood => [ + Email::Address::XS->new(phrase => 'Emmanuel Goldstein', address => 'goldstein@brotherhood.oceania'), + ], + 'users@oceania' => [ + Email::Address::XS->new(phrase => 'user5@oceania" , "', address => 'user4@oceania'), + ], + "" => [], + ], + 'test function parse_email_groups() on string with nested comments and quoted characters', + ); + +} + +######################### + +{ + is_deeply( + [ parse_email_groups("\"string1\\\x00string2\"") ], + [ undef() => [ Email::Address::XS->new(phrase => "string1\x00string2") ] ], + 'test function parse_email_groups() on string with nul character', + ); + is_deeply( + [ parse_email_groups("\"\\\x00string1\\\x00string2\"") ], + [ undef() => [ Email::Address::XS->new(phrase => "\x00string1\x00string2") ] ], + 'test function parse_email_groups() on string which begins with nul character', + ); + is_deeply( + [ parse_email_groups("\"string1\\\x00string2\\\x00\"") ], + [ undef() => [ Email::Address::XS->new(phrase => "string1\x00string2\x00") ] ], + 'test function parse_email_groups() on string which ends with nul character', + ); + is_deeply( + [ parse_email_groups(qq("\\\t" <"\\\t"\@host>)) ], + [ undef() => [ Email::Address::XS->new(phrase => "\t", user => "\t", host => 'host') ] ], + 'test function parse_email_groups() on string with TAB characters', + ); + is( + format_email_groups(undef() => [ Email::Address::XS->new(phrase => "string1\x00string2", user => 'user', host => 'host') ]), + "\"string1\\\x00string2\" ", + 'test function format_email_groups() with nul character in phrase', + ); + is( + format_email_groups(undef() => [ Email::Address::XS->new(phrase => "\x00string1\x00string2\x00", user => 'user', host => 'host') ]), + "\"\\\x00string1\\\x00string2\\\x00\" ", + 'test function format_email_groups() with nul character in phrase', + ); + is( + format_email_groups(undef() => [ Email::Address::XS->new(user => "string1\x00string2", host => 'host') ]), + "\"string1\\\x00string2\"\@host", + 'test function format_email_groups() with nul character in user part of address', + ); + is( + format_email_groups(undef() => [ Email::Address::XS->new(user => "\x00string1\x00string2\x00", host => 'host') ]), + "\"\\\x00string1\\\x00string2\\\x00\"\@host", + 'test function format_email_groups() with nul character in user part of address', + ); + is( + with_warning { format_email_groups(undef() => [ Email::Address::XS->new(user => 'user', host => "string1\x00string2") ]) }, + '', + 'test function format_email_groups() with nul character in host part of address', + ); + is( + with_warning { format_email_groups(undef() => [ Email::Address::XS->new(user => 'user', host => "\x00string1\x00string2\x00") ]) }, + '', + 'test function format_email_groups() with nul character in host part of address', + ); + is( + format_email_groups(undef() => [ Email::Address::XS->new(user => 'user', host => 'host', comment => "string1\\\x00string2") ]), + "user\@host (string1\\\x00string2)", + 'test function format_email_groups() with nul character in comment', + ); + is( + format_email_groups(undef() => [ Email::Address::XS->new(user => 'user', host => 'host', comment => "\\\x00string1\\\x00string2\\\x00") ]), + "user\@host (\\\x00string1\\\x00string2\\\x00)", + 'test function format_email_groups() with nul character in comment', + ); + is( + format_email_groups(undef() => [ Email::Address::XS->new(user => qq("\\\x00\t\n\r), host => 'host') ]), + qq("\\"\\\\\\\x00\\\t\\\n\\\r"\@host), + 'test function format_email_groups() with lot of non-qtext characters in user part of address' + ); +} + +######################### + +{ + tie my $input, 'TieScalarCounter', 'winston.smith@recdep.minitrue'; + is_deeply( + [ parse_email_groups($input) ], + [ + undef() => [ + bless({ phrase => undef, user => 'winston.smith', host => 'recdep.minitrue', comment => undef }, 'Email::Address::XS::Derived'), + ], + ], + 'test function parse_email_groups() with magic scalar', + ); + is(tied($input)->{fetch}, 1, 'test function parse_email_groups() that called GET magic exacly once'); + is(tied($input)->{store}, 0, 'test function parse_email_groups() that did not call SET magic'); +} + +######################### + +{ + + my $undef = undef; + my $str = 'str'; + my $str_ref = \$str; + my $address = Email::Address::XS->new(); + my $address_ref = \$address; + my $derived = Email::Address::XS::Derived->new(); + my $not_derived = Email::Address::XS::NotDerived->new(); + + ok(!Email::Address::XS->is_obj(undef), 'test method is_obj() on undef'); + ok(!Email::Address::XS->is_obj('string'), 'test method is_obj() on string'); + ok(!Email::Address::XS->is_obj($undef), 'test method is_obj() on undef variable'); + ok(!Email::Address::XS->is_obj($str), 'test method is_obj() on string variable'); + ok(!Email::Address::XS->is_obj($str_ref), 'test method is_obj() on string reference'); + ok(Email::Address::XS->is_obj($address), 'test method is_obj() on Email::Address::XS object'); + ok(!Email::Address::XS->is_obj($address_ref), 'test method is_obj() on reference of Email::Address::XS object'); + ok(Email::Address::XS->is_obj($derived), 'test method is_obj() on Email::Address::XS derived object'); + ok(!Email::Address::XS->is_obj($not_derived), 'test method is_obj() on Email::Address::XS not derived object'); + +} + +######################### + +package Email::Address::XS::Derived; + +use base 'Email::Address::XS'; + +sub user { + my ($self, @args) = @_; + $args[0] .= "_derived_suffix" if @args and defined $args[0]; + return $self->SUPER::user(@args); +} + +package Email::Address::XS::NotDerived; + +sub new { + return bless {}; +} + +sub user { + return 'not_derived'; +} + +######################### + +package TieScalarCounter; + +sub TIESCALAR { + my ($class, $value) = @_; + return bless { fetch => 0, store => 0, value => $value }, $class; +} + +sub FETCH { + my ($self) = @_; + $self->{fetch}++; + return $self->{value}; +} + +sub STORE { + my ($self, $value) = @_; + $self->{store}++; + $self->{value} = $value; +} diff --git a/t/taint-Email-Address-XS.t b/t/taint-Email-Address-XS.t new file mode 100755 index 0000000..b70f03a --- /dev/null +++ b/t/taint-Email-Address-XS.t @@ -0,0 +1,194 @@ +#!/usr/bin/perl -T +# Copyright (c) 2015-2017 by Pali + +######################### + +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" (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" (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" (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" (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" (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" (Records Department)', $subtest); +} + +undef $address; + +$address = Email::Address::XS->parse('"Winston Smith" (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" (Records Department)', $subtest); + test_not_tainted($address->original(), '"Winston Smith" (Records Department)', $subtest); +} + +undef $address; + +$address = Email::Address::XS->parse(taint('"Winston Smith" (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" (Records Department)', $subtest); + test_tainted($address->original(), '"Winston Smith" (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); +}