File Coverage

blib/lib/Courriel/Header.pm
Criterion Covered Total %
statement 33 112 29.4
branch 0 30 0.0
condition 0 15 0.0
subroutine 11 18 61.1
pod 2 2 100.0
total 46 177 25.9


line stmt bran cond sub pod time code
1             package Courriel::Header;
2              
3 9     9   2024 use strict;
  9         13  
  9         285  
4 9     9   37 use warnings;
  9         37  
  9         240  
5 9     9   37 use namespace::autoclean;
  9         12  
  9         50  
6              
7             our $VERSION = '0.44';
8              
9 9     9   4434 use Courriel::Helpers qw( fold_header );
  9         30  
  9         1288  
10 9     9   107 use Courriel::Types qw( NonEmptyStr Str Streamable );
  9         16  
  9         95  
11 9     9   93269 use Email::Address::List;
  9         172777  
  9         901  
12 9     9   130 use Encode qw( encode find_encoding );
  9         15  
  9         1017  
13 9     9   6891 use MIME::Base64 qw( encode_base64 );
  9         7616  
  9         739  
14 9     9   71 use Params::ValidationCompiler qw( validation_for );
  9         18  
  9         503  
15              
16 9     9   54 use Moose;
  9         18  
  9         98  
17 9     9   58268 use MooseX::StrictConstructor;
  9         21  
  9         92  
18              
19             with 'Courriel::Role::Streams' => { -exclude => ['stream_to'] };
20              
21             has name => (
22             is => 'ro',
23             isa => NonEmptyStr,
24             required => 1,
25             );
26              
27             has value => (
28             is => 'ro',
29             isa => Str,
30             required => 1,
31             );
32              
33             {
34             my $validator = validation_for(
35             params => [
36             charset => { type => NonEmptyStr, default => 'utf8' },
37             output => { type => Streamable },
38             ],
39             named_to_list => 1,
40             );
41              
42             sub stream_to {
43 0     0 1   my $self = shift;
44 0           my ( $charset, $output ) = $validator->(@_);
45              
46 0           my $string = $self->name;
47 0           $string .= ': ';
48              
49 0           $string .= $self->_maybe_encoded_value($charset);
50              
51 0           $output->( fold_header($string) );
52              
53 0           return;
54             }
55             }
56              
57             sub as_string {
58 0     0 1   my $self = shift;
59              
60 0           my $string = q{};
61              
62 0           $self->stream_to( output => $self->_string_output( \$string ), @_ );
63              
64 0           return $string;
65             }
66              
67             {
68             # RFC 2047 - An 'encoded-word' MUST NOT be used in a Received header
69             # field.
70             my %never_encode = map { lc $_ => 1 } qw( Received );
71             my %contains_addresses = map { lc $_ => 1 } qw( CC From To );
72              
73             # XXX - this really isn't very correct. Only certain types of values (per RFC
74             # 2047) can be encoded, not just any random text. I'm not sure how best to
75             # handle this. If we parsed an email that encoded stuff that shouldn't be
76             # encoded, what should we do? At the very least, we should add some checks to
77             # Courriel::Builder to ensure that people don't try to create an email with
78             # non-ASCII in certain parts of fields (like in email addresses).
79             sub _maybe_encoded_value {
80 0     0     my $self = shift;
81 0           my $charset = shift;
82              
83             return $self->value
84 0 0         if $never_encode{ lc $self->name };
85              
86             return $self->_encoded_address_list($charset)
87 0 0         if $contains_addresses{ lc $self->name };
88              
89 0           return $self->_encode_string( $self->value, $charset );
90             }
91             }
92              
93             sub _encoded_address_list {
94 0     0     my $self = shift;
95 0           my $charset = shift;
96              
97 0           my @elements;
98             my @group;
99 0           for my $parsed ( Email::Address::List->parse( $self->value ) ) {
100 0 0         my $push_to = @group ? \@group : \@elements;
101             ## no critic (ControlStructures::ProhibitCascadingIfElse)
102 0 0         if ( $parsed->{type} eq 'group start' ) {
    0          
    0          
    0          
103 0           @group = $parsed->{value} . ':';
104             }
105             elsif ( $parsed->{type} eq 'group end' ) {
106 0           my $group = join ', ', @group;
107 0           $group .= ';';
108 0           push @elements, $group;
109 0           @group = ();
110             }
111             elsif ( $parsed->{type} eq 'unknown' ) {
112 0           push @{$push_to},
113 0           $self->_encode_string( $parsed->{value}, $charset );
114             }
115             elsif ( $parsed->{type} eq 'mailbox' ) {
116 0           push @{$push_to},
117 0           $self->_maybe_encoded_address( $parsed->{value}, $charset );
118             }
119             }
120              
121 0           return join ', ', @elements;
122             }
123              
124             sub _maybe_encoded_address {
125 0     0     my $self = shift;
126 0           my $address = shift;
127 0           my $charset = shift;
128              
129 0           my $encoded = q{};
130              
131 0           my $phrase = $address->phrase;
132 0 0 0       if ( defined $phrase && length $phrase ) {
133 0           my $enc_phrase = $self->_encode_string( $phrase, $charset );
134              
135             # If the phrase wasn't encoded then we can make it a quoted-word, if
136             # it was encoded then it cannot be wrapped in quotes per RFC 2047.
137 0 0         if ( $enc_phrase ne $phrase ) {
138 0           $encoded .= $enc_phrase;
139             }
140             else {
141 0           $encoded .= q{"} . $phrase . q{"};
142             }
143 0           $encoded .= q{ };
144             }
145              
146 0           $encoded .= '<' . $address->address . '>';
147              
148 0           my $comment = $address->comment;
149 0 0 0       if ( defined $comment && length $comment ) {
150 0           $encoded .= '(' . $self->_encode_string( $comment, $charset ) . ')';
151             }
152              
153 0           return $encoded;
154             }
155              
156             {
157             my $header_chunk = qr/
158             (?:
159             ^
160             |
161             (?<ascii>[\x21-\x7e]+) # printable ASCII (excluding space, \x20)
162             |
163             (?<non_ascii>\S+) # anything that's not space
164             )
165             (?:
166             (?<ws>\s+)
167             |
168             $
169             )
170             /x;
171              
172             sub _encode_string {
173 0     0     my $self = shift;
174 0           my $string = shift;
175 0           my $charset = shift;
176              
177 0           my @chunks;
178 0           while ( $string =~ /\G$header_chunk/g ) {
179 0           push @chunks, {%+};
180             }
181              
182 0           my @encoded;
183 0           for my $i ( 0 .. $#chunks ) {
184 0 0         if ( defined $chunks[$i]->{non_ascii} ) {
185             my $to_encode
186             = $chunks[ $i + 1 ]
187             && defined $chunks[ $i + 1 ]{non_ascii}
188             ? $chunks[$i]{non_ascii} . ( $chunks[$i]{ws} // q{} )
189 0 0 0       : $chunks[$i]{non_ascii};
      0        
190              
191 0           push @encoded, $self->_mime_encode( $to_encode, $charset );
192 0 0         push @encoded, q{ } if $chunks[ $i + 1 ];
193             }
194             else {
195             push @encoded,
196             ( $chunks[$i]{ascii} // q{} )
197 0   0       . ( $chunks[$i]{ws} // q{} );
      0        
198             }
199             }
200              
201 0           return join q{}, @encoded;
202             }
203             }
204              
205             sub _mime_encode {
206 0     0     my $self = shift;
207 0           my $text = shift;
208 0           my $charset = find_encoding(shift)->mime_name;
209              
210 0           my $head = '=?' . $charset . '?B?';
211 0           my $tail = '?=';
212              
213 0           my $base_length = 75 - ( length($head) + length($tail) );
214              
215             # This code is copied from Mail::Message::Field::Full in the Mail-Box
216             # distro.
217 0           my $real_length = int( $base_length / 4 ) * 3;
218              
219 0           my @result;
220 0           my $chunk = q{};
221 0           while ( length( my $chr = substr( $text, 0, 1, q{} ) ) ) {
222 0           my $chr = encode( $charset, $chr, 0 );
223              
224 0 0         if ( length($chunk) + length($chr) > $real_length ) {
225 0           push @result, $head . encode_base64( $chunk, q{} ) . $tail;
226 0           $chunk = q{};
227             }
228              
229 0           $chunk .= $chr;
230             }
231              
232 0 0         push @result, $head . encode_base64( $chunk, q{} ) . $tail
233             if length $chunk;
234              
235 0           return join q{ }, @result;
236             }
237              
238             __PACKAGE__->meta->make_immutable;
239              
240             1;
241              
242             # ABSTRACT: A single header's name and value
243              
244             __END__
245              
246             =pod
247              
248             =encoding UTF-8
249              
250             =head1 NAME
251              
252             Courriel::Header - A single header's name and value
253              
254             =head1 VERSION
255              
256             version 0.44
257              
258             =head1 SYNOPSIS
259              
260             my $subject = $headers->get('subject');
261             print $subject->value;
262              
263             =head1 DESCRIPTION
264              
265             This class represents a single header, which consists of a name and value.
266              
267             =head1 API
268              
269             This class supports the following methods:
270              
271             =head1 Courriel::Header->new( ... )
272              
273             This method requires two attributes, C<name> and C<value>. Both must be
274             strings. The C<name> cannot be empty, but the C<value> can.
275              
276             =head2 $header->name()
277              
278             The header name as passed to the constructor.
279              
280             =head2 $header->value()
281              
282             The header value as passed to the constructor.
283              
284             =head2 $header->as_string( charset => $charset )
285              
286             Returns the header name and value with any necessary MIME encoding and folding.
287              
288             The C<charset> parameter specifies what character set to use for MIME-encoding
289             non-ASCII values. This defaults to "utf8". The charset name must be one
290             recognized by the L<Encode> module.
291              
292             =head2 $header->stream_to( output => $output, charset => ... )
293              
294             This method will send the stringified header to the specified output. The
295             output can be a subroutine reference, a filehandle, or an object with a
296             C<print()> method. The output may be sent as a single string, as a list of
297             strings, or via multiple calls to the output.
298              
299             See the C<as_string()> method for documentation on the C<charset> parameter.
300              
301             =head1 ROLES
302              
303             This class does the C<Courriel::Role::Streams> role.
304              
305             =head1 SUPPORT
306              
307             Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=Courriel>
308             (or L<bug-courriel@rt.cpan.org|mailto:bug-courriel@rt.cpan.org>).
309              
310             I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
311              
312             =head1 AUTHOR
313              
314             Dave Rolsky <autarch@urth.org>
315              
316             =head1 COPYRIGHT AND LICENSE
317              
318             This software is Copyright (c) 2016 by Dave Rolsky.
319              
320             This is free software, licensed under:
321              
322             The Artistic License 2.0 (GPL Compatible)
323              
324             =cut