File Coverage

blib/lib/MIME/Field/ParamVal.pm
Criterion Covered Total %
statement 94 107 87.8
branch 34 46 73.9
condition 6 10 60.0
subroutine 14 15 93.3
pod 7 9 77.7
total 155 187 82.8


line stmt bran cond sub pod time code
1             package MIME::Field::ParamVal;
2              
3 23     23   115120 use MIME::Words;
  23         27  
  23         1048  
4              
5             =head1 NAME
6              
7             MIME::Field::ParamVal - subclass of Mail::Field, for structured MIME fields
8              
9              
10             =head1 SYNOPSIS
11              
12             # Create an object for a content-type field:
13             $field = new Mail::Field 'Content-type';
14              
15             # Set some attributes:
16             $field->param('_' => 'text/html');
17             $field->param('charset' => 'us-ascii');
18             $field->param('boundary' => '---ABC---');
19              
20             # Same:
21             $field->set('_' => 'text/html',
22             'charset' => 'us-ascii',
23             'boundary' => '---ABC---');
24              
25             # Get an attribute, or undefined if not present:
26             print "no id!" if defined($field->param('id'));
27              
28             # Same, but use empty string for missing values:
29             print "no id!" if ($field->paramstr('id') eq '');
30              
31             # Output as string:
32             print $field->stringify, "\n";
33              
34              
35             =head1 DESCRIPTION
36              
37             This is an abstract superclass of most MIME fields. It handles
38             fields with a general syntax like this:
39              
40             Content-Type: Message/Partial;
41             number=2; total=3;
42             id="oc=jpbe0M2Yt4s@thumper.bellcore.com"
43              
44             Comments are supported I items, like this:
45              
46             Content-Type: Message/Partial; (a comment)
47             number=2 (another comment) ; (yet another comment) total=3;
48             id="oc=jpbe0M2Yt4s@thumper.bellcore.com"
49              
50              
51             =head1 PUBLIC INTERFACE
52              
53             =over 4
54              
55             =cut
56              
57             #------------------------------
58              
59             require 5.001;
60              
61             # Pragmas:
62 23     23   83 use strict;
  23         26  
  23         466  
63 23     23   68 use re 'taint';
  23         31  
  23         728  
64 23     23   73 use vars qw($VERSION @ISA);
  23         24  
  23         942  
65              
66              
67             # Other modules:
68 23     23   1313 use Mail::Field;
  23         7573  
  23         110  
69              
70             # Kit modules:
71 23     23   1309305 use MIME::Tools qw(:config :msgs);
  23         37  
  23         24076  
72              
73             @ISA = qw(Mail::Field);
74              
75              
76             #------------------------------
77             #
78             # Public globals...
79             #
80             #------------------------------
81              
82             # The package version, both in 1.23 style *and* usable by MakeMaker:
83             $VERSION = "5.508";
84              
85              
86             #------------------------------
87             #
88             # Private globals...
89             #
90             #------------------------------
91              
92             # Pattern to match parameter names (like fieldnames, but = not allowed):
93             my $PARAMNAME = '[^\x00-\x1f\x80-\xff :=]+';
94              
95             # Pattern to match the first value on the line:
96             my $FIRST = '[^\s\;\x00-\x1f\x80-\xff]*';
97              
98             # Pattern to match an RFC 2045 token:
99             #
100             # token = 1*
101             #
102             my $TSPECIAL = '()<>@,;:\
103              
104             #" Fix emacs highlighting...
105              
106             my $TOKEN = '[^ \x00-\x1f\x80-\xff' . "\Q$TSPECIAL\E" . ']+';
107              
108             my $QUOTED_STRING = '"([^\\\\"]*(?:\\\\.(?:[^\\\\"]*))*)"';
109              
110             # Encoded token:
111             my $ENCTOKEN = "=\\?[^?]*\\?[A-Za-z]\\?[^?]+\\?=";
112              
113             # Pattern to match spaces or comments:
114             my $SPCZ = '(?:\s|\([^\)]*\))*';
115              
116             # Pattern to match non-semicolon as fallback for broken MIME
117             # produced by some viruses
118             my $BADTOKEN = '[^;]+';
119              
120             #------------------------------
121             #
122             # Class init...
123             #
124             #------------------------------
125              
126             #------------------------------
127              
128             =item set [\%PARAMHASH | KEY=>VAL,...,KEY=>VAL]
129              
130             I Set this field.
131             The paramhash should contain parameter names
132             in I, with the special C<"_"> parameter name
133             signifying the "default" (unnamed) parameter for the field:
134              
135             # Set up to be...
136             #
137             # Content-type: Message/Partial; number=2; total=3; id="ocj=pbe0M2"
138             #
139             $conttype->set('_' => 'Message/Partial',
140             'number' => 2,
141             'total' => 3,
142             'id' => "ocj=pbe0M2");
143              
144             Note that a single argument is taken to be a I to
145             a paramhash, while multiple args are taken to be the elements
146             of the paramhash themselves.
147              
148             Supplying undef for a hashref, or an empty set of values, effectively
149             clears the object.
150              
151             The self object is returned.
152              
153             =cut
154              
155             sub set {
156 1675     1675 1 3583 my $self = shift;
157 1675 50 50     3793 my $params = ((@_ == 1) ? (shift || {}) : {@_});
158 1675         3912 %$self = %$params; # set 'em
159 1675         3296 $self;
160             }
161              
162             #------------------------------
163              
164             =item parse_params STRING
165              
166             I
167             Extract parameter info from a structured field, and return
168             it as a hash reference. For example, here is a field with parameters:
169              
170             Content-Type: Message/Partial;
171             number=2; total=3;
172             id="oc=jpbe0M2Yt4s@thumper.bellcore.com"
173              
174             Here is how you'd extract them:
175              
176             $params = $class->parse_params('content-type');
177             if ($$params{'_'} eq 'message/partial') {
178             $number = $$params{'number'};
179             $total = $$params{'total'};
180             $id = $$params{'id'};
181             }
182              
183             Like field names, parameter names are coerced to lowercase.
184             The special '_' parameter means the default parameter for the
185             field.
186              
187             B This has been provided as a public method to support backwards
188             compatibility, but you probably shouldn't use it.
189              
190             =cut
191              
192             sub rfc2231decode {
193 8     8 0 5 my($val) = @_;
194 8         7 my($enc, $lang, $rest);
195              
196 8         16 local($1,$2,$3);
197 8 50       22 if ($val =~ m/^([^']*)'([^']*)'(.*)\z/s) {
    0          
198 8         10 $enc = $1;
199 8         8 $lang = $2;
200 8         9 $rest = $3;
201             } elsif ($val =~ m/^([^']*)'([^']*)\z/s) {
202 0         0 $enc = $1;
203 0         0 $rest = $2;
204             } else {
205 0         0 $rest = $val;
206             # $enc remains undefined when charset/language info is missing
207             }
208 8         19 return ($enc, $lang, $rest);
209             }
210              
211             sub rfc2231percent {
212             # Do percent-substitution
213 8     8 0 8 my($str) = @_;
214 8         10 local $1;
215 8         23 $str =~ s/%([0-9a-fA-F]{2})/pack("C", hex($1))/ge;
  51         104  
216 8         18 return $str;
217             }
218              
219             sub parse_params {
220 1625     1625 1 1313 my ($self, $raw) = @_;
221 1625         1087 my %params;
222             my %rfc2231params;
223 0         0 my %rfc2231encoding_is_used;
224 0         0 my $param;
225 0         0 my $val;
226 0         0 my $part;
227              
228             # Get raw field, and unfold it:
229 1625 100       2323 defined($raw) or $raw = '';
230 1625         2399 $raw =~ s/\n//g;
231 1625         2202 $raw =~ s/\s+\z//; # Strip trailing whitespace
232              
233 1625         5110 local($1,$2,$3,$4,$5);
234             # Extract special first parameter:
235 1625 50       8041 $raw =~ m/\A$SPCZ($FIRST)$SPCZ/og or return {}; # nada!
236 1625         3121 $params{'_'} = $1;
237              
238             # Extract subsequent parameters.
239             # No, we can't just "split" on semicolons: they're legal in quoted strings!
240 1625         1300 while (1) { # keep chopping away until done...
241 2453 100       5886 $raw =~ m/\G[^;]*(\;$SPCZ)+/og or last; # skip leading separator
242 839 100       2116 $raw =~ m/\G($PARAMNAME)\s*=\s*/og or last; # give up if not a param
243 828         1190 $param = lc($1);
244 828 50       5071 $raw =~ m/\G(?:$QUOTED_STRING|($ENCTOKEN)|($TOKEN)|($BADTOKEN))/g or last; # give up if no value"
245 828         1581 my ($qstr, $enctoken, $token, $badtoken) = ($1, $2, $3, $4, $5);
246 828 100       1240 if (defined($qstr)) {
247             # unescape
248 467         558 $qstr =~ s/\\(.)/$1/g;
249             }
250 828 50       1058 if (defined($badtoken)) {
251             # Strip leading/trailing whitespace from badtoken
252 0         0 $badtoken =~ s/^\s+//;
253 0         0 $badtoken =~ s/\s+\z//;
254              
255             # Only keep token parameters in badtoken;
256             # cut it off at the first non-token char. CPAN RT #105455
257 0         0 $badtoken =~ /^($TOKEN)*/;
258 0         0 $badtoken = $1;
259             # Cut it off at first whitespace too
260 0         0 $badtoken =~ s/\s.*//;
261             }
262 828 50       1415 $val = defined($qstr) ? $qstr :
    100          
    100          
263             (defined($enctoken) ? $enctoken :
264             (defined($badtoken) ? $badtoken : $token));
265              
266             # Do RFC 2231 processing
267             # Pick out the parts of the parameter
268 828 100 66     1565 if ($param =~ /\*/ &&
269             $param =~ /^ ([^*]+) (?: \* ([^*]+) )? (\*)? \z/xs) {
270             # We have param*number* or param*number or param*
271 16   100     55 my($name, $num) = ($1, $2||0);
272 16 100       26 if (defined($3)) {
273             # We have param*number* or param*
274             # RFC 2231: Asterisks ("*") are reused to provide the
275             # indicator that language and character set information
276             # is present and encoding is being used
277 8         12 $val = rfc2231percent($val);
278 8         10 $rfc2231encoding_is_used{$name} = 1;
279             }
280 16         64 $rfc2231params{$name}{$num} .= $val;
281             } else {
282             # Assign non-rfc2231 value directly. If we
283             # did get a mix of rfc2231 and non-rfc2231 values,
284             # the non-rfc2231 will be blown away in the
285             # "extract reconstructed parameters" loop.
286 812         1395 $params{$param} = $val;
287             }
288             }
289              
290             # Extract reconstructed parameters
291 1625         2705 foreach $param (keys %rfc2231params) {
292             # If we got any rfc-2231 parameters, then
293             # blow away any potential non-rfc-2231 parameter.
294 12         14 $params{$param} = '';
295 12         10 foreach $part (sort { $a <=> $b } keys %{$rfc2231params{$param}}) {
  4         10  
  12         36  
296 16         28 $params{$param} .= $rfc2231params{$param}{$part};
297             }
298 12 100       22 if ($rfc2231encoding_is_used{$param}) {
299 8         15 my($enc, $lang, $val) = rfc2231decode($params{$param});
300 8 50       15 if (defined $enc) {
301             # re-encode as QP, preserving charset and language info
302 8         18 $val =~ s{([=?_\x00-\x1F\x7F-\xFF])}
303 23         53 {sprintf("=%02X", ord($1))}eg;
304 8         11 $val =~ tr/ /_/;
305             # RFC 2231 section 5: Language specification in Encoded Words
306 8 50 33     30 $enc .= '*' . $lang if defined $lang && $lang ne '';
307 8         18 $params{$param} = '=?' . $enc . '?Q?' . $val . '?=';
308             }
309             }
310 12         46 debug " field param <$param> = <$params{$param}>";
311             }
312              
313             # Done:
314 1625         5576 \%params;
315             }
316              
317             #------------------------------
318              
319             =item parse STRING
320              
321             I
322             Parse the string into the instance. Any previous information is wiped.
323             The self object is returned.
324              
325             May also be used as a constructor.
326              
327             =cut
328              
329             sub parse {
330 1619     1619 1 36736 my ($self, $string) = @_;
331              
332             # Allow use as constructor, for MIME::Head:
333 1619 100       3638 ref($self) or $self = bless({}, $self);
334              
335             # Get params, and stuff them into the self object:
336 1619         2335 $self->set($self->parse_params($string));
337             }
338              
339             #------------------------------
340              
341             =item param PARAMNAME,[VALUE]
342              
343             I
344             Return the given parameter, or undef if it isn't there.
345             With argument, set the parameter to that VALUE.
346             The PARAMNAME is case-insensitive. A "_" refers to the "default" parameter.
347              
348             =cut
349              
350             sub param {
351 1717     1717 1 2584 my ($self, $paramname, $value) = @_;
352 1717         1489 $paramname = lc($paramname);
353 1717 100       2392 $self->{$paramname} = $value if (@_ > 2);
354 1717         6166 $self->{$paramname}
355             }
356              
357             #------------------------------
358              
359             =item paramstr PARAMNAME,[VALUE]
360              
361             I
362             Like param(): return the given parameter, or I if it isn't there.
363             With argument, set the parameter to that VALUE.
364             The PARAMNAME is case-insensitive. A "_" refers to the "default" parameter.
365              
366             =cut
367              
368             sub paramstr {
369 88     88 1 147 my $val = shift->param(@_);
370 88 50       236 (defined($val) ? $val : '');
371             }
372              
373             #------------------------------
374              
375             =item stringify
376              
377             I
378             Convert the field to a string, and return it.
379              
380             =cut
381              
382             sub stringify {
383 62     62 1 54 my $self = shift;
384 62         48 my ($key, $val);
385              
386 62         60 my $str = $self->{'_'}; # default subfield
387 62         232 foreach $key (sort keys %$self) {
388 112 100       313 next if ($key !~ /^[a-z][a-z-_0-9]*$/); # only lowercase ones!
389 50 50       83 defined($val = $self->{$key}) or next;
390 50         65 $val =~ s/(["\\])/\\$1/g;
391 50         128 $str .= qq{; $key="$val"};
392             }
393 62         216 $str;
394             }
395              
396             #------------------------------
397              
398             =item tag
399              
400             I
401             Return the tag for this field.
402              
403             =cut
404              
405 0     0 1   sub tag { '' }
406              
407             =back
408              
409             =head1 SEE ALSO
410              
411             L
412              
413             =cut
414              
415             #------------------------------
416             1;