Import Upstream version 1.05
This commit is contained in:
su-fang
commit
ea95dfa58a
|
|
@ -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
|
||||
|
||||
|
|
@ -0,0 +1,779 @@
|
|||
/* Copyright (c) 2015-2018 by Pali <pali@cpan.org> */
|
||||
|
||||
#define PERL_NO_GET_CONTEXT
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
|
||||
#include "dovecot-parser.h"
|
||||
|
||||
/* Perl pre 5.6.1 support */
|
||||
#if PERL_VERSION < 6 || (PERL_VERSION == 6 && PERL_SUBVERSION < 1)
|
||||
#define BROKEN_SvPVutf8
|
||||
#endif
|
||||
|
||||
/* Perl pre 5.7.2 support */
|
||||
#ifndef SvPV_nomg
|
||||
#define WITHOUT_SvPV_nomg
|
||||
#endif
|
||||
|
||||
/* Perl pre 5.8.0 support */
|
||||
#ifndef UTF8_IS_INVARIANT
|
||||
#define UTF8_IS_INVARIANT(c) (((U8)c) < 0x80)
|
||||
#endif
|
||||
|
||||
/* Perl pre 5.9.5 support */
|
||||
#ifndef SVfARG
|
||||
#define SVfARG(p) ((void*)(p))
|
||||
#endif
|
||||
|
||||
/* Perl pre 5.13.1 support */
|
||||
#ifndef warn_sv
|
||||
#define warn_sv(scalar) warn("%" SVf, SVfARG(scalar))
|
||||
#endif
|
||||
#ifndef croak_sv
|
||||
#define croak_sv(scalar) croak("%" SVf, SVfARG(scalar))
|
||||
#endif
|
||||
|
||||
/* Perl pre 5.15.4 support */
|
||||
#ifndef sv_derived_from_pvn
|
||||
#define sv_derived_from_pvn(scalar, name, len, flags) sv_derived_from(scalar, name)
|
||||
#endif
|
||||
|
||||
/* Exported i_panic function for other C files */
|
||||
void i_panic(const char *format, ...)
|
||||
{
|
||||
dTHX;
|
||||
va_list args;
|
||||
|
||||
va_start(args, format);
|
||||
vcroak(format, &args);
|
||||
va_end(args);
|
||||
}
|
||||
|
||||
static void append_carp_shortmess(pTHX_ SV *scalar)
|
||||
{
|
||||
dSP;
|
||||
int count;
|
||||
|
||||
ENTER;
|
||||
SAVETMPS;
|
||||
PUSHMARK(SP);
|
||||
|
||||
count = call_pv("Carp::shortmess", G_SCALAR);
|
||||
|
||||
SPAGAIN;
|
||||
|
||||
if (count > 0)
|
||||
sv_catsv(scalar, POPs);
|
||||
|
||||
PUTBACK;
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
}
|
||||
|
||||
#define CARP_WARN false
|
||||
#define CARP_DIE true
|
||||
static void carp(bool fatal, const char *format, ...)
|
||||
{
|
||||
dTHX;
|
||||
va_list args;
|
||||
SV *scalar;
|
||||
|
||||
va_start(args, format);
|
||||
scalar = sv_2mortal(vnewSVpvf(format, &args));
|
||||
va_end(args);
|
||||
|
||||
append_carp_shortmess(aTHX_ scalar);
|
||||
|
||||
if (!fatal)
|
||||
warn_sv(scalar);
|
||||
else
|
||||
croak_sv(scalar);
|
||||
}
|
||||
|
||||
static bool string_needs_utf8_upgrade(const char *str, STRLEN len)
|
||||
{
|
||||
STRLEN i;
|
||||
|
||||
for (i = 0; i < len; ++i)
|
||||
if (!UTF8_IS_INVARIANT(str[i]))
|
||||
return true;
|
||||
|
||||
return false;
|
||||
}
|
||||
|
||||
static const char *get_perl_scalar_value(pTHX_ SV *scalar, STRLEN *len, bool utf8, bool nomg)
|
||||
{
|
||||
const char *string;
|
||||
|
||||
#ifndef WITHOUT_SvPV_nomg
|
||||
if (!nomg)
|
||||
SvGETMAGIC(scalar);
|
||||
|
||||
if (!SvOK(scalar))
|
||||
return NULL;
|
||||
|
||||
string = SvPV_nomg(scalar, *len);
|
||||
#else
|
||||
COP cop;
|
||||
|
||||
if (!SvGMAGICAL(scalar) && !SvOK(scalar))
|
||||
return NULL;
|
||||
|
||||
/* Temporary turn off all warnings because SvPV can throw uninitialized warning */
|
||||
cop = *PL_curcop;
|
||||
cop.cop_warnings = pWARN_NONE;
|
||||
|
||||
ENTER;
|
||||
SAVEVPTR(PL_curcop);
|
||||
PL_curcop = &cop;
|
||||
|
||||
string = SvPV(scalar, *len);
|
||||
|
||||
LEAVE;
|
||||
|
||||
if (SvGMAGICAL(scalar) && !SvOK(scalar))
|
||||
return NULL;
|
||||
#endif
|
||||
|
||||
if (utf8 && !SvUTF8(scalar) && string_needs_utf8_upgrade(string, *len)) {
|
||||
scalar = sv_2mortal(newSVpvn(string, *len));
|
||||
#ifdef BROKEN_SvPVutf8
|
||||
sv_utf8_upgrade(scalar);
|
||||
*len = SvCUR(scalar);
|
||||
return SvPVX(scalar);
|
||||
#else
|
||||
return SvPVutf8(scalar, *len);
|
||||
#endif
|
||||
}
|
||||
|
||||
return string;
|
||||
}
|
||||
|
||||
static const char *get_perl_scalar_string_value(pTHX_ SV *scalar, STRLEN *len, const char *name, bool utf8)
|
||||
{
|
||||
const char *string;
|
||||
|
||||
string = get_perl_scalar_value(aTHX_ scalar, len, utf8, false);
|
||||
if (!string) {
|
||||
carp(CARP_WARN, "Use of uninitialized value for %s", name);
|
||||
*len = 0;
|
||||
return "";
|
||||
}
|
||||
|
||||
return string;
|
||||
}
|
||||
|
||||
static SV *get_perl_hash_scalar(pTHX_ HV *hash, const char *key)
|
||||
{
|
||||
I32 klen;
|
||||
SV **scalar_ptr;
|
||||
|
||||
klen = strlen(key);
|
||||
|
||||
if (!hv_exists(hash, key, klen))
|
||||
return NULL;
|
||||
|
||||
scalar_ptr = hv_fetch(hash, key, klen, 0);
|
||||
if (!scalar_ptr)
|
||||
return NULL;
|
||||
|
||||
return *scalar_ptr;
|
||||
}
|
||||
|
||||
static const char *get_perl_hash_value(pTHX_ HV *hash, const char *key, STRLEN *len, bool utf8, bool *taint)
|
||||
{
|
||||
SV *scalar;
|
||||
|
||||
scalar = get_perl_hash_scalar(aTHX_ hash, key);
|
||||
if (!scalar)
|
||||
return NULL;
|
||||
|
||||
if (!*taint && SvTAINTED(scalar))
|
||||
*taint = true;
|
||||
|
||||
return get_perl_scalar_value(aTHX_ scalar, len, utf8, true);
|
||||
}
|
||||
|
||||
static void set_perl_hash_value(pTHX_ HV *hash, const char *key, const char *value, STRLEN len, bool utf8, bool taint)
|
||||
{
|
||||
I32 klen;
|
||||
SV *scalar;
|
||||
|
||||
klen = strlen(key);
|
||||
|
||||
if (!len && value && value[0])
|
||||
value = NULL;
|
||||
|
||||
if (value)
|
||||
scalar = newSVpvn(value, len);
|
||||
else
|
||||
scalar = newSV(0);
|
||||
|
||||
if (utf8 && value)
|
||||
sv_utf8_decode(scalar);
|
||||
|
||||
if (taint)
|
||||
SvTAINTED_on(scalar);
|
||||
|
||||
(void)hv_store(hash, key, klen, scalar, 0);
|
||||
}
|
||||
|
||||
static HV *get_perl_class_from_perl_cv(pTHX_ CV *cv)
|
||||
{
|
||||
GV *gv;
|
||||
HV *class;
|
||||
|
||||
class = NULL;
|
||||
gv = CvGV(cv);
|
||||
|
||||
if (gv)
|
||||
class = GvSTASH(gv);
|
||||
|
||||
if (!class)
|
||||
class = CvSTASH(cv);
|
||||
|
||||
if (!class)
|
||||
class = PL_curstash;
|
||||
|
||||
if (!class)
|
||||
carp(CARP_DIE, "Cannot retrieve class");
|
||||
|
||||
return class;
|
||||
}
|
||||
|
||||
static HV *get_perl_class_from_perl_scalar(pTHX_ SV *scalar)
|
||||
{
|
||||
HV *class;
|
||||
STRLEN class_len;
|
||||
const char *class_name;
|
||||
|
||||
class_name = get_perl_scalar_string_value(aTHX_ scalar, &class_len, "class", true);
|
||||
|
||||
if (class_len == 0) {
|
||||
carp(CARP_WARN, "Explicit blessing to '' (assuming package main)");
|
||||
class_name = "main";
|
||||
class_len = strlen(class_name);
|
||||
}
|
||||
|
||||
class = gv_stashpvn(class_name, class_len, GV_ADD | SVf_UTF8);
|
||||
if (!class)
|
||||
carp(CARP_DIE, "Cannot retrieve class %" SVf, SVfARG(scalar));
|
||||
|
||||
return class;
|
||||
}
|
||||
|
||||
static HV *get_perl_class_from_perl_scalar_or_cv(pTHX_ SV *scalar, CV *cv)
|
||||
{
|
||||
if (scalar)
|
||||
return get_perl_class_from_perl_scalar(aTHX_ scalar);
|
||||
else
|
||||
return get_perl_class_from_perl_cv(aTHX_ cv);
|
||||
}
|
||||
|
||||
static bool is_class_object(pTHX_ SV *class, const char *class_name, STRLEN class_len, SV *object)
|
||||
{
|
||||
dSP;
|
||||
SV *sv;
|
||||
bool ret;
|
||||
int count;
|
||||
|
||||
if (!sv_isobject(object))
|
||||
return false;
|
||||
|
||||
ENTER;
|
||||
SAVETMPS;
|
||||
|
||||
PUSHMARK(SP);
|
||||
EXTEND(SP, 2);
|
||||
|
||||
if (class) {
|
||||
sv = newSVsv(class);
|
||||
} else {
|
||||
sv = newSVpvn(class_name, class_len);
|
||||
SvUTF8_on(sv);
|
||||
}
|
||||
|
||||
PUSHs(sv_2mortal(newSVsv(object)));
|
||||
PUSHs(sv_2mortal(sv));
|
||||
|
||||
PUTBACK;
|
||||
|
||||
count = call_method("isa", G_SCALAR);
|
||||
|
||||
SPAGAIN;
|
||||
|
||||
if (count > 0) {
|
||||
sv = POPs;
|
||||
ret = SvTRUE(sv);
|
||||
} else {
|
||||
ret = false;
|
||||
}
|
||||
|
||||
PUTBACK;
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
static void fill_element_message(char *buffer, size_t len, I32 index1, I32 index2)
|
||||
{
|
||||
static const char message[] = "Element at index ";
|
||||
|
||||
if (len < 10 || buffer[0])
|
||||
return;
|
||||
|
||||
if (len+10+1+10 < sizeof(message)) {
|
||||
buffer[0] = 0;
|
||||
return;
|
||||
}
|
||||
|
||||
if (index2 == -1) {
|
||||
strcpy(buffer, "Argument");
|
||||
return;
|
||||
}
|
||||
|
||||
memcpy(buffer, message, sizeof(message));
|
||||
|
||||
if (index1 == -1)
|
||||
sprintf(buffer+sizeof(message)-1, "%d", (int)index2);
|
||||
else
|
||||
sprintf(buffer+sizeof(message)-1, "%d/%d", (int)index1, (int)index2);
|
||||
}
|
||||
|
||||
static HV* get_object_hash_from_perl_array(pTHX_ AV *array, I32 index1, I32 index2, const char *class_name, STRLEN class_len, bool warn)
|
||||
{
|
||||
SV *scalar;
|
||||
SV *object;
|
||||
SV **object_ptr;
|
||||
char buffer[40] = { 0 };
|
||||
|
||||
#ifdef WITHOUT_SvPV_nomg
|
||||
warn = true;
|
||||
#endif
|
||||
|
||||
object_ptr = av_fetch(array, (index2 == -1 ? 0 : index2), 0);
|
||||
if (!object_ptr) {
|
||||
if (warn) {
|
||||
fill_element_message(buffer, sizeof(buffer), index1, index2);
|
||||
carp(CARP_WARN, "%s is NULL", buffer);
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
object = *object_ptr;
|
||||
if (!is_class_object(aTHX_ NULL, class_name, class_len, object)) {
|
||||
if (warn) {
|
||||
fill_element_message(buffer, sizeof(buffer), index1, index2);
|
||||
carp(CARP_WARN, "%s is not %s object", buffer, class_name);
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
scalar = SvRV(object);
|
||||
if (SvTYPE(scalar) != SVt_PVHV) {
|
||||
if (warn) {
|
||||
fill_element_message(buffer, sizeof(buffer), index1, index2);
|
||||
carp(CARP_WARN, "%s is not HASH reference", buffer);
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
return (HV *)scalar;
|
||||
|
||||
}
|
||||
|
||||
static void message_address_add_from_perl_array(pTHX_ struct message_address **first_address, struct message_address **last_address, bool utf8, bool *taint, AV *array, I32 index1, I32 index2, const char *class_name, STRLEN class_len)
|
||||
{
|
||||
HV *hash;
|
||||
const char *name;
|
||||
const char *mailbox;
|
||||
const char *domain;
|
||||
const char *comment;
|
||||
STRLEN name_len;
|
||||
STRLEN mailbox_len;
|
||||
STRLEN domain_len;
|
||||
STRLEN comment_len;
|
||||
char buffer[40] = { 0 };
|
||||
|
||||
hash = get_object_hash_from_perl_array(aTHX_ array, index1, index2, class_name, class_len, false);
|
||||
if (!hash)
|
||||
return;
|
||||
|
||||
name = get_perl_hash_value(aTHX_ hash, "phrase", &name_len, utf8, taint);
|
||||
mailbox = get_perl_hash_value(aTHX_ hash, "user", &mailbox_len, utf8, taint);
|
||||
domain = get_perl_hash_value(aTHX_ hash, "host", &domain_len, utf8, taint);
|
||||
comment = get_perl_hash_value(aTHX_ hash, "comment", &comment_len, utf8, taint);
|
||||
|
||||
if (domain && !domain[0] && domain_len == 0)
|
||||
domain = NULL;
|
||||
|
||||
if (!mailbox && !domain) {
|
||||
fill_element_message(buffer, sizeof(buffer), index1, index2);
|
||||
carp(CARP_WARN, "%s contains empty address", buffer);
|
||||
return;
|
||||
}
|
||||
|
||||
if (!mailbox) {
|
||||
fill_element_message(buffer, sizeof(buffer), index1, index2);
|
||||
carp(CARP_WARN, "%s contains empty user portion of address", buffer);
|
||||
return;
|
||||
}
|
||||
|
||||
if (!domain) {
|
||||
fill_element_message(buffer, sizeof(buffer), index1, index2);
|
||||
carp(CARP_WARN, "%s contains empty host portion of address", buffer);
|
||||
return;
|
||||
}
|
||||
|
||||
message_address_add(first_address, last_address, name, name_len, NULL, 0, mailbox, mailbox_len, domain, domain_len, comment, comment_len);
|
||||
}
|
||||
|
||||
static AV *get_perl_array_from_scalar(SV *scalar, const char *group_name, bool warn)
|
||||
{
|
||||
SV *scalar_ref;
|
||||
|
||||
#ifdef WITHOUT_SvPV_nomg
|
||||
warn = true;
|
||||
#endif
|
||||
|
||||
if (scalar && !SvROK(scalar)) {
|
||||
if (warn)
|
||||
carp(CARP_WARN, "Value for group '%s' is not reference", group_name);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
scalar_ref = SvRV(scalar);
|
||||
|
||||
if (!scalar_ref || SvTYPE(scalar_ref) != SVt_PVAV) {
|
||||
if (warn)
|
||||
carp(CARP_WARN, "Value for group '%s' is not ARRAY reference", group_name);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
return (AV *)scalar_ref;
|
||||
}
|
||||
|
||||
static void message_address_add_from_perl_group(pTHX_ struct message_address **first_address, struct message_address **last_address, bool utf8, bool *taint, SV *scalar_group, SV *scalar_list, I32 index1, const char *class_name, STRLEN class_len)
|
||||
{
|
||||
I32 len;
|
||||
I32 index2;
|
||||
AV *array;
|
||||
STRLEN group_len;
|
||||
const char *group_name;
|
||||
|
||||
group_name = get_perl_scalar_value(aTHX_ scalar_group, &group_len, utf8, true);
|
||||
array = get_perl_array_from_scalar(scalar_list, group_name, false);
|
||||
len = array ? (av_len(array) + 1) : 0;
|
||||
|
||||
if (index1 == -1 && group_name)
|
||||
index1 = 0;
|
||||
|
||||
if (group_name)
|
||||
message_address_add(first_address, last_address, NULL, 0, NULL, 0, group_name, group_len, NULL, 0, NULL, 0);
|
||||
|
||||
for (index2 = 0; index2 < len; ++index2)
|
||||
message_address_add_from_perl_array(aTHX_ first_address, last_address, utf8, taint, array, index1, ((index1 == -1 && len == 1) ? -1 : index2), class_name, class_len);
|
||||
|
||||
if (group_name)
|
||||
message_address_add(first_address, last_address, NULL, 0, NULL, 0, NULL, 0, NULL, 0, NULL, 0);
|
||||
|
||||
if (!*taint && SvTAINTED(scalar_group))
|
||||
*taint = true;
|
||||
}
|
||||
|
||||
#ifndef WITHOUT_SvPV_nomg
|
||||
static bool perl_group_needs_utf8(pTHX_ SV *scalar_group, SV *scalar_list, I32 index1, const char *class_name, STRLEN class_len)
|
||||
{
|
||||
I32 len;
|
||||
I32 index2;
|
||||
SV *scalar;
|
||||
HV *hash;
|
||||
AV *array;
|
||||
STRLEN len_na;
|
||||
bool utf8;
|
||||
const char *group_name;
|
||||
const char **hash_key_ptr;
|
||||
|
||||
static const char *hash_keys[] = { "phrase", "user", "host", "comment", NULL };
|
||||
|
||||
utf8 = false;
|
||||
|
||||
group_name = get_perl_scalar_value(aTHX_ scalar_group, &len_na, false, false);
|
||||
if (SvUTF8(scalar_group))
|
||||
utf8 = true;
|
||||
|
||||
if (index1 == -1 && group_name)
|
||||
index1 = 0;
|
||||
|
||||
array = get_perl_array_from_scalar(scalar_list, group_name, true);
|
||||
len = array ? (av_len(array) + 1) : 0;
|
||||
|
||||
for (index2 = 0; index2 < len; ++index2) {
|
||||
hash = get_object_hash_from_perl_array(aTHX_ array, index1, ((index1 == -1 && len == 1) ? -1 : index2), class_name, class_len, true);
|
||||
if (!hash)
|
||||
continue;
|
||||
for (hash_key_ptr = hash_keys; *hash_key_ptr; ++hash_key_ptr) {
|
||||
scalar = get_perl_hash_scalar(aTHX_ hash, *hash_key_ptr);
|
||||
if (scalar && get_perl_scalar_value(aTHX_ scalar, &len_na, false, false) && SvUTF8(scalar))
|
||||
utf8 = true;
|
||||
}
|
||||
}
|
||||
|
||||
return utf8;
|
||||
}
|
||||
#endif
|
||||
|
||||
static int count_address_groups(struct message_address *first_address)
|
||||
{
|
||||
int count;
|
||||
bool in_group;
|
||||
struct message_address *address;
|
||||
|
||||
count = 0;
|
||||
in_group = false;
|
||||
|
||||
for (address = first_address; address; address = address->next) {
|
||||
if (!address->domain)
|
||||
in_group = !in_group;
|
||||
if (in_group)
|
||||
continue;
|
||||
++count;
|
||||
}
|
||||
|
||||
return count;
|
||||
}
|
||||
|
||||
static bool get_next_perl_address_group(pTHX_ struct message_address **address, SV **group_scalar, SV **addresses_scalar, HV *class, bool utf8, bool taint)
|
||||
{
|
||||
HV *hash;
|
||||
SV *object;
|
||||
SV *hash_ref;
|
||||
bool in_group;
|
||||
AV *addresses_array;
|
||||
|
||||
if (!*address)
|
||||
return false;
|
||||
|
||||
in_group = !(*address)->domain;
|
||||
|
||||
if (in_group && (*address)->mailbox)
|
||||
*group_scalar = sv_2mortal(newSVpvn((*address)->mailbox, (*address)->mailbox_len));
|
||||
else
|
||||
*group_scalar = sv_newmortal();
|
||||
|
||||
if (utf8 && in_group && (*address)->mailbox)
|
||||
sv_utf8_decode(*group_scalar);
|
||||
|
||||
if (taint)
|
||||
SvTAINTED_on(*group_scalar);
|
||||
|
||||
addresses_array = newAV();
|
||||
*addresses_scalar = sv_2mortal(newRV_noinc((SV *)addresses_array));
|
||||
|
||||
if (in_group)
|
||||
*address = (*address)->next;
|
||||
|
||||
while (*address && (*address)->domain) {
|
||||
hash = newHV();
|
||||
|
||||
set_perl_hash_value(aTHX_ hash, "phrase", (*address)->name, (*address)->name_len, utf8, taint);
|
||||
set_perl_hash_value(aTHX_ hash, "user", ( (*address)->mailbox && (*address)->mailbox[0] ) ? (*address)->mailbox : NULL, (*address)->mailbox_len, utf8, taint);
|
||||
set_perl_hash_value(aTHX_ hash, "host", ( (*address)->domain && (*address)->domain[0] ) ? (*address)->domain : NULL, (*address)->domain_len, utf8, taint);
|
||||
set_perl_hash_value(aTHX_ hash, "comment", (*address)->comment, (*address)->comment_len, utf8, taint);
|
||||
set_perl_hash_value(aTHX_ hash, "original", (*address)->original, (*address)->original_len, utf8, taint);
|
||||
|
||||
if ((*address)->invalid_syntax)
|
||||
(void)hv_store(hash, "invalid", sizeof("invalid")-1, newSViv(1), 0);
|
||||
|
||||
hash_ref = newRV_noinc((SV *)hash);
|
||||
object = sv_bless(hash_ref, class);
|
||||
|
||||
av_push(addresses_array, object);
|
||||
|
||||
*address = (*address)->next;
|
||||
}
|
||||
|
||||
if (in_group && *address)
|
||||
*address = (*address)->next;
|
||||
|
||||
return true;
|
||||
}
|
||||
|
||||
|
||||
MODULE = Email::Address::XS PACKAGE = Email::Address::XS
|
||||
|
||||
PROTOTYPES: DISABLE
|
||||
|
||||
void
|
||||
format_email_groups(...)
|
||||
PREINIT:
|
||||
I32 i;
|
||||
bool utf8;
|
||||
bool taint;
|
||||
char *string;
|
||||
size_t string_len;
|
||||
struct message_address *first_address;
|
||||
struct message_address *last_address;
|
||||
SV *string_scalar;
|
||||
INPUT:
|
||||
const char *this_class_name = "$Package";
|
||||
STRLEN this_class_len = sizeof("$Package")-1;
|
||||
INIT:
|
||||
if (items % 2 == 1) {
|
||||
carp(CARP_WARN, "Odd number of elements in argument list");
|
||||
XSRETURN_UNDEF;
|
||||
}
|
||||
PPCODE:
|
||||
first_address = NULL;
|
||||
last_address = NULL;
|
||||
taint = false;
|
||||
#ifndef WITHOUT_SvPV_nomg
|
||||
utf8 = false;
|
||||
for (i = 0; i < items; i += 2)
|
||||
if (perl_group_needs_utf8(aTHX_ ST(i), ST(i+1), (items == 2 ? -1 : i), this_class_name, this_class_len))
|
||||
utf8 = true;
|
||||
#else
|
||||
utf8 = true;
|
||||
#endif
|
||||
for (i = 0; i < items; i += 2)
|
||||
message_address_add_from_perl_group(aTHX_ &first_address, &last_address, utf8, &taint, ST(i), ST(i+1), (items == 2 ? -1 : i), this_class_name, this_class_len);
|
||||
message_address_write(&string, &string_len, first_address);
|
||||
message_address_free(&first_address);
|
||||
string_scalar = sv_2mortal(newSVpvn(string, string_len));
|
||||
string_free(string);
|
||||
if (utf8)
|
||||
sv_utf8_decode(string_scalar);
|
||||
if (taint)
|
||||
SvTAINTED_on(string_scalar);
|
||||
EXTEND(SP, 1);
|
||||
PUSHs(string_scalar);
|
||||
|
||||
void
|
||||
parse_email_groups(...)
|
||||
PREINIT:
|
||||
SV *string_scalar;
|
||||
SV *class_scalar;
|
||||
int count;
|
||||
HV *hv_class;
|
||||
SV *group_scalar;
|
||||
SV *addresses_scalar;
|
||||
bool utf8;
|
||||
bool taint;
|
||||
STRLEN input_len;
|
||||
const char *input;
|
||||
struct message_address *address;
|
||||
struct message_address *first_address;
|
||||
INPUT:
|
||||
const char *this_class_name = "$Package";
|
||||
STRLEN this_class_len = sizeof("$Package")-1;
|
||||
INIT:
|
||||
string_scalar = items >= 1 ? ST(0) : &PL_sv_undef;
|
||||
class_scalar = items >= 2 ? ST(1) : NULL;
|
||||
input = get_perl_scalar_string_value(aTHX_ string_scalar, &input_len, "string", false);
|
||||
utf8 = SvUTF8(string_scalar);
|
||||
taint = SvTAINTED(string_scalar);
|
||||
hv_class = get_perl_class_from_perl_scalar_or_cv(aTHX_ class_scalar, cv);
|
||||
if (class_scalar && !sv_derived_from_pvn(class_scalar, this_class_name, this_class_len, SVf_UTF8)) {
|
||||
carp(CARP_WARN, "Class %" SVf " is not derived from %s", SVfARG(class_scalar), this_class_name);
|
||||
XSRETURN_EMPTY;
|
||||
}
|
||||
PPCODE:
|
||||
first_address = message_address_parse(input, input_len, UINT_MAX, MESSAGE_ADDRESS_PARSE_FLAG_NON_STRICT_DOTS_AS_INVALID);
|
||||
count = count_address_groups(first_address);
|
||||
EXTEND(SP, count * 2);
|
||||
address = first_address;
|
||||
while (get_next_perl_address_group(aTHX_ &address, &group_scalar, &addresses_scalar, hv_class, utf8, taint)) {
|
||||
PUSHs(group_scalar);
|
||||
PUSHs(addresses_scalar);
|
||||
}
|
||||
message_address_free(&first_address);
|
||||
|
||||
void
|
||||
compose_address(...)
|
||||
PREINIT:
|
||||
char *string;
|
||||
const char *mailbox;
|
||||
const char *domain;
|
||||
size_t string_len;
|
||||
STRLEN mailbox_len;
|
||||
STRLEN domain_len;
|
||||
bool mailbox_utf8;
|
||||
bool domain_utf8;
|
||||
bool utf8;
|
||||
bool taint;
|
||||
SV *mailbox_scalar;
|
||||
SV *domain_scalar;
|
||||
SV *string_scalar;
|
||||
INIT:
|
||||
mailbox_scalar = items >= 1 ? ST(0) : &PL_sv_undef;
|
||||
domain_scalar = items >= 2 ? ST(1) : &PL_sv_undef;
|
||||
mailbox = get_perl_scalar_string_value(aTHX_ mailbox_scalar, &mailbox_len, "mailbox", false);
|
||||
domain = get_perl_scalar_string_value(aTHX_ domain_scalar, &domain_len, "domain", false);
|
||||
mailbox_utf8 = SvUTF8(mailbox_scalar);
|
||||
domain_utf8 = SvUTF8(domain_scalar);
|
||||
utf8 = (mailbox_utf8 || domain_utf8);
|
||||
if (utf8 && !mailbox_utf8)
|
||||
mailbox = get_perl_scalar_value(aTHX_ mailbox_scalar, &mailbox_len, true, true);
|
||||
if (utf8 && !domain_utf8)
|
||||
domain = get_perl_scalar_value(aTHX_ domain_scalar, &domain_len, true, true);
|
||||
taint = (SvTAINTED(mailbox_scalar) || SvTAINTED(domain_scalar));
|
||||
PPCODE:
|
||||
compose_address(&string, &string_len, mailbox, mailbox_len, domain, domain_len);
|
||||
string_scalar = sv_2mortal(newSVpvn(string, string_len));
|
||||
string_free(string);
|
||||
if (utf8)
|
||||
sv_utf8_decode(string_scalar);
|
||||
if (taint)
|
||||
SvTAINTED_on(string_scalar);
|
||||
EXTEND(SP, 1);
|
||||
PUSHs(string_scalar);
|
||||
|
||||
void
|
||||
split_address(...)
|
||||
PREINIT:
|
||||
const char *string;
|
||||
char *mailbox;
|
||||
char *domain;
|
||||
STRLEN string_len;
|
||||
size_t mailbox_len;
|
||||
size_t domain_len;
|
||||
bool utf8;
|
||||
bool taint;
|
||||
SV *string_scalar;
|
||||
SV *mailbox_scalar;
|
||||
SV *domain_scalar;
|
||||
INIT:
|
||||
string_scalar = items >= 1 ? ST(0) : &PL_sv_undef;
|
||||
string = get_perl_scalar_string_value(aTHX_ string_scalar, &string_len, "string", false);
|
||||
utf8 = SvUTF8(string_scalar);
|
||||
taint = SvTAINTED(string_scalar);
|
||||
PPCODE:
|
||||
split_address(string, string_len, &mailbox, &mailbox_len, &domain, &domain_len);
|
||||
mailbox_scalar = mailbox ? sv_2mortal(newSVpvn(mailbox, mailbox_len)) : sv_newmortal();
|
||||
domain_scalar = domain ? sv_2mortal(newSVpvn(domain, domain_len)) : sv_newmortal();
|
||||
string_free(mailbox);
|
||||
string_free(domain);
|
||||
if (utf8) {
|
||||
sv_utf8_decode(mailbox_scalar);
|
||||
sv_utf8_decode(domain_scalar);
|
||||
}
|
||||
if (taint) {
|
||||
SvTAINTED_on(mailbox_scalar);
|
||||
SvTAINTED_on(domain_scalar);
|
||||
}
|
||||
EXTEND(SP, 2);
|
||||
PUSHs(mailbox_scalar);
|
||||
PUSHs(domain_scalar);
|
||||
|
||||
bool
|
||||
is_obj(...)
|
||||
PREINIT:
|
||||
SV *class = items >= 1 ? ST(0) : &PL_sv_undef;
|
||||
SV *object = items >= 2 ? ST(1) : &PL_sv_undef;
|
||||
CODE:
|
||||
RETVAL = is_class_object(aTHX_ class, NULL, 0, object);
|
||||
OUTPUT:
|
||||
RETVAL
|
||||
|
|
@ -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)
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
{
|
||||
"abstract" : "Parse and format RFC 5322 email addresses and groups",
|
||||
"author" : [
|
||||
"Pali <pali@cpan.org>"
|
||||
],
|
||||
"dynamic_config" : 0,
|
||||
"generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010",
|
||||
"license" : [
|
||||
"perl_5"
|
||||
],
|
||||
"meta-spec" : {
|
||||
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
|
||||
"version" : 2
|
||||
},
|
||||
"name" : "Email-Address-XS",
|
||||
"no_index" : {
|
||||
"directory" : [
|
||||
"t",
|
||||
"inc"
|
||||
]
|
||||
},
|
||||
"prereqs" : {
|
||||
"build" : {
|
||||
"requires" : {
|
||||
"ExtUtils::MakeMaker" : "0"
|
||||
}
|
||||
},
|
||||
"configure" : {
|
||||
"requires" : {
|
||||
"ExtUtils::MakeMaker" : "0"
|
||||
}
|
||||
},
|
||||
"runtime" : {
|
||||
"requires" : {
|
||||
"Carp" : "0",
|
||||
"Exporter" : "0",
|
||||
"XSLoader" : "0",
|
||||
"base" : "0",
|
||||
"overload" : "0",
|
||||
"perl" : "5.006000",
|
||||
"strict" : "0",
|
||||
"warnings" : "0"
|
||||
}
|
||||
},
|
||||
"test" : {
|
||||
"requires" : {
|
||||
"Test::More" : "0"
|
||||
}
|
||||
}
|
||||
},
|
||||
"release_status" : "stable",
|
||||
"resources" : {
|
||||
"bugtracker" : {
|
||||
"web" : "https://github.com/pali/Email-Address-XS/issues"
|
||||
},
|
||||
"repository" : {
|
||||
"type" : "git",
|
||||
"url" : "git://github.com/pali/Email-Address-XS.git",
|
||||
"web" : "https://github.com/pali/Email-Address-XS"
|
||||
}
|
||||
},
|
||||
"version" : "1.05",
|
||||
"x_serialization_backend" : "JSON::PP version 2.97001"
|
||||
}
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
---
|
||||
abstract: 'Parse and format RFC 5322 email addresses and groups'
|
||||
author:
|
||||
- 'Pali <pali@cpan.org>'
|
||||
build_requires:
|
||||
ExtUtils::MakeMaker: '0'
|
||||
Test::More: '0'
|
||||
configure_requires:
|
||||
ExtUtils::MakeMaker: '0'
|
||||
dynamic_config: 0
|
||||
generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010'
|
||||
license: perl
|
||||
meta-spec:
|
||||
url: http://module-build.sourceforge.net/META-spec-v1.4.html
|
||||
version: '1.4'
|
||||
name: Email-Address-XS
|
||||
no_index:
|
||||
directory:
|
||||
- t
|
||||
- inc
|
||||
requires:
|
||||
Carp: '0'
|
||||
Exporter: '0'
|
||||
XSLoader: '0'
|
||||
base: '0'
|
||||
overload: '0'
|
||||
perl: '5.006000'
|
||||
strict: '0'
|
||||
warnings: '0'
|
||||
resources:
|
||||
bugtracker: https://github.com/pali/Email-Address-XS/issues
|
||||
repository: git://github.com/pali/Email-Address-XS.git
|
||||
version: '1.05'
|
||||
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
#!/usr/bin/perl
|
||||
use ExtUtils::MakeMaker;
|
||||
WriteMakefile(
|
||||
NAME => 'Email::Address::XS',
|
||||
VERSION_FROM => 'lib/Email/Address/XS.pm',
|
||||
ABSTRACT_FROM => 'lib/Email/Address/XS.pm',
|
||||
AUTHOR => 'Pali <pali@cpan.org>',
|
||||
H => [ 'dovecot-parser.h' ],
|
||||
C => [ 'dovecot-parser.c', 'Email-Address-XS.c' ],
|
||||
XS => { 'Email-Address-XS.xs' => 'Email-Address-XS.c' },
|
||||
OBJECT => '$(O_FILES)',
|
||||
NORECURS => 1,
|
||||
LICENSE => 'perl_5',
|
||||
MIN_PERL_VERSION => '5.6.0',
|
||||
|
||||
PREREQ_PM => {
|
||||
'base' => '0',
|
||||
'overload' => '0',
|
||||
'strict' => '0',
|
||||
'warnings' => '0',
|
||||
'Carp' => '0',
|
||||
'Exporter' => '0',
|
||||
'XSLoader' => '0',
|
||||
},
|
||||
TEST_REQUIRES => {
|
||||
'Test::More' => '0',
|
||||
},
|
||||
eval { ExtUtils::MakeMaker->VERSION('6.68') } ? (
|
||||
META_MERGE => {
|
||||
'meta-spec' => {
|
||||
version => 2,
|
||||
},
|
||||
'resources' => {
|
||||
bugtracker => {
|
||||
web => 'https://github.com/pali/Email-Address-XS/issues',
|
||||
},
|
||||
repository => {
|
||||
url => 'git://github.com/pali/Email-Address-XS.git',
|
||||
web => 'https://github.com/pali/Email-Address-XS',
|
||||
type => 'git',
|
||||
},
|
||||
},
|
||||
'dynamic_config' => 0,
|
||||
},
|
||||
) : (),
|
||||
);
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
Email-Address-XS
|
||||
================
|
||||
|
||||
This module implements RFC 5322 parser and formatter of email addresses
|
||||
and groups. It parses an input string from email headers which contain
|
||||
a list of email addresses or a groups of email addresses (like From,
|
||||
To, Cc, Bcc, Reply-To, Sender, ...). Also it can generate a string
|
||||
value for those headers from a list of email addresses objects.
|
||||
Module is backward compatible with RFC 2822 and RFC 822.
|
||||
|
||||
Parser and formatter functionality is implemented in XS and uses
|
||||
shared code from Dovecot IMAP server.
|
||||
|
||||
It is a drop-in replacement for the Email::Address module which has
|
||||
several security issues. E.g. issue CVE-2015-7686 (Algorithmic
|
||||
complexity vulnerability) which allows remote attackers to cause
|
||||
denial of service, is still present in Email::Address version 1.908.
|
||||
|
||||
Email::Address::XS module was created to finally fix CVE-2015-7686.
|
||||
|
||||
Existing applications that use Email::Address module could be easily
|
||||
switched to Email::Address::XS module. In most cases only changing
|
||||
'use Email::Address' to 'use Email::Address::XS' and replacing every
|
||||
'Email::Address' occurrence with 'Email::Address::XS' is sufficient.
|
||||
|
||||
So unlike Email::Address, this module does not use regular expressions
|
||||
for parsing but instead native XS implementation parses input string
|
||||
sequentially according to RFC 5322 grammar.
|
||||
|
||||
Additionally it has support also for named groups and so can be use
|
||||
instead of the Email::Address::List module.
|
||||
|
||||
INSTALLATION
|
||||
|
||||
To install this module type the following:
|
||||
|
||||
perl Makefile.PL
|
||||
make
|
||||
make test
|
||||
make install
|
||||
|
||||
DEPENDENCIES
|
||||
|
||||
None
|
||||
|
||||
COPYRIGHT AND LICENCE
|
||||
|
||||
Copyright (C) 2015-2018 by Pali <pali@cpan.org>
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself, either Perl version 5.6.0 or,
|
||||
at your option, any later version of Perl 5 you may have available.
|
||||
|
||||
Dovecot parser is licensed under The MIT License and copyrighted by
|
||||
Dovecot authors.
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,64 @@
|
|||
#ifndef DOVECOT_PARSER_H
|
||||
#define DOVECOT_PARSER_H
|
||||
|
||||
#include <stdbool.h>
|
||||
|
||||
enum message_address_parse_flags {
|
||||
/* If enabled, missing mailbox and domain are set to MISSING_MAILBOX
|
||||
and MISSING_DOMAIN strings. Otherwise they're set to "". */
|
||||
MESSAGE_ADDRESS_PARSE_FLAG_FILL_MISSING = (1 << 0),
|
||||
/* Require local-part to strictly adhere to RFC5322 when parsing dots.
|
||||
For example ".user", "us..ser" and "user." will be invalid. This
|
||||
isn't enabled by default, because these kind of invalid addresses
|
||||
are commonly used in Japan. */
|
||||
MESSAGE_ADDRESS_PARSE_FLAG_STRICT_DOTS = (1 << 1),
|
||||
/* Same as MESSAGE_ADDRESS_PARSE_FLAG_STRICT_DOTS, but accept also
|
||||
non-strict input. Flag invalid_syntax will be set to true. */
|
||||
MESSAGE_ADDRESS_PARSE_FLAG_NON_STRICT_DOTS_AS_INVALID = (1 << 2),
|
||||
};
|
||||
|
||||
/* group: ... ; will be stored like:
|
||||
{name = NULL, NULL, "group", NULL}, ..., {NULL, NULL, NULL, NULL}
|
||||
*/
|
||||
struct message_address {
|
||||
struct message_address *next;
|
||||
|
||||
/* display-name */
|
||||
char *name;
|
||||
size_t name_len;
|
||||
/* route string contains the @ prefix */
|
||||
char *route;
|
||||
size_t route_len;
|
||||
/* local-part */
|
||||
char *mailbox;
|
||||
size_t mailbox_len;
|
||||
char *domain;
|
||||
size_t domain_len;
|
||||
char *comment;
|
||||
size_t comment_len;
|
||||
char *original;
|
||||
size_t original_len;
|
||||
/* there were errors when parsing this address */
|
||||
bool invalid_syntax;
|
||||
};
|
||||
|
||||
/* Parse message addresses from given data. Note that giving an empty string
|
||||
will return NULL since there are no addresses. */
|
||||
struct message_address *
|
||||
message_address_parse(const char *str, size_t len, unsigned int max_addresses, enum message_address_parse_flags flags);
|
||||
|
||||
void message_address_add(struct message_address **first, struct message_address **last,
|
||||
const char *name, size_t name_len, const char *route, size_t route_len,
|
||||
const char *mailbox, size_t mailbox_len, const char *domain, size_t domain_len,
|
||||
const char *comment, size_t comment_len);
|
||||
|
||||
void message_address_free(struct message_address **addr);
|
||||
|
||||
void message_address_write(char **str, size_t *len, const struct message_address *addr);
|
||||
|
||||
void compose_address(char **output, size_t *output_len, const char *mailbox, size_t mailbox_len, const char *domain, size_t domain_len);
|
||||
void split_address(const char *input, size_t input_len, char **mailbox, size_t *mailbox_len, char **domain, size_t *domain_len);
|
||||
|
||||
void string_free(char *string);
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,680 @@
|
|||
# Copyright (c) 2015-2018 by Pali <pali@cpan.org>
|
||||
|
||||
package Email::Address::XS;
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.05';
|
||||
|
||||
use Carp;
|
||||
|
||||
use base 'Exporter';
|
||||
our @EXPORT_OK = qw(parse_email_addresses parse_email_groups format_email_addresses format_email_groups compose_address split_address);
|
||||
|
||||
use XSLoader;
|
||||
XSLoader::load(__PACKAGE__, $VERSION);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Email::Address::XS - Parse and format RFC 5322 email addresses and groups
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Email::Address::XS;
|
||||
|
||||
my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', user => 'winston.smith', host => 'recdep.minitrue', comment => 'Records Department');
|
||||
print $winstons_address->address();
|
||||
# winston.smith@recdep.minitrue
|
||||
|
||||
my $julias_address = Email::Address::XS->new('Julia', 'julia@ficdep.minitrue');
|
||||
print $julias_address->format();
|
||||
# Julia <julia@ficdep.minitrue>
|
||||
|
||||
my $users_address = Email::Address::XS->parse('user <user@oceania>');
|
||||
print $users_address->host();
|
||||
# oceania
|
||||
|
||||
my $goldsteins_address = Email::Address::XS->parse_bare_address('goldstein@brotherhood.oceania');
|
||||
print $goldsteins_address->user();
|
||||
# goldstein
|
||||
|
||||
my @addresses = Email::Address::XS->parse('"Winston Smith" <winston.smith@recdep.minitrue> (Records Department), Julia <julia@ficdep.minitrue>');
|
||||
# ($winstons_address, $julias_address)
|
||||
|
||||
|
||||
use Email::Address::XS qw(format_email_addresses format_email_groups parse_email_addresses parse_email_groups);
|
||||
|
||||
my $addresses_string = format_email_addresses($winstons_address, $julias_address, $users_address);
|
||||
# "Winston Smith" <winston.smith@recdep.minitrue> (Records Department), Julia <julia@ficdep.minitrue>, user <user@oceania>
|
||||
|
||||
my @addresses = map { $_->address() } parse_email_addresses($addresses_string);
|
||||
# ('winston.smith@recdep.minitrue', 'julia@ficdep.minitrue', 'user@oceania')
|
||||
|
||||
my $groups_string = format_email_groups('Brotherhood' => [ $winstons_address, $julias_address ], undef() => [ $users_address ]);
|
||||
# Brotherhood: "Winston Smith" <winston.smith@recdep.minitrue> (Records Department), Julia <julia@ficdep.minitrue>;, user <user@oceania>
|
||||
|
||||
my @groups = parse_email_groups($groups_string);
|
||||
# ('Brotherhood' => [ $winstons_address, $julias_address ], undef() => [ $users_address ])
|
||||
|
||||
|
||||
use Email::Address::XS qw(compose_address split_address);
|
||||
|
||||
my ($user, $host) = split_address('julia(outer party)@ficdep.minitrue');
|
||||
# ('julia', 'ficdep.minitrue')
|
||||
|
||||
my $string = compose_address('charrington"@"shop', 'thought.police.oceania');
|
||||
# "charrington\"@\"shop"@thought.police.oceania
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module implements L<RFC 5322|https://tools.ietf.org/html/rfc5322>
|
||||
parser and formatter of email addresses and groups. It parses an input
|
||||
string from email headers which contain a list of email addresses or
|
||||
a groups of email addresses (like From, To, Cc, Bcc, Reply-To, Sender,
|
||||
...). Also it can generate a string value for those headers from a
|
||||
list of email addresses objects. Module is backward compatible with
|
||||
L<RFC 2822|https://tools.ietf.org/html/rfc2822> and
|
||||
L<RFC 822|https://tools.ietf.org/html/rfc822>.
|
||||
|
||||
Parser and formatter functionality is implemented in XS and uses
|
||||
shared code from Dovecot IMAP server.
|
||||
|
||||
It is a drop-in replacement for L<the Email::Address module|Email::Address>
|
||||
which has several security issues. E.g. issue L<CVE-2015-7686 (Algorithmic complexity vulnerability)|https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2015-7686>,
|
||||
which allows remote attackers to cause denial of service, is still
|
||||
present in L<Email::Address|Email::Address> version 1.908.
|
||||
|
||||
Email::Address::XS module was created to finally fix CVE-2015-7686.
|
||||
|
||||
Existing applications that use Email::Address module could be easily
|
||||
switched to Email::Address::XS module. In most cases only changing
|
||||
C<use Email::Address> to C<use Email::Address::XS> and replacing every
|
||||
C<Email::Address> occurrence with C<Email::Address::XS> is sufficient.
|
||||
|
||||
So unlike L<Email::Address|Email::Address>, this module does not use
|
||||
regular expressions for parsing but instead native XS implementation
|
||||
parses input string sequentially according to RFC 5322 grammar.
|
||||
|
||||
Additionally it has support also for named groups and so can be use
|
||||
instead of L<the Email::Address::List module|Email::Address::List>.
|
||||
|
||||
If you are looking for the module which provides object representation
|
||||
for the list of email addresses suitable for the MIME email headers,
|
||||
see L<Email::MIME::Header::AddressList|Email::MIME::Header::AddressList>.
|
||||
|
||||
=head2 EXPORT
|
||||
|
||||
None by default. Exportable functions are:
|
||||
L<C<parse_email_addresses>|/parse_email_addresses>,
|
||||
L<C<parse_email_groups>|/parse_email_groups>,
|
||||
L<C<format_email_addresses>|/format_email_addresses>,
|
||||
L<C<format_email_groups>|/format_email_groups>,
|
||||
L<C<compose_address>|/compose_address>,
|
||||
L<C<split_address>|/split_address>.
|
||||
|
||||
=head2 Exportable Functions
|
||||
|
||||
=over 4
|
||||
|
||||
=item format_email_addresses
|
||||
|
||||
use Email::Address::XS qw(format_email_addresses);
|
||||
|
||||
my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston@recdep.minitrue');
|
||||
my $julias_address = Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue');
|
||||
my @addresses = ($winstons_address, $julias_address);
|
||||
my $string = format_email_addresses(@addresses);
|
||||
print $string;
|
||||
# "Winston Smith" <winston@recdep.minitrue>, Julia <julia@ficdep.minitrue>
|
||||
|
||||
Takes a list of email address objects and returns one formatted string
|
||||
of those email addresses.
|
||||
|
||||
=cut
|
||||
|
||||
sub format_email_addresses {
|
||||
my (@args) = @_;
|
||||
return format_email_groups(undef, \@args);
|
||||
}
|
||||
|
||||
=item format_email_groups
|
||||
|
||||
use Email::Address::XS qw(format_email_groups);
|
||||
|
||||
my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', user => 'winston.smith', host => 'recdep.minitrue');
|
||||
my $julias_address = Email::Address::XS->new('Julia', 'julia@ficdep.minitrue');
|
||||
my $users_address = Email::Address::XS->new(address => 'user@oceania');
|
||||
|
||||
my $groups_string = format_email_groups('Brotherhood' => [ $winstons_address, $julias_address ], undef() => [ $users_address ]);
|
||||
print $groups_string;
|
||||
# Brotherhood: "Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>;, user@oceania
|
||||
|
||||
my $undisclosed_string = format_email_groups('undisclosed-recipients' => []);
|
||||
print $undisclosed_string;
|
||||
# undisclosed-recipients:;
|
||||
|
||||
Like L<C<format_email_addresses>|/format_email_addresses> but this
|
||||
method takes pairs which consist of a group display name and a
|
||||
reference to address list. If a group is not undef then address
|
||||
list is formatted inside named group.
|
||||
|
||||
=item parse_email_addresses
|
||||
|
||||
use Email::Address::XS qw(parse_email_addresses);
|
||||
|
||||
my $string = '"Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>, user@oceania';
|
||||
my @addresses = parse_email_addresses($string);
|
||||
# @addresses now contains three Email::Address::XS objects, one for each address
|
||||
|
||||
Parses an input string and returns a list of Email::Address::XS
|
||||
objects. Optional second string argument specifies class name for
|
||||
blessing new objects.
|
||||
|
||||
=cut
|
||||
|
||||
sub parse_email_addresses {
|
||||
my (@args) = @_;
|
||||
my $t = 1;
|
||||
return map { @{$_} } grep { $t ^= 1 } parse_email_groups(@args);
|
||||
}
|
||||
|
||||
=item parse_email_groups
|
||||
|
||||
use Email::Address::XS qw(parse_email_groups);
|
||||
|
||||
my $string = 'Brotherhood: "Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>;, user@oceania, undisclosed-recipients:;';
|
||||
my @groups = parse_email_groups($string);
|
||||
# @groups now contains list ('Brotherhood' => [ $winstons_object, $julias_object ], undef() => [ $users_object ], 'undisclosed-recipients' => [])
|
||||
|
||||
Like L<C<parse_email_addresses>|/parse_email_addresses> but this
|
||||
function returns a list of pairs: a group display name and a
|
||||
reference to a list of addresses which belongs to that named group.
|
||||
An undef value for a group means that a following list of addresses
|
||||
is not inside any named group. An output is in a same format as a
|
||||
input for the function L<C<format_email_groups>|/format_email_groups>.
|
||||
This function preserves order of groups and does not do any
|
||||
de-duplication or merging.
|
||||
|
||||
=item compose_address
|
||||
|
||||
use Email::Address::XS qw(compose_address);
|
||||
my $string_address = compose_address($user, $host);
|
||||
|
||||
Takes an unescaped user part and unescaped host part of an address
|
||||
and returns escaped address.
|
||||
|
||||
Available since version 1.01.
|
||||
|
||||
=item split_address
|
||||
|
||||
use Email::Address::XS qw(split_address);
|
||||
my ($user, $host) = split_address($string_address);
|
||||
|
||||
Takes an escaped address and split it into pair of unescaped user
|
||||
part and unescaped host part of address. If splitting input address
|
||||
into these two parts is not possible then this function returns
|
||||
pair of undefs.
|
||||
|
||||
Available since version 1.01.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Class Methods
|
||||
|
||||
=over 4
|
||||
|
||||
=item new
|
||||
|
||||
my $empty_address = Email::Address::XS->new();
|
||||
my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', user => 'winston.smith', host => 'recdep.minitrue', comment => 'Records Department');
|
||||
my $julias_address = Email::Address::XS->new('Julia', 'julia@ficdep.minitrue');
|
||||
my $users_address = Email::Address::XS->new(address => 'user@oceania');
|
||||
my $only_name = Email::Address::XS->new(phrase => 'Name');
|
||||
my $copy_of_winstons_address = Email::Address::XS->new(copy => $winstons_address);
|
||||
|
||||
Constructs and returns a new C<Email::Address::XS> object. Takes named
|
||||
list of arguments: phrase, address, user, host, comment and copy.
|
||||
An argument address takes precedence over user and host.
|
||||
|
||||
When an argument copy is specified then it is expected an
|
||||
Email::Address::XS object and a cloned copy of that object is
|
||||
returned. All other parameters are ignored.
|
||||
|
||||
Old syntax L<from the Email::Address module|Email::Address/new> is
|
||||
supported too. Takes one to four positional arguments: phrase, address
|
||||
comment, and original string. Passing an argument original is
|
||||
deprecated, ignored and throws a warning.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class, @args) = @_;
|
||||
|
||||
my %hash_keys = (phrase => 1, address => 1, user => 1, host => 1, comment => 1, copy => 1);
|
||||
my $is_hash;
|
||||
if ( scalar @args == 2 and defined $args[0] ) {
|
||||
$is_hash = 1 if exists $hash_keys{$args[0]};
|
||||
} elsif ( scalar @args == 4 and defined $args[0] and defined $args[2] ) {
|
||||
$is_hash = 1 if exists $hash_keys{$args[0]} and exists $hash_keys{$args[2]};
|
||||
} elsif ( scalar @args > 4 ) {
|
||||
$is_hash = 1;
|
||||
}
|
||||
|
||||
my %args;
|
||||
if ( $is_hash ) {
|
||||
%args = @args;
|
||||
} else {
|
||||
carp 'Argument original is deprecated and ignored' if scalar @args > 3;
|
||||
$args{comment} = $args[2] if scalar @args > 2;
|
||||
$args{address} = $args[1] if scalar @args > 1;
|
||||
$args{phrase} = $args[0] if scalar @args > 0;
|
||||
}
|
||||
|
||||
my $invalid;
|
||||
my $original;
|
||||
if ( exists $args{copy} ) {
|
||||
if ( $class->is_obj($args{copy}) ) {
|
||||
$args{phrase} = $args{copy}->phrase();
|
||||
$args{comment} = $args{copy}->comment();
|
||||
$args{user} = $args{copy}->user();
|
||||
$args{host} = $args{copy}->host();
|
||||
$invalid = $args{copy}->{invalid};
|
||||
$original = $args{copy}->{original};
|
||||
delete $args{address};
|
||||
} else {
|
||||
carp 'Named argument copy does not contain a valid object';
|
||||
}
|
||||
}
|
||||
|
||||
my $self = bless {}, $class;
|
||||
|
||||
$self->phrase($args{phrase});
|
||||
$self->comment($args{comment});
|
||||
|
||||
if ( exists $args{address} ) {
|
||||
$self->address($args{address});
|
||||
} else {
|
||||
$self->user($args{user});
|
||||
$self->host($args{host});
|
||||
}
|
||||
|
||||
$self->{invalid} = 1 if $invalid;
|
||||
$self->{original} = $original;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item parse
|
||||
|
||||
my $winstons_address = Email::Address::XS->parse('"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)');
|
||||
my @users_addresses = Email::Address::XS->parse('user1@oceania, user2@oceania');
|
||||
|
||||
Parses an input string and returns a list of an Email::Address::XS
|
||||
objects. Same as the function L<C<parse_email_addresses>|/parse_email_addresses>
|
||||
but this one is class method.
|
||||
|
||||
In scalar context this function returns just first parsed object.
|
||||
If more then one object was parsed then L<C<is_valid>|/is_valid>
|
||||
method on returned object returns false. If no object was parsed
|
||||
then empty Email::Address::XS object is returned.
|
||||
|
||||
Prior to version 1.01 return value in scalar context is undef when
|
||||
no object was parsed.
|
||||
|
||||
=cut
|
||||
|
||||
sub parse {
|
||||
my ($class, $string) = @_;
|
||||
my @addresses = parse_email_addresses($string, $class);
|
||||
return @addresses if wantarray;
|
||||
my $self = @addresses ? $addresses[0] : Email::Address::XS->new();
|
||||
$self->{invalid} = 1 if scalar @addresses != 1;
|
||||
$self->{original} = $string unless defined $self->{original};
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item parse_bare_address
|
||||
|
||||
my $winstons_address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue');
|
||||
|
||||
Parses an input string as one bare email address (addr spec) which
|
||||
does not allow phrase part or angle brackets around email address and
|
||||
returns an Email::Address::XS object. It is just a wrapper around
|
||||
L<C<address>|/address> method. Method L<C<is_valid>|/is_valid> can be
|
||||
used to check if parsing was successful.
|
||||
|
||||
Available since version 1.01.
|
||||
|
||||
=cut
|
||||
|
||||
sub parse_bare_address {
|
||||
my ($class, $string) = @_;
|
||||
my $self = $class->new();
|
||||
if ( defined $string ) {
|
||||
$self->address($string);
|
||||
$self->{original} = $string;
|
||||
} else {
|
||||
carp 'Use of uninitialized value for string';
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head2 Object Methods
|
||||
|
||||
=over 4
|
||||
|
||||
=item format
|
||||
|
||||
my $string = $address->format();
|
||||
|
||||
Returns formatted Email::Address::XS object as a string. This method
|
||||
throws a warning when L<C<user>|/user> or L<C<host>|/host> part of
|
||||
the email address is invalid or empty string.
|
||||
|
||||
=cut
|
||||
|
||||
sub format {
|
||||
my ($self) = @_;
|
||||
return format_email_addresses($self);
|
||||
}
|
||||
|
||||
=item is_valid
|
||||
|
||||
my $is_valid = $address->is_valid();
|
||||
|
||||
Returns true if the parse function or method which created this
|
||||
Email::Address::XS object had not received any syntax error on input
|
||||
string and also that L<C<user>|/user> and L<C<host>|/host> part of
|
||||
the email address are not empty strings.
|
||||
|
||||
Thus this function can be used for checking if Email::Address::XS
|
||||
object is valid before calling L<C<format>|/format> method on it.
|
||||
|
||||
Available since version 1.01.
|
||||
|
||||
=cut
|
||||
|
||||
sub is_valid {
|
||||
my ($self) = @_;
|
||||
my $user = $self->user();
|
||||
my $host = $self->host();
|
||||
return (defined $user and defined $host and length $host and not $self->{invalid});
|
||||
}
|
||||
|
||||
=item phrase
|
||||
|
||||
my $phrase = $address->phrase();
|
||||
$address->phrase('Winston Smith');
|
||||
|
||||
Accessor and mutator for the phrase (display name).
|
||||
|
||||
=cut
|
||||
|
||||
sub phrase {
|
||||
my ($self, @args) = @_;
|
||||
return $self->{phrase} unless @args;
|
||||
delete $self->{invalid} if exists $self->{invalid};
|
||||
return $self->{phrase} = $args[0];
|
||||
}
|
||||
|
||||
=item user
|
||||
|
||||
my $user = $address->user();
|
||||
$address->user('winston.smith');
|
||||
|
||||
Accessor and mutator for the unescaped user (local/mailbox) part of
|
||||
an address.
|
||||
|
||||
=cut
|
||||
|
||||
sub user {
|
||||
my ($self, @args) = @_;
|
||||
return $self->{user} unless @args;
|
||||
delete $self->{cached_address} if exists $self->{cached_address};
|
||||
delete $self->{invalid} if exists $self->{invalid};
|
||||
return $self->{user} = $args[0];
|
||||
}
|
||||
|
||||
=item host
|
||||
|
||||
my $host = $address->host();
|
||||
$address->host('recdep.minitrue');
|
||||
|
||||
Accessor and mutator for the unescaped host (domain) part of an address.
|
||||
|
||||
Since version 1.03 this method checks if setting a new value is syntactically
|
||||
valid. If not undef is set and returned.
|
||||
|
||||
=cut
|
||||
|
||||
sub host {
|
||||
my ($self, @args) = @_;
|
||||
return $self->{host} unless @args;
|
||||
delete $self->{cached_address} if exists $self->{cached_address};
|
||||
delete $self->{invalid} if exists $self->{invalid};
|
||||
if (defined $args[0] and $args[0] =~ /^(?:\[.*\]|[^\x00-\x20\x7F()<>\[\]:;@\\,"]+)$/) {
|
||||
return $self->{host} = $args[0];
|
||||
} else {
|
||||
return $self->{host} = undef;
|
||||
}
|
||||
}
|
||||
|
||||
=item address
|
||||
|
||||
my $string_address = $address->address();
|
||||
$address->address('winston.smith@recdep.minitrue');
|
||||
|
||||
Accessor and mutator for the escaped address (addr spec).
|
||||
|
||||
Internally this module stores a user and a host part of an address
|
||||
separately. Function L<C<compose_address>|/compose_address> is used
|
||||
for composing full address and function L<C<split_address>|/split_address>
|
||||
for splitting into a user and a host parts. If splitting new address
|
||||
into these two parts is not possible then this method returns undef
|
||||
and sets both parts to undef.
|
||||
|
||||
=cut
|
||||
|
||||
sub address {
|
||||
my ($self, @args) = @_;
|
||||
my $user;
|
||||
my $host;
|
||||
if ( @args ) {
|
||||
delete $self->{invalid} if exists $self->{invalid};
|
||||
($user, $host) = split_address($args[0]) if defined $args[0];
|
||||
if ( not defined $user or not defined $host ) {
|
||||
$user = undef;
|
||||
$host = undef;
|
||||
}
|
||||
$self->{user} = $user;
|
||||
$self->{host} = $host;
|
||||
} else {
|
||||
return $self->{cached_address} if exists $self->{cached_address};
|
||||
$user = $self->user();
|
||||
$host = $self->host();
|
||||
}
|
||||
if ( defined $user and defined $host and length $host ) {
|
||||
return $self->{cached_address} = compose_address($user, $host);
|
||||
} else {
|
||||
return $self->{cached_address} = undef;
|
||||
}
|
||||
}
|
||||
|
||||
=item comment
|
||||
|
||||
my $comment = $address->comment();
|
||||
$address->comment('Records Department');
|
||||
|
||||
Accessor and mutator for the comment which is formatted after an
|
||||
address. A comment can contain another nested comments in round
|
||||
brackets. When setting new comment this method check if brackets are
|
||||
balanced. If not undef is set and returned.
|
||||
|
||||
=cut
|
||||
|
||||
sub comment {
|
||||
my ($self, @args) = @_;
|
||||
return $self->{comment} unless @args;
|
||||
delete $self->{invalid} if exists $self->{invalid};
|
||||
return $self->{comment} = undef unless defined $args[0];
|
||||
my $count = 0;
|
||||
my $cleaned = $args[0];
|
||||
$cleaned =~ s/(?:\\.|[^\(\)\x00])//g;
|
||||
foreach ( split //, $cleaned ) {
|
||||
$count++ if $_ eq '(';
|
||||
$count-- if $_ eq ')';
|
||||
$count = -1 if $_ eq "\x00";
|
||||
last if $count < 0;
|
||||
}
|
||||
return $self->{comment} = undef if $count != 0;
|
||||
return $self->{comment} = $args[0];
|
||||
}
|
||||
|
||||
=item name
|
||||
|
||||
my $name = $address->name();
|
||||
|
||||
This method tries to return a name which belongs to the address. It
|
||||
returns either L<C<phrase>|/phrase> or L<C<comment>|/comment> or
|
||||
L<C<user>|/user> part of the address or empty string (first defined
|
||||
value in this order). But it never returns undef.
|
||||
|
||||
=cut
|
||||
|
||||
sub name {
|
||||
my ($self) = @_;
|
||||
my $phrase = $self->phrase();
|
||||
return $phrase if defined $phrase and length $phrase;
|
||||
my $comment = $self->comment();
|
||||
return $comment if defined $comment and length $comment;
|
||||
my $user = $self->user();
|
||||
return $user if defined $user;
|
||||
return '';
|
||||
}
|
||||
|
||||
=item as_string
|
||||
|
||||
my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue');
|
||||
my $stringified = $address->as_string();
|
||||
|
||||
This method is used for object L<stringification|/stringify>. It
|
||||
returns string representation of object. By default object is
|
||||
stringified to L<C<format>|/format>.
|
||||
|
||||
Available since version 1.01.
|
||||
|
||||
=cut
|
||||
|
||||
our $STRINGIFY; # deprecated
|
||||
|
||||
sub as_string {
|
||||
my ($self) = @_;
|
||||
return $self->format() unless defined $STRINGIFY;
|
||||
carp 'Variable $Email::Address::XS::STRINGIFY is deprecated; subclass instead';
|
||||
my $method = $self->can($STRINGIFY);
|
||||
croak 'Stringify method ' . $STRINGIFY . ' does not exist' unless defined $method;
|
||||
return $method->($self);
|
||||
}
|
||||
|
||||
=item original
|
||||
|
||||
my $address = Email::Address::XS->parse('(Winston) "Smith" <winston.smith@recdep.minitrue> (Minitrue)');
|
||||
my $original = $address->original();
|
||||
# (Winston) "Smith" <winston.smith@recdep.minitrue> (Minitrue)
|
||||
my $format = $address->format();
|
||||
# Smith <winston.smith@recdep.minitrue> (Minitrue)
|
||||
|
||||
This method returns original part of the string which was used for
|
||||
parsing current Email::Address::XS object. If object was not created
|
||||
by parsing input string, then this method returns undef.
|
||||
|
||||
Note that L<C<format>|/format> method does not have to return same
|
||||
original string.
|
||||
|
||||
Available since version 1.01.
|
||||
|
||||
=cut
|
||||
|
||||
sub original {
|
||||
my ($self) = @_;
|
||||
return $self->{original};
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head2 Overloaded Operators
|
||||
|
||||
=over 4
|
||||
|
||||
=item stringify
|
||||
|
||||
my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue');
|
||||
print "Winston's address is $address.";
|
||||
# Winston's address is "Winston Smith" <winston.smith@recdep.minitrue>.
|
||||
|
||||
Stringification is done by method L<C<as_string>|/as_string>.
|
||||
|
||||
=cut
|
||||
|
||||
use overload '""' => \&as_string;
|
||||
|
||||
=back
|
||||
|
||||
=head2 Deprecated Functions and Variables
|
||||
|
||||
For compatibility with L<the Email::Address module|Email::Address>
|
||||
there are defined some deprecated functions and variables.
|
||||
Do not use them in new code. Their usage throws warnings.
|
||||
|
||||
Altering deprecated variable C<$Email::Address::XS::STRINGIFY> changes
|
||||
method which is called for objects stringification.
|
||||
|
||||
Deprecated cache functions C<purge_cache>, C<disable_cache> and
|
||||
C<enable_cache> are noop and do nothing.
|
||||
|
||||
=cut
|
||||
|
||||
sub purge_cache {
|
||||
carp 'Function purge_cache is deprecated and does nothing';
|
||||
}
|
||||
|
||||
sub disable_cache {
|
||||
carp 'Function disable_cache is deprecated and does nothing';
|
||||
}
|
||||
|
||||
sub enable_cache {
|
||||
carp 'Function enable_cache is deprecated and does nothing';
|
||||
}
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<RFC 822|https://tools.ietf.org/html/rfc822>,
|
||||
L<RFC 2822|https://tools.ietf.org/html/rfc2822>,
|
||||
L<RFC 5322|https://tools.ietf.org/html/rfc5322>,
|
||||
L<Email::MIME::Header::AddressList>,
|
||||
L<Email::Address>,
|
||||
L<Email::Address::List>,
|
||||
L<Email::AddressParser>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Pali E<lt>pali@cpan.orgE<gt>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (C) 2015-2018 by Pali E<lt>pali@cpan.orgE<gt>
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself, either Perl version 5.6.0 or,
|
||||
at your option, any later version of Perl 5 you may have available.
|
||||
|
||||
Dovecot parser is licensed under The MIT License and copyrighted by
|
||||
Dovecot authors.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,194 @@
|
|||
#!/usr/bin/perl -T
|
||||
# Copyright (c) 2015-2017 by Pali <pali@cpan.org>
|
||||
|
||||
#########################
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
local $SIG{__WARN__} = sub { fail('following test does not throw warning'); warn $_[0]; };
|
||||
|
||||
use Carp;
|
||||
$Carp::Internal{'Test::Builder'} = 1;
|
||||
$Carp::Internal{'Test::More'} = 1;
|
||||
|
||||
use Test::More tests => 137;
|
||||
use Test::Builder;
|
||||
|
||||
#########################
|
||||
|
||||
sub is_tainted {
|
||||
local $@; # Don't pollute caller's value.
|
||||
return ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 };
|
||||
}
|
||||
|
||||
sub test_tainted {
|
||||
my ($got, $expected, $subtest) = @_;
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
ok(is_tainted($got), $subtest);
|
||||
is($got, $expected, $subtest);
|
||||
}
|
||||
|
||||
sub test_not_tainted {
|
||||
my ($got, $expected, $subtest) = @_;
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
ok(!is_tainted($got), $subtest);
|
||||
is($got, $expected, $subtest);
|
||||
}
|
||||
|
||||
sub taint {
|
||||
my ($str) = @_;
|
||||
return substr($ENV{PATH}, 0, 0) . $str;
|
||||
}
|
||||
|
||||
#########################
|
||||
|
||||
BEGIN {
|
||||
use_ok('Email::Address::XS');
|
||||
};
|
||||
|
||||
#########################
|
||||
|
||||
my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue', comment => 'Records Department');
|
||||
|
||||
{
|
||||
my $subtest = 'no tainted arguments';
|
||||
test_not_tainted($address->phrase(), 'Winston Smith', $subtest);
|
||||
test_not_tainted($address->user(), 'winston.smith', $subtest);
|
||||
test_not_tainted($address->host(), 'recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->comment(), 'Records Department', $subtest);
|
||||
test_not_tainted($address->name(), 'Winston Smith', $subtest);
|
||||
test_not_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
|
||||
}
|
||||
|
||||
$address->phrase(taint('Winston Smith'));
|
||||
|
||||
{
|
||||
my $subtest = 'tainted phrase argument';
|
||||
test_tainted($address->phrase(), 'Winston Smith', $subtest);
|
||||
test_not_tainted($address->user(), 'winston.smith', $subtest);
|
||||
test_not_tainted($address->host(), 'recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->comment(), 'Records Department', $subtest);
|
||||
test_tainted($address->name(), 'Winston Smith', $subtest);
|
||||
test_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
|
||||
}
|
||||
|
||||
$address->phrase('Winston Smith');
|
||||
|
||||
$address->user(taint('winston.smith'));
|
||||
|
||||
{
|
||||
my $subtest = 'tainted user argument';
|
||||
test_not_tainted($address->phrase(), 'Winston Smith', $subtest);
|
||||
test_tainted($address->user(), 'winston.smith', $subtest);
|
||||
test_not_tainted($address->host(), 'recdep.minitrue', $subtest);
|
||||
test_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->comment(), 'Records Department', $subtest);
|
||||
test_not_tainted($address->name(), 'Winston Smith', $subtest);
|
||||
test_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
|
||||
}
|
||||
|
||||
$address->user('winston.smith');
|
||||
|
||||
$address->host(taint('recdep.minitrue'));
|
||||
|
||||
{
|
||||
my $subtest = 'tainted host argument';
|
||||
test_not_tainted($address->phrase(), 'Winston Smith', $subtest);
|
||||
test_not_tainted($address->user(), 'winston.smith', $subtest);
|
||||
test_tainted($address->host(), 'recdep.minitrue', $subtest);
|
||||
test_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->comment(), 'Records Department', $subtest);
|
||||
test_not_tainted($address->name(), 'Winston Smith', $subtest);
|
||||
test_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
|
||||
}
|
||||
|
||||
$address->host('recdep.minitrue');
|
||||
|
||||
$address->address(taint('winston.smith@recdep.minitrue'));
|
||||
|
||||
{
|
||||
my $subtest = 'tainted address argument';
|
||||
test_not_tainted($address->phrase(), 'Winston Smith', $subtest);
|
||||
test_tainted($address->user(), 'winston.smith', $subtest);
|
||||
test_tainted($address->host(), 'recdep.minitrue', $subtest);
|
||||
test_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->comment(), 'Records Department', $subtest);
|
||||
test_not_tainted($address->name(), 'Winston Smith', $subtest);
|
||||
test_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
|
||||
}
|
||||
|
||||
$address->address('winston.smith@recdep.minitrue');
|
||||
|
||||
$address->comment(taint('Records Department'));
|
||||
|
||||
{
|
||||
my $subtest = 'tainted address argument';
|
||||
test_not_tainted($address->phrase(), 'Winston Smith', $subtest);
|
||||
test_not_tainted($address->user(), 'winston.smith', $subtest);
|
||||
test_not_tainted($address->host(), 'recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
test_tainted($address->comment(), 'Records Department', $subtest);
|
||||
test_not_tainted($address->name(), 'Winston Smith', $subtest);
|
||||
test_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
|
||||
}
|
||||
|
||||
undef $address;
|
||||
|
||||
$address = Email::Address::XS->parse('"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)');
|
||||
|
||||
{
|
||||
my $subtest = 'no tainted parse';
|
||||
test_not_tainted($address->phrase(), 'Winston Smith', $subtest);
|
||||
test_not_tainted($address->user(), 'winston.smith', $subtest);
|
||||
test_not_tainted($address->host(), 'recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->comment(), 'Records Department', $subtest);
|
||||
test_not_tainted($address->name(), 'Winston Smith', $subtest);
|
||||
test_not_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
|
||||
test_not_tainted($address->original(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
|
||||
}
|
||||
|
||||
undef $address;
|
||||
|
||||
$address = Email::Address::XS->parse(taint('"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)'));
|
||||
|
||||
{
|
||||
my $subtest = 'tainted parse';
|
||||
test_tainted($address->phrase(), 'Winston Smith', $subtest);
|
||||
test_tainted($address->user(), 'winston.smith', $subtest);
|
||||
test_tainted($address->host(), 'recdep.minitrue', $subtest);
|
||||
test_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
test_tainted($address->comment(), 'Records Department', $subtest);
|
||||
test_tainted($address->name(), 'Winston Smith', $subtest);
|
||||
test_tainted($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
|
||||
test_tainted($address->original(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest);
|
||||
}
|
||||
|
||||
undef $address;
|
||||
|
||||
$address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue');
|
||||
|
||||
{
|
||||
my $subtest = 'no tainted parse_bare_address';
|
||||
test_not_tainted($address->user(), 'winston.smith', $subtest);
|
||||
test_not_tainted($address->host(), 'recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->format(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
test_not_tainted($address->original(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
}
|
||||
|
||||
undef $address;
|
||||
|
||||
$address = Email::Address::XS->parse_bare_address(taint('winston.smith@recdep.minitrue'));
|
||||
|
||||
{
|
||||
my $subtest = 'tainted parse_bare_address';
|
||||
test_tainted($address->user(), 'winston.smith', $subtest);
|
||||
test_tainted($address->host(), 'recdep.minitrue', $subtest);
|
||||
test_tainted($address->address(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
test_tainted($address->format(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
test_tainted($address->original(), 'winston.smith@recdep.minitrue', $subtest);
|
||||
}
|
||||
Loading…
Reference in New Issue