← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:12 2021

Filename/usr/local/lib/perl5/site_perl/MIME/Field/ParamVal.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMIME::Field::ParamVal::::BEGIN@3MIME::Field::ParamVal::BEGIN@3
0000s0sMIME::Field::ParamVal::::BEGIN@62MIME::Field::ParamVal::BEGIN@62
0000s0sMIME::Field::ParamVal::::BEGIN@63MIME::Field::ParamVal::BEGIN@63
0000s0sMIME::Field::ParamVal::::BEGIN@64MIME::Field::ParamVal::BEGIN@64
0000s0sMIME::Field::ParamVal::::BEGIN@68MIME::Field::ParamVal::BEGIN@68
0000s0sMIME::Field::ParamVal::::BEGIN@71MIME::Field::ParamVal::BEGIN@71
0000s0sMIME::Field::ParamVal::::paramMIME::Field::ParamVal::param
0000s0sMIME::Field::ParamVal::::paramstrMIME::Field::ParamVal::paramstr
0000s0sMIME::Field::ParamVal::::parseMIME::Field::ParamVal::parse
0000s0sMIME::Field::ParamVal::::parse_paramsMIME::Field::ParamVal::parse_params
0000s0sMIME::Field::ParamVal::::rfc2231decodeMIME::Field::ParamVal::rfc2231decode
0000s0sMIME::Field::ParamVal::::rfc2231percentMIME::Field::ParamVal::rfc2231percent
0000s0sMIME::Field::ParamVal::::setMIME::Field::ParamVal::set
0000s0sMIME::Field::ParamVal::::stringifyMIME::Field::ParamVal::stringify
0000s0sMIME::Field::ParamVal::::tagMIME::Field::ParamVal::tag
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package MIME::Field::ParamVal;
2
3use MIME::Words;
4
5=head1 NAME
6
7MIME::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
37This is an abstract superclass of most MIME fields. It handles
38fields 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
44Comments are supported I<between> 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
59require 5.001;
60
61# Pragmas:
62use strict;
63use re 'taint';
64use vars qw($VERSION @ISA);
65
66
67# Other modules:
68use Mail::Field;
69
70# Kit modules:
71use MIME::Tools qw(:config :msgs);
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.509";
84
85
86#------------------------------
87#
88# Private globals...
89#
90#------------------------------
91
92# Pattern to match parameter names (like fieldnames, but = not allowed):
93my $PARAMNAME = '[^\x00-\x1f\x80-\xff :=]+';
94
95# Pattern to match the first value on the line:
96my $FIRST = '[^\s\;\x00-\x1f\x80-\xff]*';
97
98# Pattern to match an RFC 2045 token:
99#
100# token = 1*<any (ASCII) CHAR except SPACE, CTLs, or tspecials>
101#
102my $TSPECIAL = '()<>@,;:\</[]?="';
103
104#" Fix emacs highlighting...
105
106my $TOKEN = '[^ \x00-\x1f\x80-\xff' . "\Q$TSPECIAL\E" . ']+';
107
108my $QUOTED_STRING = '"([^\\\\"]*(?:\\\\.(?:[^\\\\"]*))*)"';
109
110# Encoded token:
111my $ENCTOKEN = "=\\?[^?]*\\?[A-Za-z]\\?[^?]+\\?=";
112
113# Pattern to match spaces or comments:
114my $SPCZ = '(?:\s|\([^\)]*\))*';
115
116# Pattern to match non-semicolon as fallback for broken MIME
117# produced by some viruses
118my $BADTOKEN = '[^;]+';
119
120#------------------------------
121#
122# Class init...
123#
124#------------------------------
125
126#------------------------------
127
128=item set [\%PARAMHASH | KEY=>VAL,...,KEY=>VAL]
129
130I<Instance method.> Set this field.
131The paramhash should contain parameter names
132in I<all lowercase>, with the special C<"_"> parameter name
133signifying 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
144Note that a single argument is taken to be a I<reference> to
145a paramhash, while multiple args are taken to be the elements
146of the paramhash themselves.
147
148Supplying undef for a hashref, or an empty set of values, effectively
149clears the object.
150
151The self object is returned.
152
153=cut
154
155sub set {
156 my $self = shift;
157 my $params = ((@_ == 1) ? (shift || {}) : {@_});
158 %$self = %$params; # set 'em
159 $self;
160}
161
162#------------------------------
163
164=item parse_params STRING
165
166I<Class/instance utility method.>
167Extract parameter info from a structured field, and return
168it 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
174Here 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
183Like field names, parameter names are coerced to lowercase.
184The special '_' parameter means the default parameter for the
185field.
186
187B<NOTE:> This has been provided as a public method to support backwards
188compatibility, but you probably shouldn't use it.
189
190=cut
191
192sub rfc2231decode {
193 my($val) = @_;
194 my($enc, $lang, $rest);
195
196 local($1,$2,$3);
197 if ($val =~ m/^([^']*)'([^']*)'(.*)\z/s) {
198 $enc = $1;
199 $lang = $2;
200 $rest = $3;
201 } elsif ($val =~ m/^([^']*)'([^']*)\z/s) {
202 $enc = $1;
203 $rest = $2;
204 } else {
205 $rest = $val;
206 # $enc remains undefined when charset/language info is missing
207 }
208 return ($enc, $lang, $rest);
209}
210
211sub rfc2231percent {
212 # Do percent-substitution
213 my($str) = @_;
214 local $1;
215 $str =~ s/%([0-9a-fA-F]{2})/pack("C", hex($1))/ge;
216 return $str;
217}
218
219sub parse_params {
220 my ($self, $raw) = @_;
221 my %params;
222 my %rfc2231params;
223 my %rfc2231encoding_is_used;
224 my $param;
225 my $val;
226 my $part;
227
228 # Get raw field, and unfold it:
229 defined($raw) or $raw = '';
230 $raw =~ s/\n//g;
231 $raw =~ s/\s+\z//; # Strip trailing whitespace
232
233 local($1,$2,$3,$4,$5);
234 # Extract special first parameter:
235 $raw =~ m/\A$SPCZ($FIRST)$SPCZ/og or return {}; # nada!
236 $params{'_'} = $1;
237
238 # Extract subsequent parameters.
239 # No, we can't just "split" on semicolons: they're legal in quoted strings!
240 while (1) { # keep chopping away until done...
241 $raw =~ m/\G[^;]*(\;$SPCZ)+/og or last; # skip leading separator
242 $raw =~ m/\G($PARAMNAME)\s*=\s*/og or last; # give up if not a param
243 $param = lc($1);
244 $raw =~ m/\G(?:$QUOTED_STRING|($ENCTOKEN)|($TOKEN)|($BADTOKEN))/g or last; # give up if no value"
245 my ($qstr, $enctoken, $token, $badtoken) = ($1, $2, $3, $4, $5);
246 if (defined($qstr)) {
247 # unescape
248 $qstr =~ s/\\(.)/$1/g;
249 }
250 if (defined($badtoken)) {
251 # Strip leading/trailing whitespace from badtoken
252 $badtoken =~ s/^\s+//;
253 $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 $badtoken =~ /^($TOKEN)*/;
258 $badtoken = $1;
259 # Cut it off at first whitespace too
260 $badtoken =~ s/\s.*//;
261 }
262 $val = defined($qstr) ? $qstr :
263 (defined($enctoken) ? $enctoken :
264 (defined($badtoken) ? $badtoken : $token));
265
266 # Do RFC 2231 processing
267 # Pick out the parts of the parameter
268 if ($param =~ /\*/ &&
269 $param =~ /^ ([^*]+) (?: \* ([^*]+) )? (\*)? \z/xs) {
270 # We have param*number* or param*number or param*
271 my($name, $num) = ($1, $2||0);
272 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 $val = rfc2231percent($val);
278 $rfc2231encoding_is_used{$name} = 1;
279 }
280 $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 $params{$param} = $val;
287 }
288 }
289
290 # Extract reconstructed parameters
291 foreach $param (keys %rfc2231params) {
292 # If we got any rfc-2231 parameters, then
293 # blow away any potential non-rfc-2231 parameter.
294 $params{$param} = '';
295 foreach $part (sort { $a <=> $b } keys %{$rfc2231params{$param}}) {
296 $params{$param} .= $rfc2231params{$param}{$part};
297 }
298 if ($rfc2231encoding_is_used{$param}) {
299 my($enc, $lang, $val) = rfc2231decode($params{$param});
300 if (defined $enc) {
301 # re-encode as QP, preserving charset and language info
302 $val =~ s{([=?_\x00-\x1F\x7F-\xFF])}
303 {sprintf("=%02X", ord($1))}eg;
304 $val =~ tr/ /_/;
305 # RFC 2231 section 5: Language specification in Encoded Words
306 $enc .= '*' . $lang if defined $lang && $lang ne '';
307 $params{$param} = '=?' . $enc . '?Q?' . $val . '?=';
308 }
309 }
310 debug " field param <$param> = <$params{$param}>";
311 }
312
313 # Done:
314 \%params;
315}
316
317#------------------------------
318
319=item parse STRING
320
321I<Class/instance method.>
322Parse the string into the instance. Any previous information is wiped.
323The self object is returned.
324
325May also be used as a constructor.
326
327=cut
328
329sub parse {
330 my ($self, $string) = @_;
331
332 # Allow use as constructor, for MIME::Head:
333 ref($self) or $self = bless({}, $self);
334
335 # Get params, and stuff them into the self object:
336 $self->set($self->parse_params($string));
337}
338
339#------------------------------
340
341=item param PARAMNAME,[VALUE]
342
343I<Instance method.>
344Return the given parameter, or undef if it isn't there.
345With argument, set the parameter to that VALUE.
346The PARAMNAME is case-insensitive. A "_" refers to the "default" parameter.
347
348=cut
349
350sub param {
351 my ($self, $paramname, $value) = @_;
352 $paramname = lc($paramname);
353 $self->{$paramname} = $value if (@_ > 2);
354 $self->{$paramname}
355}
356
357#------------------------------
358
359=item paramstr PARAMNAME,[VALUE]
360
361I<Instance method.>
362Like param(): return the given parameter, or I<empty> if it isn't there.
363With argument, set the parameter to that VALUE.
364The PARAMNAME is case-insensitive. A "_" refers to the "default" parameter.
365
366=cut
367
368sub paramstr {
369 my $val = shift->param(@_);
370 (defined($val) ? $val : '');
371}
372
373#------------------------------
374
375=item stringify
376
377I<Instance method.>
378Convert the field to a string, and return it.
379
380=cut
381
382sub stringify {
383 my $self = shift;
384 my ($key, $val);
385
386 my $str = $self->{'_'}; # default subfield
387 foreach $key (sort keys %$self) {
388 next if ($key !~ /^[a-z][a-z-_0-9]*$/); # only lowercase ones!
389 defined($val = $self->{$key}) or next;
390 $val =~ s/(["\\])/\\$1/g;
391 $str .= qq{; $key="$val"};
392 }
393 $str;
394}
395
396#------------------------------
397
398=item tag
399
400I<Instance method, abstract.>
401Return the tag for this field.
402
403=cut
404
405sub tag { '' }
406
407=back
408
409=head1 SEE ALSO
410
411L<Mail::Field>
412
413=cut
414
415#------------------------------
4161;