File Coverage

blib/lib/Mail/Header.pm
Criterion Covered Total %
statement 196 310 63.2
branch 69 168 41.0
condition 36 82 43.9
subroutine 24 31 77.4
pod 22 22 100.0
total 347 613 56.6


line stmt bran cond sub pod time code
1             # Copyrights 1995-2018 by [Mark Overmeer].
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              
9             package Mail::Header;
10 3     3   970 use vars '$VERSION';
  3         6  
  3         161  
11             $VERSION = '2.20';
12              
13              
14 3     3   17 use strict;
  3         6  
  3         54  
15 3     3   14 use Carp;
  3         5  
  3         11763  
16              
17             my $MAIL_FROM = 'KEEP';
18             my %HDR_LENGTHS = ();
19              
20             our $FIELD_NAME = '[^\x00-\x1f\x7f-\xff :]+:';
21              
22              
23             ##
24             ## Private functions
25             ##
26              
27 1     1   7 sub _error { warn @_; () }
  1         7  
28              
29             # tidy up internal hash table and list
30              
31             sub _tidy_header
32 0     0   0 { my $self = shift;
33 0         0 my $deleted = 0;
34              
35 0         0 for(my $i = 0 ; $i < @{$self->{mail_hdr_list}}; $i++)
  0         0  
36 0 0       0 { next if defined $self->{mail_hdr_list}[$i];
37              
38 0         0 splice @{$self->{mail_hdr_list}}, $i, 1;
  0         0  
39 0         0 $deleted++;
40 0         0 $i--;
41             }
42              
43 0 0       0 if($deleted)
44 0         0 { local $_;
45 0         0 my @del;
46              
47 0         0 while(my ($key,$ref) = each %{$self->{mail_hdr_hash}} )
  0         0  
48             { push @del, $key
49 0 0       0 unless @$ref = grep { ref $_ && defined $$_ } @$ref;
  0 0       0  
50             }
51              
52 0         0 delete $self->{'mail_hdr_hash'}{$_} for @del;
53             }
54             }
55              
56             # fold the line to the given length
57              
58             my %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              
71             sub _fold_line
72 27     27   43 { my($ln,$maxlen) = @_;
73              
74 27 50       50 $maxlen = 20
75             if $maxlen < 20;
76              
77 27         40 my $max = int($maxlen - 5); # 4 for leading spcs + 1 for [\,\;]
78 27         50 my $min = int($maxlen * 4 / 5) - 4;
79              
80 27         101 $_[0] =~ s/[\r\n]+//og; # Remove new-lines
81 27         191 $_[0] =~ s/\s*\Z/\n/so; # End line with an EOLN
82              
83 27 50       64 return if $_[0] =~ /^From\s/io;
84              
85 27 100       48 if(length($_[0]) > $maxlen)
86 14 100 66     68 { 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 9         13 my $x = "";
92 9         398 $x .= "$1\n " while $_[0] =~
93             s/^\s*
94             ( [^"]{$min,$max} [,;]
95             | [^"]{1,$max} [,;\s]
96             | [^\s"]*(?:"[^"]*"[ \t]?[^\s"]*)+\s
97             ) //x;
98              
99 9         19 $x .= $_[0];
100 9         15 $_[0] = $x;
101 9         119 $_[0] =~ s/(\A\s+|[\t ]+\Z)//sog;
102 9         51 $_[0] =~ s/\s+\n/\n/sog;
103             }
104             else
105 5         77 { $_[0] =~ s/(.{$min,$max})(\s)/$1\n$2/g;
106 5         45 $_[0] =~ s/\s*$/\n/s;
107             }
108             }
109              
110 27         80 $_[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              
121             sub _tag_case
122 61     61   73 { my $tag = shift;
123 61         121 $tag =~ s/\:$//;
124             join '-'
125 61 100       141 , map { /^[b-df-hj-np-tv-z]+$|^(?:MIME|SWE|SOAP|LDAP|ID)$/i
  69         364  
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              
136             sub _fmt_line
137 25     25   54 { my ($self, $tag, $line, $modify) = @_;
138 25   66     78 $modify ||= $self->{mail_hdr_modify};
139 25         34 my $ctag = undef;
140              
141 25 50       39 ($tag) = $line =~ /^($FIELD_NAME|From )/oi
142             unless defined $tag;
143              
144 25 50 66     142 if(defined $tag && $tag =~ /^From /io && $self->{mail_hdr_mail_from} ne 'KEEP')
      66        
145 0 0       0 { if($self->{mail_hdr_mail_from} eq 'COERCE')
    0          
    0          
146 0         0 { $line =~ s/^From /Mail-From: /o;
147 0         0 $tag = "Mail-From:";
148             }
149             elsif($self->{mail_hdr_mail_from} eq 'IGNORE')
150 0         0 { return ();
151             }
152             elsif($self->{mail_hdr_mail_from} eq 'ERROR')
153 0         0 { return _error "unadorned 'From ' ignored: <$line>";
154             }
155             }
156              
157 25 50       41 if(defined $tag)
158 25         50 { $tag = _tag_case($ctag = $tag);
159 25 100       51 $ctag = $tag if $modify;
160 25 50       105 $ctag =~ s/([^ :])$/$1:/o if defined $ctag;
161             }
162              
163 25 50 33     191 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 25 100 100     186 if(defined $ctag && ($modify || $line !~ /^\Q$ctag\E/i))
      66        
168 15         63 { (my $xtag = $ctag) =~ s/\s*\Z//o;
169 15         152 $line =~ s/^(\Q$ctag\E)?\s*/$xtag /i;
170             }
171              
172             my $maxlen = $self->{mail_hdr_lengths}{$tag}
173 25   33     120 || $HDR_LENGTHS{$tag}
174             || $self->fold_length;
175              
176 25 100 66     86 if ($modify && defined $maxlen)
    100          
177             { # folding will fix bad header continuations for us
178 9         13 _fold_line $line, $maxlen;
179             }
180             elsif($line =~ /\r?\n\S/)
181 1         5 { return _error "Bad header continuation, skipping '$tag': ",
182             "no space after newline in '$line'\n";
183             }
184              
185              
186 24         171 $line =~ s/\n*$/\n/so;
187 24         85 ($tag, $line);
188             }
189              
190             sub _insert
191 24     24   50 { my ($self, $tag, $line, $where) = @_;
192              
193 24 50       49 if($where < 0)
    0          
194 24         27 { $where = @{$self->{mail_hdr_list}} + $where + 1;
  24         45  
195 24 50       42 $where = 0 if $where < 0;
196             }
197 0         0 elsif($where >= @{$self->{mail_hdr_list}})
198 0         0 { $where = @{$self->{mail_hdr_list}};
  0         0  
199             }
200              
201 24         25 my $atend = $where == @{$self->{mail_hdr_list}};
  24         60  
202 24         29 splice @{$self->{mail_hdr_list}}, $where, 0, $line;
  24         55  
203              
204 24   100     111 $self->{mail_hdr_hash}{$tag} ||= [];
205 24         28 my $ref = \${$self->{mail_hdr_list}}[$where];
  24         51  
206              
207 24         36 my $def = $self->{mail_hdr_hash}{$tag};
208 24 100 66     66 if($def && $where)
209 18 50       30 { if($atend) { push @$def, $ref }
  18         44  
210             else
211 0         0 { my $i = 0;
212 0         0 foreach my $ln (@{$self->{mail_hdr_list}})
  0         0  
213 0         0 { my $r = \$ln;
214 0 0       0 last if $r == $ref;
215 0 0       0 $i++ if $r == $def->[$i];
216             }
217 0         0 splice @$def, $i, 0, $ref;
218             }
219             }
220             else
221 6         19 { unshift @$def, $ref;
222             }
223             }
224              
225             #------------
226              
227             sub new
228 11     11 1 131 { my $call = shift;
229 11   33     32 my $class = ref($call) || $call;
230 11 100       24 my $arg = @_ % 2 ? shift : undef;
231 11         20 my %opt = @_;
232              
233             $opt{Modify} = delete $opt{Reformat}
234 11 100       26 unless exists $opt{Modify};
235              
236             my $self = bless
237             { mail_hdr_list => []
238             , mail_hdr_hash => {}
239 11   100     62 , mail_hdr_modify => (delete $opt{Modify} || 0)
240             , mail_hdr_foldlen => 79
241             , mail_hdr_lengths => {}
242             }, $class;
243              
244 11   33     55 $self->mail_from( uc($opt{MailFrom} || $MAIL_FROM) );
245              
246             $self->fold_length($opt{FoldLength})
247 11 50       24 if exists $opt{FoldLength};
248              
249 11 100       28 if(!ref $arg) {}
    50          
    0          
250 5         12 elsif(ref($arg) eq 'ARRAY') { $self->extract( [ @$arg ] ) }
251 0         0 elsif(defined fileno($arg)) { $self->read($arg) }
252              
253 11         53 $self;
254             }
255              
256              
257             sub dup
258 2     2 1 4 { my $self = shift;
259 2         5 my $dup = ref($self)->new;
260              
261 2         13 %$dup = %$self;
262 2         16 $dup->empty; # rebuild tables
263              
264 2         3 $dup->{mail_hdr_list} = [ @{$self->{mail_hdr_list}} ];
  2         7  
265              
266 2         4 foreach my $ln ( @{$dup->{mail_hdr_list}} )
  2         6  
267 8         65 { my $tag = _tag_case +($ln =~ /^($FIELD_NAME|From )/oi)[0];
268 8         13 push @{$dup->{mail_hdr_hash}{$tag}}, \$ln;
  8         26  
269             }
270              
271 2         13 $dup;
272             }
273              
274             #------------
275              
276             sub extract
277 6     6 1 12 { my ($self, $lines) = @_;
278 6         12 $self->empty;
279              
280 6         13 while(@$lines)
281 21         31 { my $line = shift @$lines;
282 21 100       65 last if $line =~ /^\r?$/;
283              
284 19 50       107 $line =~ /^($FIELD_NAME|From )/o or next;
285 19         43 my $tag = $1;
286              
287 19   100     83 $line .= shift @$lines
288             while @$lines && $lines->[0] =~ /^[ \t]+/;
289              
290 19         35 ($tag, $line) = _fmt_line $self, $tag, $line;
291              
292 19 100       79 _insert $self, $tag, $line, -1
293             if defined $line;
294             }
295              
296 6         46 $self;
297             }
298              
299              
300             sub read
301 0     0 1 0 { my ($self, $fd) = @_;
302 0         0 $self->empty;
303              
304 0         0 my ($ln, $tag, $line);
305 0         0 while(1)
306 0         0 { $ln = <$fd>;
307              
308 0 0 0     0 if(defined $ln && defined $line && $ln =~ /^[ \t]+/)
      0        
309 0         0 { $line .= $ln; # folded line
310 0         0 next;
311             }
312              
313 0 0       0 if(defined $line)
314 0         0 { ($tag, $line) = _fmt_line $self, $tag, $line;
315 0 0       0 _insert $self, $tag, $line, -1
316             if defined $line;
317 0         0 ($tag, $line) = ();
318             }
319              
320 0 0 0     0 last if !defined $ln || $ln =~ m/^\r?$/;
321              
322 0 0       0 $ln =~ /^($FIELD_NAME|From )/o or next;
323 0         0 ($tag, $line) = ($1, $ln);
324             }
325              
326 0         0 $self;
327             }
328              
329              
330             sub empty
331 8     8 1 12 { my $self = shift;
332 8         15 $self->{mail_hdr_list} = [];
333 8         13 $self->{mail_hdr_hash} = {};
334 8         11 $self;
335             }
336              
337              
338             sub header
339 1     1 1 2 { my $self = shift;
340              
341 1 50       5 $self->extract(@_)
342             if @_;
343              
344             $self->fold
345 1 50       6 if $self->{mail_hdr_modify};
346              
347 1         2 [ @{$self->{mail_hdr_list}} ];
  1         5  
348             }
349              
350              
351             sub header_hashref
352 2     2 1 20 { my ($self, $hashref) = @_;
353              
354 2         9 while(my ($key, $value) = each %$hashref)
355 2 100       6 { $self->add($key, $_) for ref $value ? @$value : $value;
356             }
357              
358             $self->fold
359 2 50       4 if $self->{mail_hdr_modify};
360              
361             defined wantarray # MO, added minimal optimization
362 2 100       5 or return;
363              
364 3         6 +{ map { ($_ => [$self->get($_)] ) } # MO: Eh?
365 1         2 keys %{$self->{mail_hdr_hash}}
  1         3  
366             };
367             }
368              
369             #------------
370              
371             sub modify
372 3     3 1 5 { my $self = shift;
373 3         5 my $old = $self->{mail_hdr_modify};
374              
375 3 50       8 $self->{mail_hdr_modify} = 0 + shift
376             if @_;
377              
378 3         6 $old;
379             }
380              
381              
382             sub mail_from
383 11     11 1 13 { my $thing = shift;
384 11         20 my $choice = uc shift;
385              
386 11 50       50 $choice =~ /^(IGNORE|ERROR|COERCE|KEEP)$/
387             or die "bad Mail-From choice: '$choice'";
388              
389 11 50       21 if(ref $thing) { $thing->{mail_hdr_mail_from} = $choice }
  11         30  
390 0         0 else { $MAIL_FROM = $choice }
391              
392 11         18 $thing;
393             }
394              
395              
396             sub fold_length
397 28     28 1 39 { my $thing = shift;
398 28         33 my $old;
399              
400 28 50       48 if(@_ == 2)
401 0         0 { my $tag = _tag_case shift;
402 0         0 my $len = shift;
403              
404 0 0       0 my $hash = ref $thing ? $thing->{mail_hdr_lengths} : \%HDR_LENGTHS;
405 0         0 $old = $hash->{$tag};
406 0 0       0 $hash->{$tag} = $len > 20 ? $len : 20;
407             }
408             else
409 28         36 { my $self = $thing;
410 28         34 my $len = shift;
411 28         35 $old = $self->{mail_hdr_foldlen};
412              
413 28 100       63 if(defined $len)
414 3 50       7 { $self->{mail_hdr_foldlen} = $len > 20 ? $len : 20;
415 3 50       8 $self->fold if $self->{mail_hdr_modify};
416             }
417             }
418              
419 28         58 $old;
420             }
421              
422             #------------
423              
424             sub fold
425 3     3 1 24 { my ($self, $maxlen) = @_;
426              
427 3         3 while(my ($tag, $list) = each %{$self->{mail_hdr_hash}})
  12         35  
428             { my $len = $maxlen
429             || $self->{mail_hdr_lengths}{$tag}
430 9   0     16 || $HDR_LENGTHS{$tag}
431             || $self->fold_length;
432              
433 9         13 foreach my $ln (@$list)
434 18 50       39 { _fold_line $$ln, $len
435             if defined $ln;
436             }
437             }
438              
439 3         7 $self;
440             }
441              
442              
443             sub unfold
444 1     1 1 5 { my $self = shift;
445              
446 1 50       4 if(@_)
447 0         0 { my $tag = _tag_case shift;
448 0 0       0 my $list = $self->{mail_hdr_hash}{$tag}
449             or return $self;
450              
451 0         0 foreach my $ln (@$list)
452 0 0 0     0 { $$ln =~ s/\r?\n\s+/ /sog
453             if defined $ln && defined $$ln;
454             }
455              
456 0         0 return $self;
457             }
458              
459 1         2 while( my ($tag, $list) = each %{$self->{mail_hdr_hash}})
  4         12  
460 3         4 { foreach my $ln (@$list)
461 6 50 33     28 { $$ln =~ s/\r?\n\s+/ /sog
462             if defined $ln && defined $$ln;
463             }
464             }
465              
466 1         2 $self;
467             }
468              
469              
470             sub add
471 6     6 1 22 { my ($self, $tag, $text, $where) = @_;
472 6         10 ($tag, my $line) = _fmt_line $self, $tag, $text;
473              
474 6 50 33     19 defined $tag && defined $line
475             or return undef;
476              
477 6 50       11 defined $where
478             or $where = -1;
479              
480 6         13 _insert $self, $tag, $line, $where;
481              
482 6         15 $line =~ /^\S+\s(.*)/os;
483 6         18 $1;
484             }
485              
486              
487             sub replace
488 0     0 1 0 { my $self = shift;
489 0 0       0 my $idx = @_ % 2 ? pop @_ : 0;
490              
491 0         0 my ($tag, $line);
492             TAG:
493 0         0 while(@_)
494 0         0 { ($tag,$line) = _fmt_line $self, splice(@_,0,2);
495              
496 0 0 0     0 defined $tag && defined $line
497             or return undef;
498              
499 0         0 my $field = $self->{mail_hdr_hash}{$tag};
500 0 0 0     0 if($field && defined $field->[$idx])
501 0         0 { ${$field->[$idx]} = $line }
  0         0  
502 0         0 else { _insert $self, $tag, $line, -1 }
503             }
504              
505 0         0 $line =~ /^\S+\s*(.*)/os;
506 0         0 $1;
507             }
508              
509              
510             sub combine
511 0     0 1 0 { my $self = shift;
512 0         0 my $tag = _tag_case shift;
513 0   0     0 my $with = shift || ' ';
514              
515 0 0 0     0 $tag =~ /^From /io && $self->{mail_hdr_mail_from} ne 'KEEP'
516             and return _error "unadorned 'From ' ignored";
517              
518 0 0       0 my $def = $self->{mail_hdr_hash}{$tag}
519             or return undef;
520              
521 0 0       0 return $def->[0]
522             if @$def <= 1;
523              
524 0         0 my @lines = $self->get($tag);
525 0         0 chomp @lines;
526              
527 0         0 my $line = (_fmt_line $self, $tag, join($with,@lines), 1)[1];
528              
529 0         0 $self->{mail_hdr_hash}{$tag} = [ \$line ];
530 0         0 $line;
531             }
532              
533              
534             sub get
535 26     26 1 145 { my $self = shift;
536 26         34 my $tag = _tag_case shift;
537 26         48 my $idx = shift;
538              
539 26 100       50 my $def = $self->{mail_hdr_hash}{$tag}
540             or return ();
541              
542 23         28 my $l = length $tag;
543 23 50       37 $l += 1 if $tag !~ / $/o;
544              
545 23 100 100     49 if(defined $idx || !wantarray)
546 20   100     43 { $idx ||= 0;
547 20 50       27 defined $def->[$idx] or return undef;
548 20         21 my $val = ${$def->[$idx]};
  20         23  
549 20 50       29 defined $val or return undef;
550              
551 20         31 $val = substr $val, $l;
552 20         48 $val =~ s/^\s+//;
553 20         45 return $val;
554             }
555              
556 3         5 map { my $tmp = substr $$_,$l; $tmp =~ s/^\s+//; $tmp } @$def;
  6         8  
  6         20  
  6         25  
557             }
558              
559              
560              
561             sub count
562 0     0 1 0 { my $self = shift;
563 0         0 my $tag = _tag_case shift;
564 0         0 my $def = $self->{mail_hdr_hash}{$tag};
565 0 0       0 defined $def ? scalar(@$def) : 0;
566             }
567              
568              
569              
570             sub delete
571 2     2 1 3 { my $self = shift;
572 2         5 my $tag = _tag_case shift;
573 2         14 my $idx = shift;
574 2         5 my @val;
575              
576 2 50       14 if(my $def = $self->{mail_hdr_hash}{$tag})
577 0         0 { my $l = length $tag;
578 0 0       0 $l += 2 if $tag !~ / $/;
579              
580 0 0       0 if(defined $idx)
581 0 0       0 { if(defined $def->[$idx])
582 0         0 { push @val, substr ${$def->[$idx]}, $l;
  0         0  
583 0         0 undef ${$def->[$idx]};
  0         0  
584             }
585             }
586             else
587 0         0 { @val = map {my $x = substr $$_,$l; undef $$_; $x } @$def;
  0         0  
  0         0  
  0         0  
588             }
589              
590 0         0 _tidy_header($self);
591             }
592              
593 2         6 @val;
594             }
595              
596              
597              
598             sub print
599 1     1 1 4 { my $self = shift;
600 1   50     4 my $fd = shift || \*STDOUT;
601              
602 1         2 foreach my $ln (@{$self->{mail_hdr_list}})
  1         2  
603 6 50       10 { defined $ln or next;
604 6 50       9 print $fd $ln or return 0;
605             }
606              
607 1         2 1;
608             }
609              
610              
611 6     6 1 21 sub as_string { join '', grep {defined} @{shift->{mail_hdr_list}} }
  28         68  
  6         15  
612              
613              
614 0     0 1   sub tags { keys %{shift->{mail_hdr_hash}} }
  0            
615              
616              
617             sub cleanup
618 0     0 1   { my $self = shift;
619 0           my $deleted = 0;
620              
621 0 0         foreach my $key (@_ ? @_ : keys %{$self->{mail_hdr_hash}})
  0            
622 0           { my $fields = $self->{mail_hdr_hash}{$key};
623 0           foreach my $field (@$fields)
624 0 0         { next if $$field =~ /^\S+\s+\S/s;
625 0           undef $$field;
626 0           $deleted++;
627             }
628             }
629              
630 0 0         _tidy_header $self
631             if $deleted;
632              
633 0           $self;
634             }
635              
636             1;