1# Copyrights 2001-2021 by [Mark Overmeer <markov@cpan.org>]. 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.02. 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 9package Mail::Message::Body; 10use vars '$VERSION'; 11$VERSION = '3.011'; 12 13# Mail::Message::Body::Construct adds functionality to Mail::Message::Body 14 15use strict; 16use warnings; 17 18use Carp; 19use Mail::Message::Body::String; 20use Mail::Message::Body::Lines; 21 22 23sub foreachLine($) 24{ my ($self, $code) = @_; 25 my $changes = 0; 26 my @result; 27 28 foreach ($self->lines) 29 { my $becomes = $code->(); 30 if(defined $becomes) 31 { push @result, $becomes; 32 $changes++ if $becomes ne $_; 33 } 34 else {$changes++} 35 } 36 37 $changes 38 or return $self; 39 40 ref($self)->new 41 ( based_on => $self 42 , data => \@result 43 ); 44} 45 46#------------------------------------------ 47 48 49sub concatenate(@) 50{ my $self = shift; 51 52 return $self 53 if @_==1; 54 55 my @unified; 56 foreach (@_) 57 { next unless defined $_; 58 push @unified 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 ref($self)->new 67 ( based_on => $self 68 , mime_type => 'text/plain' 69 , data => join('', @unified) 70 ); 71} 72 73#------------------------------------------ 74 75 76sub attach(@) 77{ my $self = shift; 78 79 my @parts; 80 push @parts, shift while @_ && ref $_[0]; 81 82 return $self unless @parts; 83 unshift @parts, 84 ( $self->isNested ? $self->nested 85 : $self->isMultipart ? $self->parts 86 : $self 87 ); 88 89 return $parts[0] if @parts==1; 90 Mail::Message::Body::Multipart->new(parts => \@parts, @_); 91} 92 93#------------------------------------------ 94 95 96# tests in t/51stripsig.t 97 98sub stripSignature($@) 99{ my ($self, %args) = @_; 100 101 return $self if $self->mimeType->isBinary; 102 103 my $pattern = !defined $args{pattern} ? qr/^--\s?$/ 104 : !ref $args{pattern} ? qr/^\Q${args{pattern}}/ 105 : $args{pattern}; 106 107 my $lines = $self->lines; # no copy! 108 my $stop = defined $args{max_lines}? @$lines - $args{max_lines} 109 : exists $args{max_lines} ? 0 110 : @$lines-10; 111 112 $stop = 0 if $stop < 0; 113 my ($sigstart, $found); 114 115 if(ref $pattern eq 'CODE') 116 { for($sigstart = $#$lines; $sigstart >= $stop; $sigstart--) 117 { next unless $pattern->($lines->[$sigstart]); 118 $found = 1; 119 last; 120 } 121 } 122 else 123 { for($sigstart = $#$lines; $sigstart >= $stop; $sigstart--) 124 { next unless $lines->[$sigstart] =~ $pattern; 125 $found = 1; 126 last; 127 } 128 } 129 130 return $self unless $found; 131 132 my $bodytype = $args{result_type} || ref $self; 133 134 my $stripped = $bodytype->new 135 ( based_on => $self 136 , data => [ @$lines[0..$sigstart-1] ] 137 ); 138 139 return $stripped unless wantarray; 140 141 my $sig = $bodytype->new 142 ( based_on => $self 143 , data => [ @$lines[$sigstart..$#$lines] ] 144 ); 145 146 ($stripped, $sig); 147} 148 149#------------------------------------------ 150 1511; 152