File Coverage

blib/lib/Email/Address/XS.pm
Criterion Covered Total %
statement 110 121 90.9
branch 66 70 94.2
condition 24 33 72.7
subroutine 19 23 82.6
pod 11 15 73.3
total 230 262 87.7


line stmt bran cond sub pod time code
1             # Copyright (c) 2015-2017 by Pali
2              
3             package Email::Address::XS;
4              
5 2     2   27909 use 5.006;
  2         4  
6 2     2   6 use strict;
  2         2  
  2         39  
7 2     2   6 use warnings;
  2         6  
  2         72  
8              
9             our $VERSION = '1.00';
10              
11 2     2   7 use Carp;
  2         2  
  2         106  
12              
13 2     2   8 use base 'Exporter';
  2         2  
  2         189  
14             our @EXPORT_OK = qw(parse_email_addresses parse_email_groups format_email_addresses format_email_groups);
15              
16 2     2   7 use XSLoader;
  2         3  
  2         1734  
17             XSLoader::load(__PACKAGE__, $VERSION);
18              
19             =head1 NAME
20              
21             Email::Address::XS - Parse and format RFC 2822 email addresses and groups
22              
23             =head1 SYNOPSIS
24              
25             use Email::Address::XS;
26              
27             my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', user => 'winston.smith', host => 'recdep.minitrue', comment => 'Records Department');
28             print $winstons_address->address();
29             # winston.smith@recdep.minitrue
30              
31             my $julias_address = Email::Address::XS->new('Julia', 'julia@ficdep.minitrue');
32             print $julias_address->format();
33             # Julia
34              
35             my $users_address = Email::Address::XS->parse('user ');
36             print $users_address->host();
37             # oceania
38              
39              
40             use Email::Address::XS qw(format_email_addresses format_email_groups parse_email_addresses parse_email_groups);
41             my $undef = undef;
42              
43             my $addresses_string = format_email_addresses($winstons_address, $julias_address, $users_address);
44             print $addresses_string;
45             # "Winston Smith" (Records Department), Julia , user
46              
47             my @addresses = parse_email_addresses($addresses_string);
48             print 'address: ' . $_->address() . "\n" foreach @addresses;
49             # address: winston.smith@recdep.minitrue
50             # address: julia@ficdep.minitrue
51             # address: user@oceania
52              
53             my $groups_string = format_email_groups('Brotherhood' => [ $winstons_address, $julias_address ], $undef => [ $users_address ]);
54             print $groups_string;
55             # Brotherhood: "Winston Smith" (Records Department), Julia ;, user
56              
57             my @groups = parse_email_groups($groups_string);
58              
59             =head1 DESCRIPTION
60              
61             This module implements L
62             parser and formatter of email addresses and groups. It parses an input
63             string from email headers which contain a list of email addresses or
64             a groups of email addresses (like From, To, Cc, Bcc, Reply-To, Sender,
65             ...). Also it can generate a string value for those headers from a
66             list of email addresses objects.
67              
68             Parser and formatter functionality is implemented in XS and uses
69             shared code from Dovecot IMAP server.
70              
71             It is a drop-in replacement for L
72             which has several security issues. E.g. issue L,
73             which allows remote attackers to cause denial of service, is still
74             present in L version 1.908.
75              
76             Email::Address::XS module was created to finally fix CVE-2015-7686.
77              
78             Existing applications that use Email::Address module could be easily
79             switched to Email::Address::XS module. In most cases only changing
80             C to C and replacing every
81             C occurrence with C is sufficient.
82              
83             So unlike L, this module does not use
84             regular expressions for parsing but instead native XS implementation
85             parses input string sequentially according to RFC 2822 grammar.
86              
87             Additionally it has support also for named groups and so can be use
88             instead of L.
89              
90             =head2 EXPORT
91              
92             None by default. Exportable functions are:
93             C,
94             C,
95             C,
96             C.
97              
98             =head2 Exportable Functions
99              
100             =over 4
101              
102             =item format_email_addresses
103              
104             use Email::Address::XS qw(format_email_addresses);
105              
106             my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston@recdep.minitrue');
107             my $julias_address = Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue');
108             my @addresses = ($winstons_address, $julias_address);
109             my $string = format_email_addresses(@addresses);
110             print $string;
111             # "Winston Smith" , Julia
112              
113             Takes a list of email address objects and returns one formatted string
114             of those email addresses.
115              
116             =cut
117              
118             sub format_email_addresses {
119 37     37 1 1229 my (@args) = @_;
120 37         1229 return format_email_groups(undef, \@args);
121             }
122              
123             =item format_email_groups
124              
125             use Email::Address::XS qw(format_email_groups);
126             my $undef = undef;
127              
128             my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', user => 'winston.smith', host => 'recdep.minitrue');
129             my $julias_address = Email::Address::XS->new('Julia', 'julia@ficdep.minitrue');
130             my $users_address = Email::Address::XS->new(address => 'user@oceania');
131              
132             my $groups_string = format_email_groups('Brotherhood' => [ $winstons_address, $julias_address ], $undef => [ $users_address ]);
133             print $groups_string;
134             # Brotherhood: "Winston Smith" , Julia ;, user@oceania
135              
136             my $undisclosed_string = format_email_groups('undisclosed-recipients' => []);
137             print $undisclosed_string;
138             # undisclosed-recipients:;
139              
140             Like C but this method takes pairs which
141             consist of a group display name and a reference to address list. If a
142             group is not undef then address list is formatted inside named group.
143              
144             =item parse_email_addresses
145              
146             use Email::Address::XS qw(parse_email_addresses);
147              
148             my $string = '"Winston Smith" , Julia , user@oceania';
149             my @addresses = parse_email_addresses($string);
150             # @addresses now contains three Email::Address::XS objects, one for each address
151              
152             Parses an input string and returns a list of Email::Address::XS
153             objects. Optional second string argument specifies class name for
154             blessing new objects.
155              
156             =cut
157              
158             sub parse_email_addresses {
159 31     31 1 1108 my (@args) = @_;
160 31         29 my $t = 1;
161 31         695 return map { @{$_} } grep { $t ^= 1 } parse_email_groups(@args);
  25         19  
  25         115  
  50         67  
162             }
163              
164             =item parse_email_groups
165              
166             use Email::Address::XS qw(parse_email_groups);
167             my $undef = undef;
168              
169             my $string = 'Brotherhood: "Winston Smith" , Julia ;, user@oceania, undisclosed-recipients:;';
170             my @groups = parse_email_groups($string);
171             # @groups now contains list ('Brotherhood' => [ $winstons_object, $julias_object ], $undef => [ $users_object ], 'undisclosed-recipients' => [])
172              
173             Like C but this function returns a list of
174             pairs: a group display name and a reference to a list of addresses
175             which belongs to that named group. An undef value for a group means
176             that a following list of addresses is not inside any named group. An
177             output is in a same format as a input for the function
178             C. This function preserves order of groups and
179             does not do any de-duplication or merging.
180              
181             =back
182              
183             =head2 Class Methods
184              
185             =over 4
186              
187             =item new
188              
189             my $empty_address = Email::Address::XS->new();
190             my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', user => 'winston.smith', host => 'recdep.minitrue', comment => 'Records Department');
191             my $julias_address = Email::Address::XS->new('Julia', 'julia@ficdep.minitrue');
192             my $users_address = Email::Address::XS->new(address => 'user@oceania');
193             my $only_name = Email::Address::XS->new(phrase => 'Name');
194             my $copy_of_winstons_address = Email::Address::XS->new(copy => $winstons_address);
195              
196             Constructs and returns a new C object. Takes named
197             list of arguments: phrase, address, user, host, comment and copy.
198             An argument address takes precedence over user and host.
199              
200             When an argument copy is specified then it is expected an
201             Email::Address::XS object and a cloned copy of that object is
202             returned. All other parameters are ignored.
203              
204             Old syntax L is
205             supported too. Takes one to four positional arguments: phrase, address
206             comment, and original string. An argument original is deprecated and
207             ignored. Passing it throws a warning.
208              
209             =cut
210              
211             sub new {
212 107     107 1 114010 my ($class, @args) = @_;
213              
214 107         243 my %hash_keys = (phrase => 1, address => 1, user => 1, host => 1, comment => 1, copy => 1);
215 107         71 my $is_hash;
216 107 100 100     526 if ( scalar @args == 2 and defined $args[0] ) {
    100 66        
    100 66        
217 18 100       36 $is_hash = 1 if exists $hash_keys{$args[0]};
218             } elsif ( scalar @args == 4 and defined $args[0] and defined $args[2] ) {
219 50 100 66     157 $is_hash = 1 if exists $hash_keys{$args[0]} and exists $hash_keys{$args[2]};
220             } elsif ( scalar @args > 4 ) {
221 21         16 $is_hash = 1;
222             }
223              
224 107         82 my %args;
225 107 100       113 if ( $is_hash ) {
226 85         115 %args = @args;
227             } else {
228 22 100       148 carp 'Argument original is deprecated and ignored' if scalar @args > 3;
229 22 100       31 $args{comment} = $args[2] if scalar @args > 2;
230 22 100       33 $args{address} = $args[1] if scalar @args > 1;
231 22 100       35 $args{phrase} = $args[0] if scalar @args > 0;
232             }
233              
234 107 100       155 if ( exists $args{copy} ) {
235 1 50       4 if ( $class->is_obj($args{copy}) ) {
236 1         2 $args{phrase} = $args{copy}->phrase();
237 1         3 $args{comment} = $args{copy}->comment();
238 1         2 $args{user} = $args{copy}->user();
239 1         2 $args{host} = $args{copy}->host();
240 1         1 delete $args{address};
241             } else {
242 0         0 carp 'Named argument copy does not contain a valid object';
243             }
244             }
245              
246 107         110 my $self = bless {}, $class;
247              
248 107         161 $self->phrase($args{phrase});
249 107         194 $self->comment($args{comment});
250              
251 107 100       136 if ( exists $args{address} ) {
252 66         84 $self->address($args{address});
253             } else {
254 41         63 $self->user($args{user});
255 41         66 $self->host($args{host});
256             }
257              
258 107         374 return $self;
259             }
260              
261             =item parse
262              
263             my $winstons_address = Email::Address::XS->parse('"Winston Smith" (Records Department)');
264             my @users_addresses = Email::Address::XS->parse('user1@oceania, user2@oceania');
265              
266             Parses an input string and returns a list of an Email::Address::XS
267             objects. Same as the function C but this one is
268             class method.
269              
270             In scalar context this function returns just first parsed object.
271              
272             =cut
273              
274             sub parse {
275 8     8 1 3525 my ($class, $string) = @_;
276 8         16 my @addresses = parse_email_addresses($string, $class);
277 8 100       50 return wantarray ? @addresses : $addresses[0];
278             }
279              
280             =back
281              
282             =head2 Object Methods
283              
284             =over 4
285              
286             =item format
287              
288             my $string = $address->format();
289              
290             Returns formatted Email::Address::XS object as a string.
291              
292             =cut
293              
294             sub format {
295 31     31 1 40 my ($self) = @_;
296 31         41 return format_email_addresses($self);
297             }
298              
299             =item phrase
300              
301             my $phrase = $address->phrase();
302             $address->phrase('Winston Smith');
303              
304             Accessor and mutator for the phrase (display name).
305              
306             =cut
307              
308             sub phrase {
309 186     186 1 1912 my ($self, @args) = @_;
310 186 100       418 return $self->{phrase} unless @args;
311 122         418 return $self->{phrase} = $args[0];
312             }
313              
314             =item user
315              
316             my $user = $address->user();
317             $address->user('winston.smith');
318              
319             Accessor and mutator for the unescaped user part of an address.
320              
321             =cut
322              
323             sub user {
324 108     108 1 807 my ($self, @args) = @_;
325 108 100       273 return $self->{user} unless @args;
326 50 100       73 delete $self->{cached_address} if exists $self->{cached_address};
327 50         76 return $self->{user} = $args[0];
328             }
329              
330             =item host
331              
332             my $host = $address->host();
333             $address->host('recdep.minitrue');
334              
335             Accessor and mutator for the unescaped host part of an address.
336              
337             =cut
338              
339             sub host {
340 93     93 1 760 my ($self, @args) = @_;
341 93 100       280 return $self->{host} unless @args;
342 47 100       76 delete $self->{cached_address} if exists $self->{cached_address};
343 47         63 return $self->{host} = $args[0];
344             }
345              
346             =item address
347              
348             my $string_address = $address->address();
349             $address->address('winston.smith@recdep.minitrue');
350              
351             Accessor and mutator for the escaped address.
352              
353             Internally this module stores a user and a host part of an address
354             separately. Private method C is used for composing
355             full address and private method C for splitting into a
356             user and a host parts. If splitting new address into these two parts
357             is not possible then this method returns undef and sets both parts to
358             undef.
359              
360             =cut
361              
362             sub address {
363 112     112 1 808 my ($self, @args) = @_;
364 112         80 my $user;
365             my $host;
366 112 100       147 if ( @args ) {
367 81 100       436 ($user, $host) = split_address($args[0]) if defined $args[0];
368 81 100 66     205 if ( not defined $user or not defined $host ) {
369 7         7 $user = undef;
370 7         5 $host = undef;
371             }
372 81         95 $self->{user} = $user;
373 81         82 $self->{host} = $host;
374             } else {
375 31 100       122 return $self->{cached_address} if exists $self->{cached_address};
376 12         30 $user = $self->user();
377 12         24 $host = $self->host();
378             }
379 93 100 66     502 if ( defined $user and defined $host and length $user and length $host ) {
      100        
      66        
380 82         328 return $self->{cached_address} = compose_address($user, $host);
381             } else {
382 11         27 return $self->{cached_address} = undef;
383             }
384             }
385              
386             =item comment
387              
388             my $comment = $address->comment();
389             $address->comment('Records Department');
390              
391             Accessor and mutator for the comment which is formatted after an
392             address. A comment can contain another nested comments in round
393             brackets. When setting new comment this method check if brackets are
394             balanced. If not undef is set and returned.
395              
396             =cut
397              
398             sub comment {
399 181     181 1 243 my ($self, @args) = @_;
400 181 100       643 return $self->{comment} unless @args;
401 127 100       263 return $self->{comment} = undef unless defined $args[0];
402 30         25 my $count = 0;
403 30         27 my $cleaned = $args[0];
404 30         225 $cleaned =~ s/(?:\\.|[^\(\)])//g;
405 30         80 foreach ( split //, $cleaned ) {
406 33 100       43 $count++ if $_ eq '(';
407 33 100       39 $count-- if $_ eq ')';
408 33 100       43 last if $count < 0;
409             }
410 30 100       60 return $self->{comment} = undef if $count != 0;
411 25         55 return $self->{comment} = $args[0];
412             }
413              
414             =item name
415              
416             my $name = $address->name();
417              
418             This method tries to return a name which belongs to the address. It
419             returns either C or C or C part of the address
420             or empty string (first defined value in this order). But it never
421             returns undef.
422              
423             =cut
424              
425             sub name {
426 34     34 1 47 my ($self) = @_;
427 34         49 my $phrase = $self->phrase();
428 34 100 66     175 return $phrase if defined $phrase and length $phrase;
429 14         17 my $comment = $self->comment();
430 14 100 66     31 return $comment if defined $comment and length $comment;
431 12         14 my $user = $self->user();
432 12 100 66     58 return $user if defined $user and length $user;
433 4         12 return '';
434             }
435              
436             =back
437              
438             =head2 Overloaded Operators
439              
440             =over 4
441              
442             =item stringify
443              
444             my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue');
445             print "Winston's address is $address.";
446             # Winston's address is "Winston Smith" .
447              
448             Objects stringify to C.
449              
450             =cut
451              
452             our $STRINGIFY; # deprecated
453              
454             use overload '""' => sub {
455 5     5   9 my ($self) = @_;
456 5 50       14 return $self->format() unless defined $STRINGIFY;
457 0         0 carp 'Variable $Email::Address::XS::STRINGIFY is deprecated; subclass instead';
458 0         0 my $method = $self->can($STRINGIFY);
459 0 0       0 croak 'Stringify method ' . $STRINGIFY . ' does not exist' unless defined $method;
460 0         0 return $method->($self);
461 2     2   1861 };
  2         1892  
  2         14  
462              
463             =back
464              
465             =head2 Deprecated Functions, Methods and Variables
466              
467             For compatibility with L
468             there are defined some deprecated functions, methods and variables.
469             Do not use them in new code. Their usage throws warnings.
470              
471             Altering deprecated variable C<$Email:Address::XS::STRINGIFY> changes
472             method which is called for objects stringification.
473              
474             Deprecated cache functions C, C and
475             C are noop and do nothing.
476              
477             =cut
478              
479             sub purge_cache {
480 0     0 0   carp 'Function purge_cache is deprecated and does nothing';
481             }
482              
483             sub disable_cache {
484 0     0 0   carp 'Function disable_cache is deprecated and does nothing';
485             }
486              
487             sub enable_cache {
488 0     0 0   carp 'Function enable_cache is deprecated and does nothing';
489             }
490              
491             =pod
492              
493             Deprecated object method C just returns C
.
494              
495             =cut
496              
497             sub original {
498 0     0 0   my ($self) = @_;
499 0           carp 'Method original is deprecated and returns address';
500 0           return $self->address();
501             }
502              
503             =head1 SEE ALSO
504              
505             L,
506             L,
507             L,
508             L,
509             L
510              
511             =head1 AUTHOR
512              
513             Pali Epali@cpan.orgE
514              
515             =head1 COPYRIGHT AND LICENSE
516              
517             Copyright (C) 2015-2017 by Pali Epali@cpan.orgE
518              
519             This library is free software; you can redistribute it and/or modify
520             it under the same terms as Perl itself, either Perl version 5.6.0 or,
521             at your option, any later version of Perl 5 you may have available.
522              
523             Dovecot parser is licensed under The MIT License and copyrighted by
524             Dovecot authors.
525              
526             =cut
527              
528             1;