File Coverage

blib/lib/Email/MIME/Header/AddressList.pm
Criterion Covered Total %
statement 104 122 85.2
branch 19 32 59.3
condition 11 18 61.1
subroutine 16 18 88.8
pod 13 13 100.0
total 163 203 80.3


line stmt bran cond sub pod time code
1             # Copyright (c) 2016-2017 by Pali
2              
3             package Email::MIME::Header::AddressList 1.951;
4              
5             # ABSTRACT: MIME support for list of Email::Address::XS objects
6              
7 3     3   2383 use strict;
  3         8  
  3         94  
8 3     3   17 use warnings;
  3         6  
  3         103  
9              
10 3     3   17 use Carp ();
  3         6  
  3         46  
11 3     3   14 use Email::Address::XS;
  3         8  
  3         187  
12 3     3   19 use Email::MIME::Encode;
  3         7  
  3         4512  
13              
14             #pod =encoding utf8
15             #pod
16             #pod =head1 SYNOPSIS
17             #pod
18             #pod my $address1 = Email::Address::XS->new('Name1' => 'address1@host.com');
19             #pod my $address2 = Email::Address::XS->new("Name2 \N{U+263A}" => 'address2@host.com');
20             #pod my $mime_address = Email::Address::XS->new('=?UTF-8?B?TmFtZTIg4pi6?=' => 'address2@host.com');
21             #pod
22             #pod my $list1 = Email::MIME::Header::AddressList->new($address1, $address2);
23             #pod
24             #pod $list1->append_groups('undisclosed-recipients' => []);
25             #pod
26             #pod $list1->first_address();
27             #pod # returns $address1
28             #pod
29             #pod $list1->groups();
30             #pod # returns (undef, [ $address1, $address2 ], 'undisclosed-recipients', [])
31             #pod
32             #pod $list1->as_string();
33             #pod # returns 'Name1 , "Name2 ☺" , undisclosed-recipients:;'
34             #pod
35             #pod $list1->as_mime_string();
36             #pod # returns 'Name1 , =?UTF-8?B?TmFtZTIg4pi6?= , undisclosed-recipients:;'
37             #pod
38             #pod my $list2 = Email::MIME::Header::AddressList->new_groups(Group => [ $address1, $address2 ]);
39             #pod
40             #pod $list2->append_addresses($address2);
41             #pod
42             #pod $list2->addresses();
43             #pod # returns ($address2, $address1, $address2)
44             #pod
45             #pod $list2->groups();
46             #pod # returns (undef, [ $address2 ], 'Group', [ $address1, $address2 ])
47             #pod
48             #pod my $list3 = Email::MIME::Header::AddressList->new_mime_groups('=?UTF-8?B?4pi6?=' => [ $mime_address ]);
49             #pod $list3->as_string();
50             #pod # returns '☺: "Name2 ☺" ;'
51             #pod
52             #pod my $list4 = Email::MIME::Header::AddressList->from_string('Name1 , "Name2 ☺" , undisclosed-recipients:;');
53             #pod my $list5 = Email::MIME::Header::AddressList->from_string('Name1 ', '"Name2 ☺" ', 'undisclosed-recipients:;');
54             #pod
55             #pod my $list6 = Email::MIME::Header::AddressList->from_mime_string('Name1 , =?UTF-8?B?TmFtZTIg4pi6?= , undisclosed-recipients:;');
56             #pod my $list7 = Email::MIME::Header::AddressList->from_mime_string('Name1 ', '=?UTF-8?B?TmFtZTIg4pi6?= ', 'undisclosed-recipients:;');
57             #pod
58             #pod =head1 DESCRIPTION
59             #pod
60             #pod This module implements object representation for the list of the
61             #pod L objects. It provides methods for
62             #pod L MIME encoding and decoding
63             #pod suitable for L address-list
64             #pod structure.
65             #pod
66             #pod =head2 EXPORT
67             #pod
68             #pod None
69             #pod
70             #pod =head2 Class Methods
71             #pod
72             #pod =over 4
73             #pod
74             #pod =item new_empty
75             #pod
76             #pod Construct new empty C object.
77             #pod
78             #pod =cut
79              
80             sub new_empty {
81 59     59 1 105 my ($class) = @_;
82 59         214 return bless { addresses => [], groups => [] }, $class;
83             }
84              
85             #pod =item new
86             #pod
87             #pod Construct new C object from list of
88             #pod L objects.
89             #pod
90             #pod =cut
91              
92             sub new {
93 0     0 1 0 my ($class, @addresses) = @_;
94 0         0 my $self = $class->new_empty();
95 0         0 $self->append_addresses(@addresses);
96 0         0 return $self;
97             }
98              
99             #pod =item new_groups
100             #pod
101             #pod Construct new C object from named groups of
102             #pod L objects.
103             #pod
104             #pod =cut
105              
106             sub new_groups {
107 59     59 1 9735 my ($class, @groups) = @_;
108 59         126 my $self = $class->new_empty();
109 59         167 $self->append_groups(@groups);
110 59         278 return $self;
111             }
112              
113             #pod =item new_mime_groups
114             #pod
115             #pod Like L|/new_groups> but in this method group names and objects properties are
116             #pod expected to be already MIME encoded, thus ASCII strings.
117             #pod
118             #pod =cut
119              
120             sub new_mime_groups {
121 35     35 1 90 my ($class, @groups) = @_;
122 35 50       98 if (scalar @groups % 2) {
123 0         0 Carp::carp 'Odd number of elements in argument list';
124 0         0 return;
125             }
126 35         116 foreach (0 .. scalar @groups / 2 - 1) {
127 35 100 100     140 $groups[2 * $_] = Email::MIME::Encode::mime_decode($groups[2 * $_])
128             if defined $groups[2 * $_] and $groups[2 * $_] =~ /=\?/;
129 35         52 $groups[2 * $_ + 1] = [ @{$groups[2 * $_ + 1]} ];
  35         84  
130 35         61 foreach (@{$groups[2 * $_ + 1]}) {
  35         85  
131 44 50       275 next unless Email::Address::XS->is_obj($_);
132 44   66     127 my $decode_phrase = (defined $_->phrase and $_->phrase =~ /=\?/);
133 44   33     668 my $decode_comment = (defined $_->comment and $_->comment =~ /=\?/);
134 44 100 66     326 next unless $decode_phrase or $decode_comment;
135 43         147 $_ = ref($_)->new(copy => $_);
136 43 50       3947 $_->phrase(Email::MIME::Encode::mime_decode($_->phrase))
137             if $decode_phrase;
138 43 50       444 $_->comment(Email::MIME::Encode::mime_decode($_->comment))
139             if $decode_comment;
140             }
141             }
142 35         100 return $class->new_groups(@groups);
143             }
144              
145             #pod =item from_string
146             #pod
147             #pod Construct new C object from input string arguments.
148             #pod Calls L.
149             #pod
150             #pod =cut
151              
152             sub from_string {
153 22     22 1 58 my ($class, @strings) = @_;
154 22         51 return $class->new_groups(map { Email::Address::XS::parse_email_groups($_) } @strings);
  24         291  
155             }
156              
157             #pod =item from_mime_string
158             #pod
159             #pod Like L|/from_string> but input string arguments are expected to
160             #pod be already MIME encoded.
161             #pod
162             #pod =cut
163              
164             sub from_mime_string {
165 35     35 1 80 my ($class, @strings) = @_;
166 35         65 return $class->new_mime_groups(map { Email::Address::XS::parse_email_groups($_) } @strings);
  35         372  
167             }
168              
169             #pod =back
170             #pod
171             #pod =head2 Object Methods
172             #pod
173             #pod =over 4
174             #pod
175             #pod =item as_string
176             #pod
177             #pod Returns string representation of C object.
178             #pod Calls L.
179             #pod
180             #pod =cut
181              
182             sub as_string {
183 21     21 1 43 my ($self) = @_;
184 21         43 return Email::Address::XS::format_email_groups($self->groups());
185             }
186              
187             #pod =item as_mime_string
188             #pod
189             #pod Like L|/as_string> but output string will be properly and
190             #pod unambiguously MIME encoded. MIME encoding is done before calling
191             #pod L.
192             #pod
193             #pod =cut
194              
195             sub as_mime_string {
196 24     24 1 55 my ($self, $arg) = @_;
197 24         41 my $charset = $arg->{charset};
198 24         42 my $header_name_length = $arg->{header_name_length};
199              
200 24         53 my @groups = $self->groups();
201 24         63 foreach (0 .. scalar @groups / 2 - 1) {
202 26 100       73 $groups[2 * $_] = Email::MIME::Encode::mime_encode($groups[2 * $_], $charset)
203             if Email::MIME::Encode::_needs_mime_encode_addr($groups[2 * $_]);
204 26         44 $groups[2 * $_ + 1] = [ @{$groups[2 * $_ + 1]} ];
  26         65  
205 26         46 foreach (@{$groups[2 * $_ + 1]}) {
  26         72  
206 27         83 my $encode_phrase = Email::MIME::Encode::_needs_mime_encode_addr($_->phrase);
207 27         90 my $encode_comment = Email::MIME::Encode::_needs_mime_encode_addr($_->comment);
208 27 100 66     84 next unless $encode_phrase or $encode_comment;
209 23         93 $_ = ref($_)->new(copy => $_);
210 23 50       2200 $_->phrase(Email::MIME::Encode::mime_encode($_->phrase, $charset))
211             if $encode_phrase;
212 23 50       247 $_->comment(Email::MIME::Encode::mime_encode($_->comment, $charset))
213             if $encode_comment;
214             }
215             }
216 24         506 return Email::Address::XS::format_email_groups(@groups);
217             }
218              
219             #pod =item first_address
220             #pod
221             #pod Returns first L object.
222             #pod
223             #pod =cut
224              
225             sub first_address {
226 7     7 1 14 my ($self) = @_;
227 7 50       9 return $self->{addresses}->[0] if @{$self->{addresses}};
  7         21  
228 7         20 my $groups = $self->{groups};
229 7         12 foreach (0 .. @{$groups} / 2 - 1) {
  7         21  
230 7 50       11 next unless @{$groups->[2 * $_ + 1]};
  7         21  
231 7         32 return $groups->[2 * $_ + 1]->[0];
232             }
233 0         0 return undef;
234             }
235              
236             #pod =item addresses
237             #pod
238             #pod Returns list of all L objects.
239             #pod
240             #pod =cut
241              
242             sub addresses {
243 2     2 1 9 my ($self) = @_;
244 2         5 my $t = 1;
245 2         3 my @addresses = @{$self->{addresses}};
  2         5  
246 2         5 push @addresses, map { @{$_} } grep { $t ^= 1 } @{$self->{groups}};
  2         2  
  2         5  
  4         10  
  2         4  
247 2         7 return @addresses;
248             }
249              
250             #pod =item groups
251             #pod
252             #pod Like L|/addresses> but returns objects with named groups.
253             #pod
254             #pod =cut
255              
256             sub groups {
257 51     51 1 89 my ($self) = @_;
258 51         70 my @groups = @{$self->{groups}};
  51         118  
259 53         149 $groups[2 * $_ + 1] = [ @{$groups[2 * $_ + 1]} ]
260 51         145 foreach 0 .. scalar @groups / 2 - 1;
261 0         0 unshift @groups, undef, [ @{$self->{addresses}} ]
262 51 50       75 if @{$self->{addresses}};
  51         121  
263 51         449 return @groups;
264             }
265              
266             #pod =item append_addresses
267             #pod
268             #pod Append L objects.
269             #pod
270             #pod =cut
271              
272             sub append_addresses {
273 0     0 1 0 my ($self, @addresses) = @_;
274 0         0 my @valid_addresses = grep { Email::Address::XS->is_obj($_) } @addresses;
  0         0  
275 0 0       0 Carp::carp 'Argument is not an Email::Address::XS object' if scalar @valid_addresses != scalar @addresses;
276 0         0 push @{$self->{addresses}}, @valid_addresses;
  0         0  
277             }
278              
279             #pod =item append_groups
280             #pod
281             #pod Like L|/append_addresses> but arguments are pairs of name of
282             #pod group and array reference of L objects.
283             #pod
284             #pod =cut
285              
286             sub append_groups {
287 59     59 1 119 my ($self, @groups) = @_;
288 59 50       156 if (scalar @groups % 2) {
289 0         0 Carp::carp 'Odd number of elements in argument list';
290 0         0 return;
291             }
292 59         96 my $carp_invalid = 1;
293 59         92 my @valid_groups;
294 59         199 foreach (0 .. scalar @groups / 2 - 1) {
295 61         125 push @valid_groups, $groups[2 * $_];
296 61         104 my $addresses = $groups[2 * $_ + 1];
297 61         91 my @valid_addresses = grep { Email::Address::XS->is_obj($_) } @{$addresses};
  71         476  
  61         116  
298 61 50 33     195 if ($carp_invalid and scalar @valid_addresses != scalar @{$addresses}) {
  61         209  
299 0         0 Carp::carp 'Array element is not an Email::Address::XS object';
300 0         0 $carp_invalid = 0;
301             }
302 61         159 push @valid_groups, \@valid_addresses;
303             }
304 59         92 push @{$self->{groups}}, @valid_groups;
  59         171  
305             }
306              
307             #pod =back
308             #pod
309             #pod =head1 SEE ALSO
310             #pod
311             #pod L,
312             #pod L,
313             #pod L,
314             #pod L
315             #pod
316             #pod =head1 AUTHOR
317             #pod
318             #pod Pali Epali@cpan.orgE
319             #pod
320             #pod =cut
321              
322             1;
323              
324             __END__