File Coverage

blib/lib/Courriel/HeaderAttribute.pm
Criterion Covered Total %
statement 75 75 100.0
branch 18 18 100.0
condition 7 8 87.5
subroutine 14 14 100.0
pod n/a
total 114 115 99.1


line stmt bran cond sub pod time code
1             package Courriel::HeaderAttribute;
2              
3 10     10   105209 use strict;
  10         40  
  10         335  
4 10     10   44 use warnings;
  10         14  
  10         333  
5 10     10   915 use namespace::autoclean;
  10         28062  
  10         83  
6              
7             our $VERSION = '0.44';
8              
9 10     10   1085 use Courriel::HeaderAttribute;
  10         26  
  10         352  
10 10     10   797 use Courriel::Helpers qw( quote_and_escape_attribute_value );
  10         18  
  10         783  
11 10     10   3357 use Courriel::Types qw( Maybe NonEmptyStr Str );
  10         27  
  10         87  
12 10     10   73630 use Encode qw( encode );
  10         18  
  10         775  
13              
14 10     10   57 use Moose;
  10         14  
  10         94  
15 10     10   68436 use MooseX::StrictConstructor;
  10         147966  
  10         66  
16              
17             with 'Courriel::Role::Streams';
18              
19             has name => (
20             is => 'ro',
21             isa => NonEmptyStr,
22             required => 1,
23             );
24              
25             has value => (
26             is => 'ro',
27             isa => Str,
28             required => 1,
29             );
30              
31             has charset => (
32             is => 'ro',
33             isa => NonEmptyStr,
34             default => 'us-ascii',
35             );
36              
37             has language => (
38             is => 'ro',
39             isa => Maybe [NonEmptyStr],
40             default => undef,
41             );
42              
43             override BUILDARGS => sub {
44             my $class = shift;
45              
46             my $p = super();
47              
48             return $p unless defined $p->{value};
49              
50             $p->{charset} = 'UTF-8' if $p->{value} =~ /[^\p{ASCII}]/;
51              
52             return $p;
53             };
54              
55             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
56             sub _stream_to {
57 10     10   22 my $self = shift;
58 10         17 my $output = shift;
59              
60 10         40 $output->( $self->_as_string );
61             }
62             ## use critic
63              
64             {
65             my $non_attribute_char = qr{
66             $Courriel::Helpers::TSPECIALS
67             |
68             [ \*\%] # space, *, %
69             |
70             [^\p{ASCII}] # anything that's not ascii
71             |
72             [\x00-\x1f\x7f] # ctrl chars
73             }x;
74              
75             sub _as_string {
76 10     10   17 my $self = shift;
77              
78 10         456 my $value = $self->value;
79              
80 10         27 my $transport_method = '_simple_parameter';
81              
82 10 100 100     505 if ( $value =~ /[\x00-\x1f]|\x7f|[^\p{ASCII}]/
    100 66        
83             || defined $self->language
84             || $self->charset ne 'us-ascii' ) {
85              
86 4         26 $value = encode( 'utf-8', $value );
87 4         592 $value
88 110         656 =~ s/($non_attribute_char)/'%' . uc sprintf( '%02x', ord($1) )/eg;
89              
90 4         15 $transport_method = '_encoded_parameter';
91             }
92             elsif ( $value =~ /$non_attribute_char/ ) {
93 3         9 $transport_method = '_quoted_parameter';
94             }
95              
96             # XXX - hard code 78 as the max line length may not be right. Should
97             # this account for the length that the parameter name takes up (as
98             # well as encoding information, etc.)?
99              
100 10         20 my @pieces;
101 10         39 while ( length $value ) {
102 15         41 my $last_percent = rindex( $value, '%', 78 );
103              
104 15 100       59 my $size
    100          
105             = $last_percent >= 76 ? $last_percent
106             : length $value > 78 ? 78
107             : length $value;
108              
109 15         91 push @pieces, substr( $value, 0, $size, q{} );
110             }
111              
112 10 100       30 if ( @pieces == 1 ) {
113 7         45 return $self->$transport_method( undef, $pieces[0] );
114             }
115             else {
116             return join q{ },
117 3         15 map { $self->$transport_method( $_, $pieces[$_] ) }
  8         36  
118             0 .. $#pieces;
119             }
120             }
121             }
122              
123             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
124             sub _simple_parameter {
125 4     4   7 my $self = shift;
126 4         5 my $order = shift;
127 4         9 my $value = shift;
128              
129 4         205 my $param = $self->name;
130 4 100       20 $param .= q{*} . $order if defined $order;
131 4         8 $param .= q{=};
132 4         10 $param .= $value;
133              
134 4         31 return $param;
135             }
136              
137             sub _quoted_parameter {
138 4     4   7 my $self = shift;
139 4         8 my $order = shift;
140 4         7 my $value = shift;
141              
142 4         188 my $param = $self->name;
143 4 100       20 $param .= q{*} . $order if defined $order;
144 4         9 $param .= q{=};
145              
146 4         13 $value =~ s/\"/\\\"/g;
147              
148 4         14 $param .= q{"} . $value . q{"};
149              
150 4         28 return $param;
151             }
152              
153             sub _encoded_parameter {
154 7     7   13 my $self = shift;
155 7         11 my $order = shift;
156 7         14 my $value = shift;
157              
158 7         360 my $param = $self->name;
159 7 100       31 $param .= q{*} . $order if defined $order;
160 7         16 $param .= q{*=};
161              
162             # XXX (1) - does it makes sense to just say everything is utf-8? in theory
163             # someone could pass through binary data in another encoding.
164 7 100       22 unless ($order) {
165 4   100     198 $param .= 'UTF-8' . q{'} . ( $self->language // q{} ) . q{'};
166             }
167              
168 7         18 $param .= $value;
169              
170 7         46 return $param;
171             }
172             ## use critic;
173              
174             __PACKAGE__->meta->make_immutable;
175              
176             1;
177              
178             # ABSTRACT: A single attribute belonging to a header
179              
180             __END__
181              
182             =pod
183              
184             =encoding UTF-8
185              
186             =head1 NAME
187              
188             Courriel::HeaderAttribute - A single attribute belonging to a header
189              
190             =head1 VERSION
191              
192             version 0.44
193              
194             =head1 SYNOPSIS
195              
196             my $ct = $headers->get('Content-Type');
197             print $ct->get_attribute('charset')->value;
198              
199             =head1 DESCRIPTION
200              
201             This class represents a single attribute belonging to a header. An attribute
202             consists of a name and value, with optional charset and language information.
203              
204             =head1 API
205              
206             This class supports the following methods:
207              
208             =head1 Courriel::HeaderAttribute->new( ... )
209              
210             This method creates a new object. It accepts the following parameters:
211              
212             =over 4
213              
214             =item * name
215              
216             The name of the attribute. This should be a non-empty string.
217              
218             =item * value
219              
220             The value of the attribute. This can be empty.
221              
222             =item * charset
223              
224             The charset for the value. If the value contains any non-ASCII data, this will
225             always be "UTF-8", otherwise the default is "us-ascii".
226              
227             =item * language
228              
229             The language for the attribute's value. It should be a valid ISO language code
230             like "en-us" or "zh". This is optional.
231              
232             =back
233              
234             =head2 $attribute->name()
235              
236             The attribute name as passed to the constructor.
237              
238             =head2 $attribute->value()
239              
240             The attribute value as passed to the constructor.
241              
242             =head2 $attribute->charset()
243              
244             The attribute's charset.
245              
246             =head2 $attribute->language()
247              
248             The attribute's language.
249              
250             =head2 $attribute->as_string()
251              
252             This returns the attribute in a form suitable for putting in an email. This
253             may involve escaping, quoting, splitting up, and otherwise messing with the
254             value.
255              
256             If the value needs to be split across continuations, each name/value pair is
257             returned separate by a space, but not folded across multiple lines.
258              
259             =head2 $attribute->stream_to( output => $output )
260              
261             This method will send the stringified attribute to the specified output. The
262             output can be a subroutine reference, a filehandle, or an object with a
263             C<print()> method. The output may be sent as a single string, as a list of
264             strings, or via multiple calls to the output.
265              
266             =head1 ROLES
267              
268             This class does the C<Courriel::Role::Streams> role.
269              
270             =head1 SUPPORT
271              
272             Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=Courriel>
273             (or L<bug-courriel@rt.cpan.org|mailto:bug-courriel@rt.cpan.org>).
274              
275             I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
276              
277             =head1 AUTHOR
278              
279             Dave Rolsky <autarch@urth.org>
280              
281             =head1 COPYRIGHT AND LICENSE
282              
283             This software is Copyright (c) 2016 by Dave Rolsky.
284              
285             This is free software, licensed under:
286              
287             The Artistic License 2.0 (GPL Compatible)
288              
289             =cut