File Coverage

blib/lib/Mail/Message/Body/Construct.pm
Criterion Covered Total %
statement 57 65 87.6
branch 33 48 68.7
condition 1 6 16.6
subroutine 9 10 90.0
pod 4 4 100.0
total 104 133 78.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::Body;
10 5     5   1416 use vars '$VERSION';
  5         11  
  5         344  
11             $VERSION = '3.012';
12              
13             # Mail::Message::Body::Construct adds functionality to Mail::Message::Body
14              
15 5     5   27 use strict;
  5         9  
  5         115  
16 5     5   22 use warnings;
  5         11  
  5         138  
17              
18 5     5   22 use Carp;
  5         10  
  5         389  
19 5     5   1549 use Mail::Message::Body::String;
  5         13  
  5         179  
20 5     5   31 use Mail::Message::Body::Lines;
  5         11  
  5         2938  
21              
22              
23             sub foreachLine($)
24 4     4 1 13 { my ($self, $code) = @_;
25 4         11 my $changes = 0;
26 4         8 my @result;
27              
28 4         15 foreach ($self->lines)
29 8         21 { my $becomes = $code->();
30 8 50       52 if(defined $becomes)
31 8         18 { push @result, $becomes;
32 8 50       24 $changes++ if $becomes ne $_;
33             }
34 0         0 else {$changes++}
35             }
36            
37             $changes
38 4 50       16 or return $self;
39              
40 4         20 ref($self)->new
41             ( based_on => $self
42             , data => \@result
43             );
44             }
45              
46             #------------------------------------------
47              
48              
49             sub concatenate(@)
50 9     9 1 24 { my $self = shift;
51              
52 9 50       35 return $self
53             if @_==1;
54              
55 9         19 my @unified;
56 9         28 foreach (@_)
57 39 100       92 { next unless defined $_;
58 21 50       305 push @unified
    50          
    100          
    100          
59             , !ref $_ ? $_
60             : ref $_ eq 'ARRAY' ? @$_
61             : $_->isa('Mail::Message') ? $_->body->decoded
62             : $_->isa('Mail::Message::Body') ? $_->decoded
63             : carp "Cannot concatenate element ".$_;
64             }
65              
66 9         53 ref($self)->new
67             ( based_on => $self
68             , mime_type => 'text/plain'
69             , data => join('', @unified)
70             );
71             }
72              
73             #------------------------------------------
74              
75              
76             sub attach(@)
77 0     0 1 0 { my $self = shift;
78              
79 0         0 my @parts;
80 0   0     0 push @parts, shift while @_ && ref $_[0];
81              
82 0 0       0 return $self unless @parts;
83 0 0       0 unshift @parts,
    0          
84             ( $self->isNested ? $self->nested
85             : $self->isMultipart ? $self->parts
86             : $self
87             );
88              
89 0 0       0 return $parts[0] if @parts==1;
90 0         0 Mail::Message::Body::Multipart->new(parts => \@parts, @_);
91             }
92              
93             #------------------------------------------
94              
95              
96             # tests in t/51stripsig.t
97              
98             sub stripSignature($@)
99 14     14 1 82 { my ($self, %args) = @_;
100              
101 14 50       48 return $self if $self->mimeType->isBinary;
102              
103             my $pattern = !defined $args{pattern} ? qr/^--\s?$/
104             : !ref $args{pattern} ? qr/^\Q${args{pattern}}/
105 14 100       425 : $args{pattern};
    100          
106            
107 14         51 my $lines = $self->lines; # no copy!
108             my $stop = defined $args{max_lines}? @$lines - $args{max_lines}
109 14 100       49 : exists $args{max_lines} ? 0
    100          
110             : @$lines-10;
111              
112 14 100       34 $stop = 0 if $stop < 0;
113 14         25 my ($sigstart, $found);
114            
115 14 100       35 if(ref $pattern eq 'CODE')
116 1         5 { for($sigstart = $#$lines; $sigstart >= $stop; $sigstart--)
117 4 100       15 { next unless $pattern->($lines->[$sigstart]);
118 1         4 $found = 1;
119 1         2 last;
120             }
121             }
122             else
123 13         48 { for($sigstart = $#$lines; $sigstart >= $stop; $sigstart--)
124 76 100       288 { next unless $lines->[$sigstart] =~ $pattern;
125 9         19 $found = 1;
126 9         18 last;
127             }
128             }
129            
130 14 100       51 return $self unless $found;
131            
132 10   33     42 my $bodytype = $args{result_type} || ref $self;
133              
134 10         57 my $stripped = $bodytype->new
135             ( based_on => $self
136             , data => [ @$lines[0..$sigstart-1] ]
137             );
138              
139 10 100       47 return $stripped unless wantarray;
140              
141 6         26 my $sig = $bodytype->new
142             ( based_on => $self
143             , data => [ @$lines[$sigstart..$#$lines] ]
144             );
145            
146 6         29 ($stripped, $sig);
147             }
148              
149             #------------------------------------------
150              
151             1;