Email-Address-XS-1.04/0000755000175000017500000000000013306777542013052 5ustar palipaliEmail-Address-XS-1.04/META.json0000644000175000017500000000301113306777542014466 0ustar palipali{ "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.04", "x_serialization_backend" : "JSON::PP version 2.97001" } Email-Address-XS-1.04/META.yml0000644000175000017500000000146713306777542014333 0ustar palipali--- 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.04' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Email-Address-XS-1.04/Changes0000644000175000017500000000327413306777440014350 0ustar palipaliRevision history for Perl extension Email::Address::XS. 1.04 Sat Jun 09 18:20:28 2018 - fix docevot parser to disallow leading dot in dot-atom - fix generating and validating email addresses with empty user part - fix generating email address with leading or trailing dot in user part - try to parse invalid email addresses and mark them as invalid - when generating address do not escape an apostrophe character - fix formatting email addresses which contain nul bytes, TAB, LF or CR - fix formatting comments which contain nul bytes 1.03 Thu Mar 15 21:55:30 2018 - update dovecot parser from dovecot version 2.3.0.1 - fix reading from uninitialized memory when formatting invalid address without user or host part - fix formatting email address which user part starts with null byte - do not generate invalid email addresses by format functions, rather return empty string 1.02 Sat Feb 03 13:41:38 2018 - add support for parsing and generating addresses with nul character - fix function compose_address when both user and host contains non-ASCII 8bit characters - fix possible memory leak in dovecot parser 1.01 Wed Oct 18 18:19:26 2017 - add new exportable functions: compose_address split_address - add new class methods: parse_bare_address - add new object methods: is_valid original as_string - show warnings when strings contain nul characters - update dovecot parser from dovecot version 2.2.31 - fix memory leak - fix documentation - improve warning messages 1.00 Sat Feb 18 15:23:30 2017 - first public release 0.01 Tue Aug 25 18:41:43 2015 - original version; created by h2xs 1.23 with options --compat-version 5.6.2 --skip-ppport --omit-autoload --name Email::Address::XS Email-Address-XS-1.04/dovecot-parser.h0000644000175000017500000000334013306777427016162 0ustar palipali#ifndef DOVECOT_PARSER_H #define DOVECOT_PARSER_H #include /* 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. If fill_missing is TRUE, missing mailbox and domain are set to MISSING_MAILBOX and MISSING_DOMAIN strings. Otherwise they're set to "". 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, bool fill_missing); 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 Email-Address-XS-1.04/lib/0000755000175000017500000000000013306777542013620 5ustar palipaliEmail-Address-XS-1.04/lib/Email/0000755000175000017500000000000013306777542014647 5ustar palipaliEmail-Address-XS-1.04/lib/Email/Address/0000755000175000017500000000000013306777542016234 5ustar palipaliEmail-Address-XS-1.04/lib/Email/Address/XS.pm0000644000175000017500000005156713306777440017137 0ustar palipali# Copyright (c) 2015-2018 by Pali package Email::Address::XS; use 5.006; use strict; use warnings; our $VERSION = '1.04'; 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; Email-Address-XS-1.04/README0000644000175000017500000000363513306777440013736 0ustar palipaliEmail-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. Email-Address-XS-1.04/Email-Address-XS.xs0000644000175000017500000004437213306777440016377 0ustar palipali/* 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, false); 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 Email-Address-XS-1.04/dovecot-parser.c0000644000175000017500000007774113306777440016170 0ustar palipali/* * 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; }; struct message_address_parser_context { struct rfc822_parser_context parser; struct message_address *first_addr, *last_addr, addr; string_t *str; bool fill_missing; }; 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; } /* 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; 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 '(': 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 '\\': if (ctx->last_comment != NULL) { str_append_data(ctx->last_comment, start, ctx->data - start); } start = ctx->data + 1; ctx->data++; if (ctx->data >= ctx->end) return -1; 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; } /* Like parse_atom() but don't stop at '.' */ static int rfc822_parse_dot_atom(struct rfc822_parser_context *ctx, string_t *str) { const unsigned char *start; 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_is_dot = false; dot_problem = false; for (start = ctx->data++; ctx->data < ctx->end; ) { if (IS_ATEXT(*ctx->data)) { ctx->data++; continue; } 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 != '.') return (last_is_dot || dot_problem) ? -2 : 1; if (last_is_dot) dot_problem = true; ctx->data++; str_append_c(str, '.'); last_is_dot = true; if ((ret = rfc822_skip_lwsp(ctx)) <= 0) return (dot_problem && ret >= 0) ? -2 : ret; start = ctx->data; } 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; size_t len; i_assert(ctx->data < ctx->end); i_assert(*ctx->data == '"'); ctx->data++; for (start = ctx->data; ctx->data < ctx->end; ctx->data++) { switch (*ctx->data) { case '"': str_append_data(str, start, ctx->data - start); 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 '\\': ctx->data++; if (ctx->data >= ctx->end) return -1; str_append_data(str, start, ctx->data - start - 1); start = ctx->data; 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; /* 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) return ret; if (!IS_ATEXT(*ctx->data) && *ctx->data != '"' && *ctx->data != '.') break; str_append_c(str, ' '); } return rfc822_skip_lwsp(ctx); } static int rfc822_parse_domain_literal(struct rfc822_parser_context *ctx, string_t *str) { const unsigned char *start; /* 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++) { if (*ctx->data == '\\') { ctx->data++; if (ctx->data >= ctx->end) break; } else if (*ctx->data == ']') { ctx->data++; str_append_data(str, start, ctx->data - start); return rfc822_skip_lwsp(ctx); } } /* 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); } 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_local_part(struct message_address_parser_context *ctx) { int ret; /* 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); if (*ctx->parser.data == '"') ret = rfc822_parse_quoted_string(&ctx->parser, ctx->str); else ret = rfc822_parse_dot_atom(&ctx->parser, ctx->str); if (ret < 0 && ret != -2) return -1; 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) 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) 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) { int ret; /* "<" [ "@" route ":" ] local-part "@" domain ">" */ i_assert(*ctx->parser.data == '<'); ctx->parser.data++; if ((ret = rfc822_skip_lwsp(&ctx->parser)) <= 0) return ret; if (*ctx->parser.data == '@') { if ((ret = parse_domain_list(ctx)) <= 0 || *ctx->parser.data != ':') { 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 */ } else { ctx->parser.data++; } ctx->parser.data++; if ((ret = rfc822_skip_lwsp(&ctx->parser)) <= 0) return ret; } if (*ctx->parser.data == '>') { /* <> address isn't valid */ } else { if ((ret = parse_local_part(ctx)) <= 0 && ret != -2) return ret; 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) return ret; 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) { /* name-addr = [display-name] angle-addr display-name = phrase */ str_truncate(ctx->str, 0); if (rfc822_parse_phrase(&ctx->parser, ctx->str) <= 0 || *ctx->parser.data != '<') return -1; 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) < 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); if (rfc822_parse_phrase(&ctx->parser, ctx->str) <= 0 || *ctx->parser.data != ':') return -1; /* 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 != ',') { 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, bool fill_missing) { 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 = fill_missing; (void)parse_address_list(&ctx, max_addresses); str_free(&ctx.str); str_free(&str); 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); /* 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; ret = rfc822_skip_lwsp(&ctx.parser); if (ret > 0) ret = parse_addr_spec(&ctx); else ret = -1; 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); str_free(&ctx.str); } void string_free(char *string) { free(string); } Email-Address-XS-1.04/MANIFEST0000644000175000017500000000051213306777542014201 0ustar palipaliChanges 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) Email-Address-XS-1.04/Makefile.PL0000644000175000017500000000225113306777427015026 0ustar palipali#!/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, }, ) : (), ); Email-Address-XS-1.04/t/0000755000175000017500000000000013306777542013315 5ustar palipaliEmail-Address-XS-1.04/t/Email-Address-XS.t0000755000175000017500000017717013306777440016461 0ustar palipali#!/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 => 511; 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_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; } Email-Address-XS-1.04/t/taint-Email-Address-XS.t0000755000175000017500000001701513306777427017572 0ustar palipali#!/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); }