File Coverage

blib/lib/Mail/Message/Construct/Rebuild.pm
Criterion Covered Total %
statement 116 149 77.8
branch 47 70 67.1
condition 11 35 31.4
subroutine 22 25 88.0
pod 2 14 14.2
total 198 293 67.5


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 2     2   1469 use vars '$VERSION';
  2         5  
  2         105  
11             $VERSION = '3.012';
12              
13              
14 2     2   11 use strict;
  2         4  
  2         41  
15 2     2   9 use warnings;
  2         4  
  2         67  
16              
17 2     2   10 use Mail::Message::Head::Complete;
  2         3  
  2         43  
18 2     2   11 use Mail::Message::Body::Lines;
  2         4  
  2         48  
19 2     2   10 use Mail::Message::Body::Multipart;
  2         10  
  2         46  
20              
21 2     2   10 use Mail::Address;
  2         3  
  2         47  
22 2     2   8 use Scalar::Util 'blessed';
  2         4  
  2         96  
23 2     2   10 use List::Util 'first';
  2         4  
  2         109  
24 2     2   11 use Mail::Box::FastScalar;
  2         4  
  2         2662  
25              
26              
27             my @default_rules =
28             qw/replaceDeletedParts descendMultiparts descendNested
29             flattenMultiparts flattenEmptyMultiparts/;
30              
31             sub rebuild(@)
32 14     14 1 2890 { my ($self, %args) = @_;
33 14         38 my $keep = delete $args{keep_message_id};
34              
35             # Collect the rules to be run
36 14 100       91 my @rules = $args{rules} ? @{delete $args{rules}} : @default_rules;
  6         24  
37 14 50       60 unshift @rules, @{delete $args{extra_rules}} if $args{extra_rules};
  0         0  
38 14 100       59 unshift @rules, @{delete $args{extraRules}} if $args{extraRules}; #old name
  6         29  
39              
40 14         46 foreach my $rule (@rules)
41 65 50       176 { next if ref $rule;
42 65 50       223 unless($self->can($rule))
43 0         0 { $self->log(ERROR => "No rebuild rule '$rule' defined.\n");
44 0         0 return 1;
45             }
46             }
47              
48             # Start off with the message
49              
50 14 50       79 my $rebuild = $self->recursiveRebuildPart($self, %args, rules => \@rules)
51             or return;
52              
53             # Be sure we end-up with a message
54              
55 14 100       125 if($rebuild->isa('Mail::Message::Part'))
56             { # a bit too much information is lost: we are left without the
57             # main message headers....
58 4         22 my $clone = Mail::Message->new(head => $self->head->clone);
59 4         30 $clone->body($rebuild->body); # to update the Content lines
60 4         13 $rebuild = $clone;
61             }
62              
63 14 50       91 $keep or $rebuild->takeMessageId;
64 14         95 $rebuild;
65             }
66              
67             #------------------------------------------
68             # The general rules
69              
70             sub flattenNesting($@)
71 4     4 0 9 { my ($self, $part) = @_;
72 4 100       14 $part->isNested ? $part->body->nested : $part;
73             }
74              
75             sub flattenMultiparts($@)
76 35     35 0 65 { my ($self, $part) = @_;
77 35 100       86 return $part unless $part->isMultipart;
78 10         56 my @active = $part->parts('ACTIVE');
79 10 100       44 @active==1 ? $active[0] : $part;
80             }
81              
82             sub removeEmptyMultiparts($@)
83 14     14 0 41 { my ($self, $part) = @_;
84 14 50 66     48 $part->isMultipart && $part->body->parts==0 ? undef : $part;
85             }
86              
87             sub flattenEmptyMultiparts($@)
88 25     25 0 55 { my ($self, $part) = @_;
89              
90 25 100 100     68 $part->isMultipart && $part->parts('ACTIVE')==0
91             or return $part;
92              
93 2         8 my $body = $part->body;
94 2   33     7 my $preamble = $body->preamble || Mail::Message::Body::Lines->new(data=>'');
95 2         8 my $epilogue = $body->epilogue;
96 2         27 my $newbody = $preamble->concatenate($preamble, <
97             * PLEASE NOTE:
98             * This multipart did not contain any parts (anymore)
99             * and was therefore flattened.
100              
101             NO_PARTS
102              
103 2         17 my $rebuild = Mail::Message::Part->new
104             ( head => $part->head->clone
105             , container => undef
106             );
107 2         13 $rebuild->body($newbody);
108 2         8 $rebuild;
109             }
110              
111             sub removeEmptyBodies($@)
112 0     0 0 0 { my ($self, $part) = @_;
113 0 0       0 $part->body->lines==0 ? undef : $part;
114             }
115              
116             sub descendMultiparts($@)
117 45     45 0 116 { my ($self, $part, %args) = @_;
118 45 100       127 return $part unless $part->isMultipart;
119              
120 19         61 my $body = $part->body;
121 19         36 my $changed = 0;
122 19         36 my @newparts;
123              
124 19         76 foreach my $part ($body->parts)
125 28         97 { my $new = $self->recursiveRebuildPart($part, %args);
126 28 100       174 if(!defined $new) { $changed++ }
  9 50       19  
127 19         52 elsif($new==$part) { push @newparts, $part }
128 0         0 else { push @newparts, $new; $changed++ }
  0         0  
129             }
130              
131 19 100       72 $changed or return $part;
132              
133 7         64 my $newbody = ref($body)->new
134             ( based_on => $body
135             , parts => \@newparts
136             );
137              
138 7         40 my $rebuild = ref($part)->new
139             ( head => $part->head->clone
140             , container => undef
141             );
142              
143 7         39 $rebuild->body($newbody); # update Content-* lines
144 7         43 $rebuild;
145             }
146              
147             sub descendNested($@)
148 32     32 0 80 { my ($self, $part, %args) = @_;
149 32 100       86 $part->isNested or return $part;
150              
151 7         29 my $body = $part->body;
152 7         22 my $srcnested = $body->nested;
153 7         37 my $newnested = $self->recursiveRebuildPart($srcnested, %args);
154              
155 7 50       31 defined $newnested or return undef;
156 7 100       27 return $part if $newnested==$srcnested;
157              
158             # Changes in the encapsulated message
159 3         27 my $newbody = ref($body)->new(based_on => $body, nested => $newnested);
160 3         16 my $rebuild = ref($part)->new(head => $part->head->clone
161             , container => undef);
162              
163 3         16 $rebuild->body($newbody);
164 3         20 $rebuild;
165             }
166              
167             sub removeDeletedParts($@)
168 30     30 0 65 { my ($self, $part) = @_;
169 30 100       89 $part->isDeleted ? undef : $part;
170             }
171              
172             sub replaceDeletedParts($@)
173 23     23 0 50 { my ($self, $part) = @_;
174              
175 23 50 66     68 ($part->isNested && $part->body->nested->isDeleted) || $part->isDeleted
      33        
176             or return $part;
177              
178 0         0 my $structure = '';
179 0         0 my $output = Mail::Box::FastScalar->new(\$structure, ' ');
180 0         0 $part->printStructure($output);
181              
182 0   0     0 my $dispfn = $part->body->dispositionFilename || '';
183 0         0 Mail::Message::Part->build
184             ( data => "Removed content:\n\n$structure\n$dispfn"
185             );
186             }
187              
188             #------------------------------------------
189             # The more complex rules
190              
191             sub removeHtmlAlternativeToText($@)
192 8     8 0 20 { my ($self, $part) = @_;
193 8 100       29 $part->body->mimeType eq 'text/html'
194             or return $part;
195              
196 2         75 my $container = $part->container;
197              
198 2 50 33     14 return $part
199             unless defined $container
200             && $container->mimeType eq 'multipart/alternative';
201              
202             # The HTML $part will be nulled when a plain text part is found
203 2         43 foreach my $subpart ($container->parts)
204 4 100       44 { return undef if $subpart->body->mimeType eq 'text/plain';
205             }
206              
207 0         0 $part;
208             }
209              
210             sub removeExtraAlternativeText($@)
211 0     0 0 0 { my ($self, $part) = @_;
212              
213 0         0 my $container = $part->container;
214 0 0 0     0 $container && $container->mimeType eq 'multipart/alternative'
215             or return $part;
216              
217             # The last part is the preferred part (as per RFC2046)
218 0         0 my $last = ($container->parts)[-1];
219 0 0 0     0 $last && $part==$last ? $part : undef;
220             }
221              
222             my $has_hft;
223             sub textAlternativeForHtml($@)
224 2     2 0 9 { my ($self, $part, %args) = @_;
225              
226 2         7 my $hft = 'Mail::Message::Convert::HtmlFormatText';
227 2 50       9 unless(defined $has_hft)
228 2         243 { eval "require $hft";
229 2         33 $has_hft = $hft->can('format');
230             }
231              
232 2 50 33     17 return $part
233             unless $has_hft && $part->body->mimeType eq 'text/html';
234              
235 0         0 my $container = $part->container;
236 0   0     0 my $in_alt = defined $container
237             && $container->mimeType eq 'multipart/alternative';
238              
239             return $part
240             if $in_alt
241 0 0 0 0   0 && first { $_->body->mimeType eq 'text/plain' } $container->parts;
  0         0  
242              
243              
244             # Create the plain part
245              
246 0         0 my $html_body = $part->body;
247 0         0 my $plain_body = $hft->new(%args)->format($html_body);
248              
249 0         0 my $plain_part = Mail::Message::Part->new(container => undef);
250 0         0 $plain_part->body($plain_body);
251              
252 0 0       0 return $container->attach($plain_part)
253             if $in_alt;
254              
255             # Recreate the html part to loose some header lines
256              
257 0         0 my $html_part = Mail::Message::Part->new(container => undef);
258 0         0 $html_part->body($html_body);
259              
260             # Create the new part, with the headers of the html part
261              
262 0         0 my $mp = Mail::Message::Body::Multipart->new
263             ( mime_type => 'multipart/alternative'
264             , parts => [ $plain_part, $html_part ]
265             );
266              
267 0         0 my $newpart = ref($part)->new
268             ( head => $part->head->clone # Subject field, and such
269             , container => undef
270             );
271 0         0 $newpart->body($mp);
272 0         0 $newpart;
273             }
274              
275             #------------------------------------------
276              
277              
278             sub recursiveRebuildPart($@)
279 49     49 1 209 { my ($self, $part, %args) = @_;
280              
281             RULES:
282 49         75 foreach my $rule (@{$args{rules}})
  49         128  
283 218 50       359 { my %params = ( %args, %{$args{$rule} || {}} );
  218         913  
284 218 100       1109 my $rebuild = $self->$rule($part, %params)
285             or return undef;
286              
287 209 100       798 if($part != $rebuild)
288 16         38 { $part = $rebuild;
289 16         72 redo RULES;
290             }
291             }
292              
293 40         103 $part;
294             }
295              
296             #------------------------------------------
297              
298              
299              
300             1;