File Coverage

blib/lib/Mail/Message/Construct/Build.pm
Criterion Covered Total %
statement 64 91 70.3
branch 28 76 36.8
condition 3 12 25.0
subroutine 11 11 100.0
pod 2 2 100.0
total 108 192 56.2


line stmt bran cond sub pod time code
1             # Copyrights 2001-2022 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.03.
5             # This code is part of distribution Mail-Message. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package Mail::Message;
10 7     7   735 use vars '$VERSION';
  7         14  
  7         429  
11             $VERSION = '3.012';
12              
13              
14 7     7   47 use strict;
  7         14  
  7         167  
15 7     7   33 use warnings;
  7         18  
  7         205  
16              
17 7     7   37 use Mail::Message::Head::Complete ();
  7         23  
  7         98  
18 7     7   33 use Mail::Message::Body::Lines ();
  7         14  
  7         81  
19 7     7   29 use Mail::Message::Body::Multipart ();
  7         14  
  7         92  
20 7     7   44 use Mail::Message::Body::Nested ();
  7         19  
  7         85  
21 7     7   31 use Mail::Message::Field ();
  7         13  
  7         91  
22              
23 7     7   36 use Mail::Address ();
  7         13  
  7         5024  
24              
25              
26             sub build(@)
27 2     2 1 4 { my $class = shift;
28              
29 2 50       26 if($class->isa('Mail::Box::Message'))
30 0         0 { $class->log(ERROR
31             => "Only build() Mail::Message's; they are not in a folder yet");
32 0         0 return undef;
33             }
34              
35             my @parts
36 2 0       12 = ! ref $_[0] ? ()
    0          
    50          
37             : $_[0]->isa('Mail::Message') ? shift
38             : $_[0]->isa('Mail::Message::Body') ? shift
39             : ();
40              
41 2         10 my ($head, @headerlines);
42 2         0 my ($type, $transfenc, $dispose, $descr, $cid);
43 2         9 while(@_)
44 9         15 { my $key = shift;
45 9 50 33     20 if(ref $key && $key->isa('Mail::Message::Field'))
46 0         0 { my $name = $key->name;
47 0 0       0 if($name eq 'content-type') { $type = $key }
  0 0       0  
    0          
    0          
    0          
48 0         0 elsif($name eq 'content-transfer-encoding') { $transfenc = $key }
49 0         0 elsif($name eq 'content-disposition') { $dispose = $key }
50 0         0 elsif($name eq 'content-description') { $descr = $key }
51 0         0 elsif($name eq 'content-id') { $cid = $key }
52 0         0 else { push @headerlines, $key }
53 0         0 next;
54             }
55              
56 9         15 my $value = shift;
57 9 50       17 next unless defined $value;
58              
59 9         16 my @data;
60              
61 9 50 33     57 if($key eq 'head')
    100          
    50          
    50          
    50          
    50          
62 0         0 { $head = $value }
63             elsif($key eq 'data')
64 3         16 { @data = Mail::Message::Body->new(data => $value) }
65             elsif($key eq 'file' || $key eq 'files')
66 0 0       0 { @data = map Mail::Message::Body->new(file => $_)
67             , ref $value eq 'ARRAY' ? @$value : $value;
68             }
69             elsif($key eq 'attach')
70 0 0       0 { foreach my $c (ref $value eq 'ARRAY' ? @$value : $value)
71 0 0       0 { defined $c or next;
72 0 0 0     0 push @data, ref $c && $c->isa('Mail::Message')
73             ? Mail::Message::Body::Nested->new(nested => $c)
74             : $c;
75             }
76             }
77             elsif($key =~
78             m/^content\-(type|transfer\-encoding|disposition|description|id)$/i )
79 0         0 { my $k = lc $1;
80 0         0 my $field = Mail::Message::Field->new($key, $value);
81 0 0       0 if($k eq 'type') { $type = $field }
  0 0       0  
    0          
    0          
82 0         0 elsif($k eq 'disposition') { $dispose = $field }
83 0         0 elsif($k eq 'description') { $descr = $field }
84 0         0 elsif($k eq 'id') { $cid = $field }
85 0         0 else { $transfenc = $field }
86             }
87             elsif($key =~ m/^[A-Z]/)
88 6         14 { push @headerlines, $key, $value }
89             else
90 0         0 { $class->log(WARNING => "Skipped unknown key '$key' in build");
91             }
92              
93 9         27 push @parts, grep defined, @data;
94             }
95              
96 2 100       19 my $body
    50          
97             = @parts==0 ? Mail::Message::Body::Lines->new()
98             : @parts==1 ? $parts[0]
99             : Mail::Message::Body::Multipart->new(parts => \@parts);
100              
101             # Setting the type explicitly, only after the body object is finalized
102 2 50       10 $body->type($type) if defined $type;
103 2 50       7 $body->disposition($dispose) if defined $dispose;
104 2 50       19 $body->description($descr) if defined $descr;
105 2 50       7 $body->contentId($cid) if defined $cid;
106 2 50       8 $body->transferEncoding($transfenc) if defined $transfenc;
107              
108 2         13 $class->buildFromBody($body, $head, @headerlines);
109             }
110              
111             #------------------------------------------
112              
113              
114             sub buildFromBody(@)
115 22     22 1 1478 { my ($class, $body) = (shift, shift);
116 22         155 my @log = $body->logSettings;
117              
118 22         171 my $head;
119 22 50 33     89 if(ref $_[0] && $_[0]->isa('Mail::Message::Head')) { $head = shift }
  0         0  
120             else
121 22 100       62 { shift unless defined $_[0]; # undef as head
122 22         142 $head = Mail::Message::Head::Complete->new(@log);
123             }
124              
125 22         139 while(@_)
126 76 50       138 { if(ref $_[0]) {$head->add(shift)}
  0         0  
127 76         207 else {$head->add(shift, shift)}
128             }
129              
130 22         109 my $message = $class->new
131             ( head => $head
132             , @log
133             );
134              
135 22         138 $message->body($body);
136              
137             # be sure the message-id is actually stored in the header.
138 22 100       135 $head->add('Message-Id' => '<'.$message->messageId.'>')
139             unless defined $head->get('message-id');
140              
141 22 100       155 $head->add(Date => Mail::Message::Field->toDate)
142             unless defined $head->get('Date');
143              
144 22 50       80 $head->add('MIME-Version' => '1.0') # required by rfc2045
145             unless defined $head->get('MIME-Version');
146              
147 22         152 $message;
148             }
149              
150             #------------------------------------------
151              
152              
153             1;