File Coverage

blib/lib/Email/MIME/Header.pm
Criterion Covered Total %
statement 66 73 90.4
branch 14 22 63.6
condition n/a
subroutine 15 16 93.7
pod 1 7 14.2
total 96 118 81.3


line stmt bran cond sub pod time code
1 20     20   152 use strict;
  20         43  
  20         640  
2 20     20   101 use warnings;
  20         119  
  20         935  
3             package Email::MIME::Header;
4             # ABSTRACT: the header of a MIME message
5             $Email::MIME::Header::VERSION = '1.952';
6 20     20   528 use parent 'Email::Simple::Header';
  20         346  
  20         157  
7              
8 20     20   6996 use Carp ();
  20         39  
  20         337  
9 20     20   105 use Email::MIME::Encode;
  20         41  
  20         546  
10 20     20   95 use Encode 1.9801;
  20         354  
  20         1625  
11 20     20   10212 use Module::Runtime ();
  20         31276  
  20         2445  
12              
13             our @CARP_NOT;
14              
15             our %header_to_class_map;
16              
17             BEGIN {
18 20     20   105 my @address_list_headers = qw(from sender reply-to to cc bcc);
19 20         57 push @address_list_headers, map { "resent-$_" } @address_list_headers;
  120         305  
20 20         55 push @address_list_headers, map { "downgraded-$_" } @address_list_headers; # RFC 5504
  240         472  
21 20         54 push @address_list_headers, qw(original-from disposition-notification-to); # RFC 5703 and RFC 3798
22 20         11982 $header_to_class_map{$_} = 'Email::MIME::Header::AddressList' foreach @address_list_headers;
23             }
24              
25             #pod =head1 DESCRIPTION
26             #pod
27             #pod This object behaves like a standard Email::Simple header, with the following
28             #pod changes:
29             #pod
30             #pod =for :list
31             #pod * the C
method automatically decodes encoded headers if possible
32             #pod * the C method returns an object representation of the header value
33             #pod * the C method returns the raw header; (read only for now)
34             #pod * stringification uses C rather than C
35             #pod
36             #pod Note that C does not do encoding for you, and expects an
37             #pod encoded header. Thus, C round-trips with C,
38             #pod not C
! Be sure to properly encode your headers with
39             #pod C before passing them to
40             #pod C. And be sure to use minimal version 2.83 of Encode
41             #pod module due to L.
42             #pod
43             #pod Alternately, if you have Unicode (character) strings to set in headers, use the
44             #pod C method.
45             #pod
46             #pod =cut
47              
48             sub header_str {
49 727     727 0 1103 my $self = shift;
50 727         1424 my $wanta = wantarray;
51              
52 727 50       1562 return unless defined $wanta; # ??
53              
54 727 100       2276 my @header = $wanta ? $self->header_raw(@_)
55             : scalar $self->header_raw(@_);
56              
57 727         19631 foreach my $header (@header) {
58 715 100       1524 next unless defined $header;
59 487 100       1625 next unless $header =~ /=\?/;
60              
61 32         79 _maybe_decode($_[0], \$header);
62             }
63 727 100       3171 return $wanta ? @header : $header[0];
64             }
65              
66             sub header {
67 701     701 1 10772 my $self = shift;
68 701         1520 return $self->header_str(@_);
69             }
70              
71             sub header_str_set {
72 20     20 0 144 my ($self, $name, @vals) = @_;
73              
74             my @values = map {
75 20         43 Email::MIME::Encode::maybe_mime_encode_header($name, $_, 'UTF-8')
  20         99  
76             } @vals;
77              
78 20         80 $self->header_raw_set($name => @values);
79             }
80              
81             sub header_str_pairs {
82 1     1 0 6 my ($self) = @_;
83              
84 1         10 my @pairs = $self->header_pairs;
85 1         47 for (grep { $_ % 2 } (1 .. $#pairs)) {
  9         13  
86 5         12 _maybe_decode($pairs[$_-1], \$pairs[$_]);
87             }
88              
89 1         6 return @pairs;
90             }
91              
92             sub header_as_obj {
93 14     14 0 89 my ($self, $name, $index, $class) = @_;
94              
95 14 50       47 $class = $self->get_class_for_header($name) unless defined $class;
96              
97             {
98 14         28 local @CARP_NOT = qw(Email::MIME);
  14         30  
99 14         22 local $@;
100 14 50       26 Carp::croak("No class for header '$name' was specified") unless defined $class;
101 14 50       24 Carp::croak("Cannot load package '$class' for header '$name': $@") unless eval { Module::Runtime::require_module($class) };
  14         36  
102 14 50       458 Carp::croak("Class '$class' does not have method 'from_mime_string'") unless $class->can('from_mime_string');
103             }
104              
105 14         46 my @values = $self->header_raw($name, $index);
106 14 50       380 if (wantarray) {
107 0         0 return map { $class->from_mime_string($_) } @values;
  0         0  
108             } else {
109 14         44 return $class->from_mime_string(@values);
110             }
111             }
112              
113             sub _maybe_decode {
114 37     37   71 my ($name, $str_ref) = @_;
115 37         100 $$str_ref = Email::MIME::Encode::maybe_mime_decode_header($name, $$str_ref);
116 37         103 return;
117             }
118              
119             sub get_class_for_header {
120 14     14 0 28 my ($self, $name) = @_;
121 14         33 return $header_to_class_map{lc $name};
122             }
123              
124             sub set_class_for_header {
125 0     0 0   my ($self, $class, $header) = @_;
126 0           $header = lc $header;
127 0 0         Carp::croak("Class for header '$header' is already set") if defined $header_to_class_map{$header};
128 0           $header_to_class_map{$header} = $class;
129 0           return;
130             }
131              
132             1;
133              
134             __END__