File Coverage

blib/lib/Courriel/Helpers.pm
Criterion Covered Total %
statement 47 72 65.2
branch 7 22 31.8
condition 3 5 60.0
subroutine 10 13 76.9
pod 0 4 0.0
total 67 116 57.7


line stmt bran cond sub pod time code
1             package Courriel::Helpers;
2              
3 10     10   45 use strict;
  10         15  
  10         348  
4 10     10   43 use warnings;
  10         14  
  10         512  
5              
6             our $VERSION = '0.44';
7              
8 10     10   7290 use Encode qw( decode );
  10         108569  
  10         1078  
9 10     10   82 use Exporter qw( import );
  10         17  
  10         401  
10 10     10   5491 use List::AllUtils qw( first );
  10         84732  
  10         7611  
11              
12             our @EXPORT_OK = qw(
13             fold_header
14             parse_header_with_attributes
15             quote_and_escape_attribute_value
16             unique_boundary
17             );
18              
19             our $CRLF = "\x0d\x0a";
20              
21             # from Email::Simple
22             our $LINE_SEP_RE = qr/(?:\x0a\x0d|\x0d\x0a|\x0a|\x0d)/;
23              
24             sub fold_header {
25 0     0 0 0 my $line = shift;
26              
27 0         0 my $folded = q{};
28              
29             # Algorithm stolen from Email::Simple::Header
30 0         0 while ( length $line ) {
31 0 0       0 if ( $line =~ s/^(.{0,76})(\s|\z)// ) {
32 0         0 $folded .= $1 . $CRLF;
33 0 0       0 $folded .= q{ } if length $line;
34             }
35             else {
36              
37             # Basically nothing we can do. :(
38 0         0 $folded .= $line . $CRLF;
39 0         0 last;
40             }
41             }
42              
43 0         0 return $folded;
44             }
45              
46             sub quote_and_escape_attribute_value {
47 0     0 0 0 my $val = shift;
48              
49 0 0       0 return $val unless $val =~ /[^a-zA-Z0-9\-]/;
50              
51 0         0 $val =~ s/(\\|")/\\$1/g;
52              
53 0         0 return qq{"$val"};
54             }
55              
56             sub parse_header_with_attributes {
57 209     209 0 326 my $text = shift;
58              
59 209 50       645 return unless defined $text;
60              
61 209         1578 my ($val) = $text =~ /([^\s;]+)(?:\s*;\s*(.*))?\z/s;
62              
63             ## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
64             return (
65 209         624 $val,
66             _parse_attributes($2),
67             );
68             }
69              
70             our $TSPECIALS = qr{\Q()<>@,;:\"/[]?=};
71              
72             my $extract_quoted = qr/
73             (?:
74             \"
75             (?<quoted_value>
76             [^\\\"]*
77             (?:
78             \\.[^\\\"]*
79             )*
80             )
81             \"
82             |
83             \'
84             (?<quoted_value>
85             [^\\\']*
86             (?:
87             \\.[^\\\']*
88             )*
89             )
90             \'
91             )
92             /x;
93              
94             # This is a very loose regex. RFC 2231 has a much tighter definition of what
95             # can go in an attribute name, but this parser is designed to accept all the
96             # crap the internet throws at it.
97             my $attr_re = qr/
98             (?<name>[^\s=\*]+) # names cannot include spaces, "=", or "*"
99             (?:
100             \*(?<order>[\d+])
101             )?
102             (?<is_encoded>\*)?
103             =
104             (?:
105             $extract_quoted
106             |
107             (?<value>[^\s;]+) # unquoted values cannot contain spaces
108             )
109             (\s*;\s*)?
110             /xs;
111              
112             sub _parse_attributes {
113 209     209   475 my $attr_text = shift;
114              
115 209 100 66     1332 return {} unless defined $attr_text && length $attr_text;
116              
117 127         317 my $attrs = {};
118              
119 127         2313 while ( $attr_text =~ /\G$attr_re/g ) {
120 10     10   6473 my $name = $+{name};
  10         4835  
  10         6154  
  151         1381  
121              
122 151         329 my $value;
123             my $charset;
124 0         0 my $language;
125              
126 151   50     955 my $order = $+{order} || 0;
127              
128 151 50       1660 if ( $+{is_encoded} ) {
    100          
129 0 0       0 if ($order) {
130             $value = _decode_raw_value(
131             $+{value},
132             $attrs->{$name}[$order]{charset},
133 0         0 );
134             }
135             else {
136 0         0 ( $charset, $language, my $raw ) = split /\'/, $+{value}, 3;
137 0 0       0 $language = undef unless length $language;
138              
139 0         0 $value = _decode_raw_value( $raw, $charset );
140             }
141             }
142             elsif ( defined $+{quoted_value} ) {
143 81         429 ( $value = $+{quoted_value} ) =~ s/\G(.*?)\\(.)/$1$2/g;
144             }
145             else {
146 70         355 $value = $+{value};
147             }
148              
149 151         1968 $attrs->{$name}[$order] = {
150             value => $value,
151             charset => $charset,
152             language => $language,
153             };
154             }
155              
156             return {
157 151         453 map { $_ => _inflate_attribute( $_, $attrs->{$_} ) }
158 127         198 keys %{$attrs}
  127         425  
159             };
160             }
161              
162             sub _decode_raw_value {
163 0     0   0 my $raw = shift;
164 0         0 my $charset = shift;
165              
166 0         0 $raw =~ s/%([\da-fA-F]{2})/chr(hex($1))/eg;
  0         0  
167              
168 0 0       0 return $raw unless defined $charset;
169              
170 0         0 return decode( $charset, $raw );
171             }
172              
173             sub _inflate_attribute {
174 151     151   268 my $name = shift;
175 151         180 my $raw_data = shift;
176              
177 151         207 my $value = join q{}, grep {defined} map { $_->{value} } @{$raw_data};
  151         566  
  151         397  
  151         238  
178              
179 151         550 my %p = (
180             name => $_,
181             value => $value,
182             );
183              
184 151         342 for my $key (qw( charset language )) {
185             $p{$key} = $raw_data->[0]{$key}
186 302 50       849 if defined $raw_data->[0]{$key};
187             }
188              
189 151         6805 return Courriel::HeaderAttribute->new(%p);
190             }
191              
192             sub unique_boundary {
193 2     2 0 11 return Email::MessageID->new->user;
194             }
195              
196             # Courriel::HeaderAttribute requires that $TSPECIALS be defined
197             require Courriel::HeaderAttribute;
198              
199             1;