← 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/Mail/Header.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::Header::::BEGIN@10Mail::Header::BEGIN@10
0000s0sMail::Header::::BEGIN@14Mail::Header::BEGIN@14
0000s0sMail::Header::::BEGIN@15Mail::Header::BEGIN@15
0000s0sMail::Header::::_errorMail::Header::_error
0000s0sMail::Header::::_fmt_lineMail::Header::_fmt_line
0000s0sMail::Header::::_fold_lineMail::Header::_fold_line
0000s0sMail::Header::::_insertMail::Header::_insert
0000s0sMail::Header::::_tag_caseMail::Header::_tag_case
0000s0sMail::Header::::_tidy_headerMail::Header::_tidy_header
0000s0sMail::Header::::addMail::Header::add
0000s0sMail::Header::::as_stringMail::Header::as_string
0000s0sMail::Header::::cleanupMail::Header::cleanup
0000s0sMail::Header::::combineMail::Header::combine
0000s0sMail::Header::::countMail::Header::count
0000s0sMail::Header::::deleteMail::Header::delete
0000s0sMail::Header::::dupMail::Header::dup
0000s0sMail::Header::::emptyMail::Header::empty
0000s0sMail::Header::::extractMail::Header::extract
0000s0sMail::Header::::foldMail::Header::fold
0000s0sMail::Header::::fold_lengthMail::Header::fold_length
0000s0sMail::Header::::getMail::Header::get
0000s0sMail::Header::::headerMail::Header::header
0000s0sMail::Header::::header_hashrefMail::Header::header_hashref
0000s0sMail::Header::::mail_fromMail::Header::mail_from
0000s0sMail::Header::::modifyMail::Header::modify
0000s0sMail::Header::::newMail::Header::new
0000s0sMail::Header::::printMail::Header::print
0000s0sMail::Header::::readMail::Header::read
0000s0sMail::Header::::replaceMail::Header::replace
0000s0sMail::Header::::tagsMail::Header::tags
0000s0sMail::Header::::unfoldMail::Header::unfold
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1# Copyrights 1995-2019 by [Mark Overmeer <markov@cpan.org>].
2# For other contributors see ChangeLog.
3# See the manual pages for details on the licensing terms.
4# Pod stripped from pm file by OODoc 2.02.
5# This code is part of the bundle MailTools. Meta-POD processed with
6# OODoc into POD and HTML manual-pages. See README.md for Copyright.
7# Licensed under the same terms as Perl itself.
8
9package Mail::Header;
10use vars '$VERSION';
11$VERSION = '2.21';
12
13
14use strict;
15use Carp;
16
17my $MAIL_FROM = 'KEEP';
18my %HDR_LENGTHS = ();
19
20our $FIELD_NAME = '[^\x00-\x1f\x7f-\xff :]+:';
21
22
23##
24## Private functions
25##
26
27sub _error { warn @_; () }
28
29# tidy up internal hash table and list
30
31sub _tidy_header
32{ my $self = shift;
33 my $deleted = 0;
34
35 for(my $i = 0 ; $i < @{$self->{mail_hdr_list}}; $i++)
36 { next if defined $self->{mail_hdr_list}[$i];
37
38 splice @{$self->{mail_hdr_list}}, $i, 1;
39 $deleted++;
40 $i--;
41 }
42
43 if($deleted)
44 { local $_;
45 my @del;
46
47 while(my ($key,$ref) = each %{$self->{mail_hdr_hash}} )
48 { push @del, $key
49 unless @$ref = grep { ref $_ && defined $$_ } @$ref;
50 }
51
52 delete $self->{'mail_hdr_hash'}{$_} for @del;
53 }
54}
55
56# fold the line to the given length
57
58my %STRUCTURE = map { (lc $_ => undef) }
59 qw{ To Cc Bcc From Date Reply-To Sender
60 Resent-Date Resent-From Resent-Sender Resent-To Return-Path
61 list-help list-post list-unsubscribe Mailing-List
62 Received References Message-ID In-Reply-To
63 Content-Length Content-Type Content-Disposition
64 Delivered-To
65 Lines
66 MIME-Version
67 Precedence
68 Status
69 };
70
71sub _fold_line
72{ my($ln,$maxlen) = @_;
73
74 $maxlen = 20
75 if $maxlen < 20;
76
77 my $max = int($maxlen - 5); # 4 for leading spcs + 1 for [\,\;]
78 my $min = int($maxlen * 4 / 5) - 4;
79
80 $_[0] =~ s/[\r\n]+//og; # Remove new-lines
81 $_[0] =~ s/\s*\Z/\n/so; # End line with an EOLN
82
83 return if $_[0] =~ /^From\s/io;
84
85 if(length($_[0]) > $maxlen)
86 { if($_[0] =~ /^([-\w]+)/ && exists $STRUCTURE{ lc $1 } )
87 { #Split the line up
88 # first bias towards splitting at a , or a ; >4/5 along the line
89 # next split a whitespace
90 # else we are looking at a single word and probably don't want to split
91 my $x = "";
92 $x .= "$1\n " while $_[0] =~
93 s/^\s*
94 ( [^"]{$min,$max} [,;]
95 | [^"]{1,$max} [,;\s]
96 | [^\s"]*(?:"[^"]*"[ \t]?[^\s"]*)+\s
97 ) //x;
98
99 $x .= $_[0];
100 $_[0] = $x;
101 $_[0] =~ s/(\A\s+|[\t ]+\Z)//sog;
102 $_[0] =~ s/\s+\n/\n/sog;
103 }
104 else
105 { $_[0] =~ s/(.{$min,$max})(\s)/$1\n$2/g;
106 $_[0] =~ s/\s*$/\n/s;
107 }
108 }
109
110 $_[0] =~ s/\A(\S+)\n\s*(?=\S)/$1 /so;
111}
112
113# Tags are case-insensitive, but there is a (slightly) preferred construction
114# being all characters are lowercase except the first of each word. Also
115# if the word is an `acronym' then all characters are uppercase. We decide
116# a word is an acronym if it does not contain a vowel.
117# In general, this change of capitalization is a bad idea, but it is in
118# the code for ages, and therefore probably crucial for existing
119# applications.
120
121sub _tag_case
122{ my $tag = shift;
123 $tag =~ s/\:$//;
124 join '-'
125 , map { /^[b-df-hj-np-tv-z]+$|^(?:MIME|SWE|SOAP|LDAP|ID)$/i
126 ? uc($_) : ucfirst(lc($_))
127 } split m/\-/, $tag, -1;
128}
129
130# format a complete line
131# ensure line starts with the given tag
132# ensure tag is correct case
133# change the 'From ' tag as required
134# fold the line
135
136sub _fmt_line
137{ my ($self, $tag, $line, $modify) = @_;
138 $modify ||= $self->{mail_hdr_modify};
139 my $ctag = undef;
140
141 ($tag) = $line =~ /^($FIELD_NAME|From )/oi
142 unless defined $tag;
143
144 if(defined $tag && $tag =~ /^From /io && $self->{mail_hdr_mail_from} ne 'KEEP')
145 { if($self->{mail_hdr_mail_from} eq 'COERCE')
146 { $line =~ s/^From /Mail-From: /o;
147 $tag = "Mail-From:";
148 }
149 elsif($self->{mail_hdr_mail_from} eq 'IGNORE')
150 { return ();
151 }
152 elsif($self->{mail_hdr_mail_from} eq 'ERROR')
153 { return _error "unadorned 'From ' ignored: <$line>";
154 }
155 }
156
157 if(defined $tag)
158 { $tag = _tag_case($ctag = $tag);
159 $ctag = $tag if $modify;
160 $ctag =~ s/([^ :])$/$1:/o if defined $ctag;
161 }
162
163 defined $ctag && $ctag =~ /^($FIELD_NAME|From )/oi
164 or croak "Bad RFC822 field name '$tag'\n";
165
166 # Ensure the line starts with tag
167 if(defined $ctag && ($modify || $line !~ /^\Q$ctag\E/i))
168 { (my $xtag = $ctag) =~ s/\s*\Z//o;
169 $line =~ s/^(\Q$ctag\E)?\s*/$xtag /i;
170 }
171
172 my $maxlen = $self->{mail_hdr_lengths}{$tag}
173 || $HDR_LENGTHS{$tag}
174 || $self->fold_length;
175
176 if ($modify && defined $maxlen)
177 { # folding will fix bad header continuations for us
178 _fold_line $line, $maxlen;
179 }
180 elsif($line =~ /\r?\n\S/)
181 { return _error "Bad header continuation, skipping '$tag': ",
182 "no space after newline in '$line'\n";
183 }
184
185
186 $line =~ s/\n*$/\n/so;
187 ($tag, $line);
188}
189
190sub _insert
191{ my ($self, $tag, $line, $where) = @_;
192
193 if($where < 0)
194 { $where = @{$self->{mail_hdr_list}} + $where + 1;
195 $where = 0 if $where < 0;
196 }
197 elsif($where >= @{$self->{mail_hdr_list}})
198 { $where = @{$self->{mail_hdr_list}};
199 }
200
201 my $atend = $where == @{$self->{mail_hdr_list}};
202 splice @{$self->{mail_hdr_list}}, $where, 0, $line;
203
204 $self->{mail_hdr_hash}{$tag} ||= [];
205 my $ref = \${$self->{mail_hdr_list}}[$where];
206
207 my $def = $self->{mail_hdr_hash}{$tag};
208 if($def && $where)
209 { if($atend) { push @$def, $ref }
210 else
211 { my $i = 0;
212 foreach my $ln (@{$self->{mail_hdr_list}})
213 { my $r = \$ln;
214 last if $r == $ref;
215 $i++ if $r == $def->[$i];
216 }
217 splice @$def, $i, 0, $ref;
218 }
219 }
220 else
221 { unshift @$def, $ref;
222 }
223}
224
225#------------
226
227sub new
228{ my $call = shift;
229 my $class = ref($call) || $call;
230 my $arg = @_ % 2 ? shift : undef;
231 my %opt = @_;
232
233 $opt{Modify} = delete $opt{Reformat}
234 unless exists $opt{Modify};
235
236 my $self = bless
237 { mail_hdr_list => []
238 , mail_hdr_hash => {}
239 , mail_hdr_modify => (delete $opt{Modify} || 0)
240 , mail_hdr_foldlen => 79
241 , mail_hdr_lengths => {}
242 }, $class;
243
244 $self->mail_from( uc($opt{MailFrom} || $MAIL_FROM) );
245
246 $self->fold_length($opt{FoldLength})
247 if exists $opt{FoldLength};
248
249 if(!ref $arg) {}
250 elsif(ref($arg) eq 'ARRAY') { $self->extract( [ @$arg ] ) }
251 elsif(defined fileno($arg)) { $self->read($arg) }
252
253 $self;
254}
255
256
257sub dup
258{ my $self = shift;
259 my $dup = ref($self)->new;
260
261 %$dup = %$self;
262 $dup->empty; # rebuild tables
263
264 $dup->{mail_hdr_list} = [ @{$self->{mail_hdr_list}} ];
265
266 foreach my $ln ( @{$dup->{mail_hdr_list}} )
267 { my $tag = _tag_case +($ln =~ /^($FIELD_NAME|From )/oi)[0];
268 push @{$dup->{mail_hdr_hash}{$tag}}, \$ln;
269 }
270
271 $dup;
272}
273
274#------------
275
276sub extract
277{ my ($self, $lines) = @_;
278 $self->empty;
279
280 while(@$lines)
281 { my $line = shift @$lines;
282 last if $line =~ /^\r?$/;
283
284 $line =~ /^($FIELD_NAME|From )/o or next;
285 my $tag = $1;
286
287 $line .= shift @$lines
288 while @$lines && $lines->[0] =~ /^[ \t]+/;
289
290 ($tag, $line) = _fmt_line $self, $tag, $line;
291
292 _insert $self, $tag, $line, -1
293 if defined $line;
294 }
295
296 $self;
297}
298
299
300sub read
301{ my ($self, $fd) = @_;
302 $self->empty;
303
304 my ($ln, $tag, $line);
305 while(1)
306 { $ln = <$fd>;
307
308 if(defined $ln && defined $line && $ln =~ /^[ \t]+/)
309 { $line .= $ln; # folded line
310 next;
311 }
312
313 if(defined $line)
314 { ($tag, $line) = _fmt_line $self, $tag, $line;
315 _insert $self, $tag, $line, -1
316 if defined $line;
317 ($tag, $line) = ();
318 }
319
320 last if !defined $ln || $ln =~ m/^\r?$/;
321
322 $ln =~ /^($FIELD_NAME|From )/o or next;
323 ($tag, $line) = ($1, $ln);
324 }
325
326 $self;
327}
328
329
330sub empty
331{ my $self = shift;
332 $self->{mail_hdr_list} = [];
333 $self->{mail_hdr_hash} = {};
334 $self;
335}
336
337
338sub header
339{ my $self = shift;
340
341 $self->extract(@_)
342 if @_;
343
344 $self->fold
345 if $self->{mail_hdr_modify};
346
347 [ @{$self->{mail_hdr_list}} ];
348}
349
350
351sub header_hashref
352{ my ($self, $hashref) = @_;
353
354 while(my ($key, $value) = each %$hashref)
355 { $self->add($key, $_) for ref $value ? @$value : $value;
356 }
357
358 $self->fold
359 if $self->{mail_hdr_modify};
360
361 defined wantarray # MO, added minimal optimization
362 or return;
363
364 +{ map { ($_ => [$self->get($_)] ) } # MO: Eh?
365 keys %{$self->{mail_hdr_hash}}
366 };
367}
368
369#------------
370
371sub modify
372{ my $self = shift;
373 my $old = $self->{mail_hdr_modify};
374
375 $self->{mail_hdr_modify} = 0 + shift
376 if @_;
377
378 $old;
379}
380
381
382sub mail_from
383{ my $thing = shift;
384 my $choice = uc shift;
385
386 $choice =~ /^(IGNORE|ERROR|COERCE|KEEP)$/
387 or die "bad Mail-From choice: '$choice'";
388
389 if(ref $thing) { $thing->{mail_hdr_mail_from} = $choice }
390 else { $MAIL_FROM = $choice }
391
392 $thing;
393}
394
395
396sub fold_length
397{ my $thing = shift;
398 my $old;
399
400 if(@_ == 2)
401 { my $tag = _tag_case shift;
402 my $len = shift;
403
404 my $hash = ref $thing ? $thing->{mail_hdr_lengths} : \%HDR_LENGTHS;
405 $old = $hash->{$tag};
406 $hash->{$tag} = $len > 20 ? $len : 20;
407 }
408 else
409 { my $self = $thing;
410 my $len = shift;
411 $old = $self->{mail_hdr_foldlen};
412
413 if(defined $len)
414 { $self->{mail_hdr_foldlen} = $len > 20 ? $len : 20;
415 $self->fold if $self->{mail_hdr_modify};
416 }
417 }
418
419 $old;
420}
421
422#------------
423
424sub fold
425{ my ($self, $maxlen) = @_;
426
427 while(my ($tag, $list) = each %{$self->{mail_hdr_hash}})
428 { my $len = $maxlen
429 || $self->{mail_hdr_lengths}{$tag}
430 || $HDR_LENGTHS{$tag}
431 || $self->fold_length;
432
433 foreach my $ln (@$list)
434 { _fold_line $$ln, $len
435 if defined $ln;
436 }
437 }
438
439 $self;
440}
441
442
443sub unfold
444{ my $self = shift;
445
446 if(@_)
447 { my $tag = _tag_case shift;
448 my $list = $self->{mail_hdr_hash}{$tag}
449 or return $self;
450
451 foreach my $ln (@$list)
452 { $$ln =~ s/\r?\n\s+/ /sog
453 if defined $ln && defined $$ln;
454 }
455
456 return $self;
457 }
458
459 while( my ($tag, $list) = each %{$self->{mail_hdr_hash}})
460 { foreach my $ln (@$list)
461 { $$ln =~ s/\r?\n\s+/ /sog
462 if defined $ln && defined $$ln;
463 }
464 }
465
466 $self;
467}
468
469
470sub add
471{ my ($self, $tag, $text, $where) = @_;
472 ($tag, my $line) = _fmt_line $self, $tag, $text;
473
474 defined $tag && defined $line
475 or return undef;
476
477 defined $where
478 or $where = -1;
479
480 _insert $self, $tag, $line, $where;
481
482 $line =~ /^\S+\s(.*)/os;
483 $1;
484}
485
486
487sub replace
488{ my $self = shift;
489 my $idx = @_ % 2 ? pop @_ : 0;
490
491 my ($tag, $line);
492 TAG:
493 while(@_)
494 { ($tag,$line) = _fmt_line $self, splice(@_,0,2);
495
496 defined $tag && defined $line
497 or return undef;
498
499 my $field = $self->{mail_hdr_hash}{$tag};
500 if($field && defined $field->[$idx])
501 { ${$field->[$idx]} = $line }
502 else { _insert $self, $tag, $line, -1 }
503 }
504
505 $line =~ /^\S+\s*(.*)/os;
506 $1;
507}
508
509
510sub combine
511{ my $self = shift;
512 my $tag = _tag_case shift;
513 my $with = shift || ' ';
514
515 $tag =~ /^From /io && $self->{mail_hdr_mail_from} ne 'KEEP'
516 and return _error "unadorned 'From ' ignored";
517
518 my $def = $self->{mail_hdr_hash}{$tag}
519 or return undef;
520
521 return $def->[0]
522 if @$def <= 1;
523
524 my @lines = $self->get($tag);
525 chomp @lines;
526
527 my $line = (_fmt_line $self, $tag, join($with,@lines), 1)[1];
528
529 $self->{mail_hdr_hash}{$tag} = [ \$line ];
530 $line;
531}
532
533
534sub get
535{ my $self = shift;
536 my $tag = _tag_case shift;
537 my $idx = shift;
538
539 my $def = $self->{mail_hdr_hash}{$tag}
540 or return ();
541
542 my $l = length $tag;
543 $l += 1 if $tag !~ / $/o;
544
545 if(defined $idx || !wantarray)
546 { $idx ||= 0;
547 defined $def->[$idx] or return undef;
548 my $val = ${$def->[$idx]};
549 defined $val or return undef;
550
551 $val = substr $val, $l;
552 $val =~ s/^\s+//;
553 return $val;
554 }
555
556 map { my $tmp = substr $$_,$l; $tmp =~ s/^\s+//; $tmp } @$def;
557}
558
- -
561sub count
562{ my $self = shift;
563 my $tag = _tag_case shift;
564 my $def = $self->{mail_hdr_hash}{$tag};
565 defined $def ? scalar(@$def) : 0;
566}
567
- -
570sub delete
571{ my $self = shift;
572 my $tag = _tag_case shift;
573 my $idx = shift;
574 my @val;
575
576 if(my $def = $self->{mail_hdr_hash}{$tag})
577 { my $l = length $tag;
578 $l += 2 if $tag !~ / $/;
579
580 if(defined $idx)
581 { if(defined $def->[$idx])
582 { push @val, substr ${$def->[$idx]}, $l;
583 undef ${$def->[$idx]};
584 }
585 }
586 else
587 { @val = map {my $x = substr $$_,$l; undef $$_; $x } @$def;
588 }
589
590 _tidy_header($self);
591 }
592
593 @val;
594}
595
- -
598sub print
599{ my $self = shift;
600 my $fd = shift || \*STDOUT;
601
602 foreach my $ln (@{$self->{mail_hdr_list}})
603 { defined $ln or next;
604 print $fd $ln or return 0;
605 }
606
607 1;
608}
609
610
611sub as_string { join '', grep {defined} @{shift->{mail_hdr_list}} }
612
613
614sub tags { keys %{shift->{mail_hdr_hash}} }
615
616
617sub cleanup
618{ my $self = shift;
619 my $deleted = 0;
620
621 foreach my $key (@_ ? @_ : keys %{$self->{mail_hdr_hash}})
622 { my $fields = $self->{mail_hdr_hash}{$key};
623 foreach my $field (@$fields)
624 { next if $$field =~ /^\S+\s+\S/s;
625 undef $$field;
626 $deleted++;
627 }
628 }
629
630 _tidy_header $self
631 if $deleted;
632
633 $self;
634}
635
6361;