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   153 use strict;
  20         40  
  20         618  
2 20     20   103 use warnings;
  20         39  
  20         906  
3             package Email::MIME::Header 1.951;
4             # ABSTRACT: the header of a MIME message
5              
6 20     20   530 use parent 'Email::Simple::Header';
  20         368  
  20         147  
7              
8 20     20   6682 use Carp ();
  20         38  
  20         408  
9 20     20   91 use Email::MIME::Encode;
  20         40  
  20         540  
10 20     20   140 use Encode 1.9801;
  20         312  
  20         1565  
11 20     20   10343 use Module::Runtime ();
  20         31190  
  20         2227  
12              
13             our @CARP_NOT;
14              
15             our %header_to_class_map;
16              
17             BEGIN {
18 20     20   104 my @address_list_headers = qw(from sender reply-to to cc bcc);
19 20         49 push @address_list_headers, map { "resent-$_" } @address_list_headers;
  120         334  
20 20         57 push @address_list_headers, map { "downgraded-$_" } @address_list_headers; # RFC 5504
  240         503  
21 20         60 push @address_list_headers, qw(original-from disposition-notification-to); # RFC 5703 and RFC 3798
22 20         11782 $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 1079 my $self = shift;
50 727         1138 my $wanta = wantarray;
51              
52 727 50       1488 return unless defined $wanta; # ??
53              
54 727 100       2150 my @header = $wanta ? $self->header_raw(@_)
55             : scalar $self->header_raw(@_);
56              
57 727         18529 foreach my $header (@header) {
58 715 100       1491 next unless defined $header;
59 487 100       1547 next unless $header =~ /=\?/;
60              
61 32         100 _maybe_decode($_[0], \$header);
62             }
63 727 100       3695 return $wanta ? @header : $header[0];
64             }
65              
66             sub header {
67 701     701 1 14473 my $self = shift;
68 701         1425 return $self->header_str(@_);
69             }
70              
71             sub header_str_set {
72 20     20 0 138 my ($self, $name, @vals) = @_;
73              
74             my @values = map {
75 20         45 Email::MIME::Encode::maybe_mime_encode_header($name, $_, 'UTF-8')
  20         57  
76             } @vals;
77              
78 20         71 $self->header_raw_set($name => @values);
79             }
80              
81             sub header_str_pairs {
82 1     1 0 7 my ($self) = @_;
83              
84 1         9 my @pairs = $self->header_pairs;
85 1         47 for (grep { $_ % 2 } (1 .. $#pairs)) {
  9         14  
86 5         15 _maybe_decode($pairs[$_-1], \$pairs[$_]);
87             }
88              
89 1         7 return @pairs;
90             }
91              
92             sub header_as_obj {
93 14     14 0 95 my ($self, $name, $index, $class) = @_;
94              
95 14 50       44 $class = $self->get_class_for_header($name) unless defined $class;
96              
97             {
98 14         25 local @CARP_NOT = qw(Email::MIME);
  14         33  
99 14         21 local $@;
100 14 50       27 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         33  
102 14 50       525 Carp::croak("Class '$class' does not have method 'from_mime_string'") unless $class->can('from_mime_string');
103             }
104              
105 14         47 my @values = $self->header_raw($name, $index);
106 14 50       378 if (wantarray) {
107 0         0 return map { $class->from_mime_string($_) } @values;
  0         0  
108             } else {
109 14         58 return $class->from_mime_string(@values);
110             }
111             }
112              
113             sub _maybe_decode {
114 37     37   79 my ($name, $str_ref) = @_;
115 37         96 $$str_ref = Email::MIME::Encode::maybe_mime_decode_header($name, $$str_ref);
116 37         99 return;
117             }
118              
119             sub get_class_for_header {
120 14     14 0 26 my ($self, $name) = @_;
121 14         32 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__