File Coverage

blib/lib/Mail/Message/Construct/Forward.pm
Criterion Covered Total %
statement 106 114 92.9
branch 46 78 58.9
condition 18 39 46.1
subroutine 15 15 100.0
pod 8 8 100.0
total 193 254 75.9


line stmt bran cond sub pod time code
1             # Copyrights 2001-2023 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 3     3   2235 use vars '$VERSION';
  3         8  
  3         175  
11             $VERSION = '3.013';
12              
13              
14 3     3   21 use strict;
  3         8  
  3         66  
15 3     3   15 use warnings;
  3         7  
  3         77  
16              
17 3     3   493 use Mail::Message::Body::Multipart;
  3         8  
  3         118  
18 3     3   19 use Mail::Message::Body::Nested;
  3         6  
  3         102  
19 3     3   17 use Scalar::Util 'blessed';
  3         5  
  3         4144  
20              
21              
22             # tests in t/57forw1f.t
23              
24             sub forward(@)
25 3     3 1 1514 { my $self = shift;
26 3         15 my %args = @_;
27              
28             return $self->forwardNo(@_)
29 3 50       10 if exists $args{body};
30              
31 3   50     13 my $include = $args{include} || 'INLINE';
32 3 50       16 return $self->forwardInline(@_) if $include eq 'INLINE';
33              
34 0         0 my $preamble = $args{preamble};
35 0 0 0     0 push @_, preamble => Mail::Message::Body->new(data => $preamble)
36             if defined $preamble && ! ref $preamble;
37              
38 0 0       0 return $self->forwardAttach(@_) if $include eq 'ATTACH';
39 0 0       0 return $self->forwardEncapsulate(@_) if $include eq 'ENCAPSULATE';
40              
41 0         0 $self->log(ERROR => 'Cannot include forward source as $include.');
42 0         0 undef;
43             }
44              
45             #------------------------------------------
46              
47              
48             sub forwardNo(@)
49 7     7 1 29 { my ($self, %args) = @_;
50              
51 7         15 my $body = $args{body};
52 7 50       20 $self->log(INTERNAL => "No body supplied for forwardNo()")
53             unless defined $body;
54              
55             #
56             # Collect header info
57             #
58              
59 7         23 my $mainhead = $self->toplevel->head;
60              
61             # Where it comes from
62 7         15 my $from = $args{From};
63 7 50       16 unless(defined $from)
64 7         30 { my @from = $self->to;
65 7 50       1154 $from = \@from if @from;
66             }
67              
68             # To whom to send
69 7         15 my $to = $args{To};
70 7 50       18 $self->log(ERROR => "No address to create forwarded to."), return
71             unless $to;
72              
73             # Create a subject
74 7         13 my $srcsub = $args{Subject};
75 7 0       28 my $subject
    50          
76             = ! defined $srcsub ? $self->forwardSubject($self->subject)
77             : ref $srcsub ? $srcsub->($self->subject)
78             : $srcsub;
79              
80             # Create a nice message-id
81 7   33     37 my $msgid = $args{'Message-ID'} || $mainhead->createMessageId;
82 7 50 33     52 $msgid = "<$msgid>" if $msgid && $msgid !~ /^\s*\<.*\>\s*$/;
83              
84             # Thread information
85 7         25 my $origid = '<'.$self->messageId.'>';
86 7         19 my $refs = $mainhead->get('references');
87              
88 7 50 50     48 my $forward = Mail::Message->buildFromBody
89             ( $body
90             , From => ($from || '(undisclosed)')
91             , To => $to
92             , Subject => $subject
93             , References => ($refs ? "$refs $origid" : $origid)
94             );
95              
96 7         23 my $newhead = $forward->head;
97 7 100       31 $newhead->set(Cc => $args{Cc} ) if $args{Cc};
98 7 100       31 $newhead->set(Bcc => $args{Bcc} ) if $args{Bcc};
99 7 50       15 $newhead->set(Date => $args{Date}) if $args{Date};
100              
101             # Ready
102              
103 7         28 $self->label(passed => 1);
104 7         42 $self->log(PROGRESS => "Forward created from $origid");
105 7         65 $forward;
106             }
107              
108             #------------------------------------------
109              
110              
111             sub forwardInline(@)
112 4     4 1 21 { my ($self, %args) = @_;
113              
114 4         18 my $body = $self->body;
115              
116 4         9 while(1) # simplify
117 4 50 33     37 { if($body->isMultipart && $body->parts==1)
    50          
118 0         0 { $body = $body->part(0)->body }
119 0         0 elsif($body->isNested) { $body = $body->nested->body }
120 4         7 else { last }
121             }
122              
123             # Prelude must be a real body, otherwise concatenate will not work
124             my $prelude = exists $args{prelude} ? $args{prelude}
125 4 100       16 : $self->forwardPrelude;
126              
127 4 100 66     31 $prelude = Mail::Message::Body->new(data => $prelude)
128             if defined $prelude && ! blessed $prelude;
129            
130             # Postlude
131             my $postlude = exists $args{postlude} ? $args{postlude}
132 4 100       19 : $self->forwardPostlude;
133            
134             # Binary bodies cannot be inlined, therefore they will be rewritten
135             # into a forwardAttach... preamble must replace prelude and postlude.
136              
137 4 100 66     22 if($body->isMultipart || $body->isBinary)
138             { $args{preamble} ||= $prelude->concatenate
139             ( $prelude
140 1   50     22 , ($args{is_attached} || "[The forwarded message is attached]\n")
      33        
141             , $postlude
142             );
143 1         7 return $self->forwardAttach(%args);
144             }
145            
146 3         29 $body = $body->decoded;
147             my $strip = (!exists $args{strip_signature} || $args{strip_signature})
148 3   66     23 && !$body->isNested;
149              
150             $body = $body->stripSignature
151             ( pattern => $args{strip_signature}
152             , max_lines => $args{max_signature}
153 3 100       20 ) if $strip;
154              
155 3 100       17 if(defined(my $quote = $args{quote}))
156 2 100   2   12 { my $quoting = ref $quote ? $quote : sub {$quote . $_};
  2         7  
157 2         11 $body = $body->foreachLine($quoting);
158             }
159              
160             #
161             # Create the message.
162             #
163              
164 3         8 my $signature = $args{signature};
165 3 50 33     10 $signature = $signature->body
166             if defined $signature && $signature->isa('Mail::Message');
167              
168 3 50       23 my $composed = $body->concatenate
169             ( $prelude, $body, $postlude
170             , (defined $signature ? "-- \n" : undef), $signature
171             );
172              
173 3         18 $self->forwardNo(%args, body => $composed);
174             }
175              
176             #------------------------------------------
177              
178              
179             sub forwardAttach(@)
180 3     3 1 475 { my ($self, %args) = @_;
181              
182 3         12 my $body = $self->body;
183 3   33     14 my $strip = !exists $args{strip_signature} || $args{strip_signature};
184              
185 3 100       14 if($body->isMultipart)
186 1 50       7 { $body = $body->stripSignature if $strip;
187 1 50       5 $body = $body->part(0)->body if $body->parts == 1;
188             }
189              
190 3         7 my $preamble = $args{preamble};
191 3 50       10 $self->log(ERROR => 'Method forwardAttach requires a preamble'), return
192             unless ref $preamble;
193              
194 3         9 my @parts = ($preamble, $body);
195 3 50       8 push @parts, $args{signature} if defined $args{signature};
196 3         22 my $multi = Mail::Message::Body::Multipart->new(parts => \@parts);
197              
198 3         15 $self->forwardNo(%args, body => $multi);
199             }
200              
201             #------------------------------------------
202              
203              
204             sub forwardEncapsulate(@)
205 1     1 1 6 { my ($self, %args) = @_;
206              
207 1         4 my $preamble = $args{preamble};
208 1 50       6 $self->log(ERROR => 'Method forwardEncapsulate requires a preamble'), return
209             unless ref $preamble;
210              
211 1         6 my $nested= Mail::Message::Body::Nested->new(nested => $self->clone);
212 1         5 my @parts = ($preamble, $nested);
213 1 50       3 push @parts, $args{signature} if defined $args{signature};
214              
215 1         7 my $multi = Mail::Message::Body::Multipart->new(parts => \@parts);
216              
217 1         6 $self->forwardNo(%args, body => $multi);
218             }
219              
220             #------------------------------------------
221              
222              
223             # tests in t/57forw0s.t
224              
225             sub forwardSubject($)
226 14     14 1 136 { my ($self, $subject) = @_;
227 14 100 100     105 defined $subject && length $subject ? "Forw: $subject" : "Forwarded";
228             }
229              
230             #------------------------------------------
231              
232              
233             sub forwardPrelude()
234 1     1 1 4 { my $head = shift->head;
235              
236 1         6 my @lines = "---- BEGIN forwarded message\n";
237 1         4 my $from = $head->get('from');
238 1         4 my $to = $head->get('to');
239 1         4 my $cc = $head->get('cc');
240 1         3 my $date = $head->get('date');
241              
242 1 50       12 push @lines, $from->string if defined $from;
243 1 50       5 push @lines, $to->string if defined $to;
244 1 50       6 push @lines, $cc->string if defined $cc;
245 1 50       16 push @lines, $date->string if defined $date;
246 1         4 push @lines, "\n";
247              
248 1         3 \@lines;
249             }
250              
251             #------------------------------------------
252              
253              
254             sub forwardPostlude()
255 1     1 1 2 { my $self = shift;
256 1         4 my @lines = ("---- END forwarded message\n");
257 1         3 \@lines;
258             }
259              
260             #------------------------------------------
261              
262              
263             #------------------------------------------
264            
265             1;