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; 10use vars '$VERSION'; 11$VERSION = '3.011'; 12 13 14use strict; 15use warnings; 16 17use Mail::Message::Body::Multipart; 18use Mail::Address; 19use Scalar::Util 'blessed'; 20 21 22# tests in t/55reply1r.t, demo in the examples/ directory 23 24sub reply(@) 25{ my ($self, %args) = @_; 26 27 my $body = $args{body}; 28 my $strip = !exists $args{strip_signature} || $args{strip_signature}; 29 my $include = $args{include} || 'INLINE'; 30 31 if($include eq 'NO') 32 { # Throw away real body. 33 $body = Mail::Message::Body->new 34 (data => ["\n[The original message is not included]\n\n"]) 35 unless defined $body; 36 } 37 elsif($include eq 'INLINE' || $include eq 'ATTACH') 38 { 39 unless(defined $body) 40 { # text attachment 41 $body = $self->body; 42 $body = $body->part(0)->body if $body->isMultipart && $body->parts==1; 43 $body = $body->nested->body if $body->isNested; 44 45 $body 46 = $strip && ! $body->isMultipart && !$body->isBinary 47 ? $body->decoded->stripSignature 48 ( pattern => $args{strip_signature} 49 , max_lines => $args{max_signature} 50 ) 51 : $body->decoded; 52 } 53 54 if($include eq 'INLINE' && $body->isMultipart) { $include = 'ATTACH' } 55 elsif($include eq 'INLINE' && $body->isBinary) 56 { $include = 'ATTACH'; 57 $body = Mail::Message::Body::Multipart->new(parts => [$body]); 58 } 59 60 if($include eq 'INLINE') 61 { my $quote 62 = defined $args{quote} ? $args{quote} 63 : exists $args{quote} ? undef 64 : '> '; 65 66 if(defined $quote) 67 { my $quoting = ref $quote ? $quote : sub {$quote . $_}; 68 $body = $body->foreachLine($quoting); 69 } 70 } 71 } 72 else 73 { $self->log(ERROR => "Cannot include reply source as $include."); 74 return; 75 } 76 77 # 78 # Collect header info 79 # 80 81 my $mainhead = $self->toplevel->head; 82 83 # Where it comes from 84 my $from = delete $args{From}; 85 unless(defined $from) 86 { my @from = $self->to; 87 $from = \@from if @from; 88 } 89 90 # To whom to send 91 my $to = delete $args{To} 92 || $mainhead->get('reply-to') || $mainhead->get('from'); 93 defined $to or return; 94 95 # Add Cc 96 my $cc = delete $args{Cc}; 97 if(!defined $cc && $args{group_reply}) 98 { my @cc = $self->cc; 99 $cc = [ $self->cc ] if @cc; 100 } 101 102 # Create a subject 103 my $srcsub = delete $args{Subject}; 104 my $subject 105 = ! defined $srcsub ? $self->replySubject($self->subject) 106 : ref $srcsub ? $srcsub->($self->subject) 107 : $srcsub; 108 109 # Create a nice message-id 110 my $msgid = delete $args{'Message-ID'}; 111 $msgid = "<$msgid>" if $msgid && $msgid !~ /^\s*\<.*\>\s*$/; 112 113 # Thread information 114 my $origid = '<'.$self->messageId.'>'; 115 my $refs = $mainhead->get('references'); 116 117 # Prelude 118 my $prelude 119 = defined $args{prelude} ? $args{prelude} 120 : exists $args{prelude} ? undef 121 : [ $self->replyPrelude($to) ]; 122 123 $prelude = Mail::Message::Body->new(data => $prelude) 124 if defined $prelude && ! blessed $prelude; 125 126 my $postlude = $args{postlude}; 127 $postlude = Mail::Message::Body->new(data => $postlude) 128 if defined $postlude && ! blessed $postlude; 129 130 # 131 # Create the message. 132 # 133 134 my $total; 135 if($include eq 'NO') {$total = $body} 136 elsif($include eq 'INLINE') 137 { my $signature = $args{signature}; 138 $signature = $signature->body 139 if defined $signature && $signature->isa('Mail::Message'); 140 141 $total = $body->concatenate 142 ( $prelude, $body, $postlude 143 , (defined $signature ? "-- \n" : undef), $signature 144 ); 145 } 146 if($include eq 'ATTACH') 147 { 148 my $intro = $prelude->concatenate 149 ( $prelude 150 , [ "\n", "[Your message is attached]\n" ] 151 , $postlude 152 ); 153 154 $total = Mail::Message::Body::Multipart->new 155 ( parts => [ $intro, $body, $args{signature} ] 156 ); 157 } 158 159 my $msgtype = $args{message_type} || 'Mail::Message'; 160 161 my $reply = $msgtype->buildFromBody 162 ( $total 163 , From => $from || 'Undisclosed senders:;' 164 , To => $to 165 , Subject => $subject 166 , 'In-Reply-To' => $origid 167 , References => ($refs ? "$refs $origid" : $origid) 168 ); 169 170 my $newhead = $reply->head; 171 $newhead->set(Cc => $cc) if $cc; 172 $newhead->set(Bcc => delete $args{Bcc}) if $args{Bcc}; 173 $newhead->add($_ => $args{$_}) 174 for sort grep /^[A-Z]/, keys %args; 175 176 # Ready 177 178 $self->log(PROGRESS => 'Reply created from '.$origid); 179 $self->label(replied => 1); 180 $reply; 181} 182 183#------------------------------------------ 184 185 186# tests in t/35reply1rs.t 187 188sub replySubject($) 189{ my ($thing, $subject) = @_; 190 $subject = 'your mail' unless defined $subject && length $subject; 191 my @subject = split /\:/, $subject; 192 my $re_count = 1; 193 194 # Strip multiple Re's from the start. 195 196 while(@subject) 197 { last if $subject[0] =~ /[A-QS-Za-qs-z][A-DF-Za-df-z]/; 198 199 for(shift @subject) 200 { while( /\bRe(?:\[\s*(\d+)\s*\]|\b)/g ) 201 { $re_count += defined $1 ? $1 : 1; 202 } 203 } 204 } 205 206 # Strip multiple Re's from the end. 207 208 if(@subject) 209 { for($subject[-1]) 210 { $re_count++ while s/\s*\(\s*(re|forw)\W*\)\s*$//i; 211 } 212 } 213 214 # Create the new subject string. 215 216 my $text = (join ':', @subject) || 'your mail'; 217 for($text) 218 { s/^\s+//; 219 s/\s+$//; 220 } 221 222 $re_count==1 ? "Re: $text" : "Re[$re_count]: $text"; 223} 224 225#------------------------------------------ 226 227 228sub replyPrelude($) 229{ my ($self, $who) = @_; 230 231 $who = $who->[0] if ref $who eq 'ARRAY'; 232 233 my $user 234 = !defined $who ? undef 235 : !ref $who ? (Mail::Address->parse($who))[0] 236 : $who->isa('Mail::Message::Field') ? ($who->addresses)[0] 237 : $who; 238 239 my $from 240 = ref $user && $user->isa('Mail::Address') 241 ? ($user->name || $user->address || $user->format) 242 : 'someone'; 243 244 my $time = gmtime $self->timestamp; 245 "On $time, $from wrote:\n"; 246} 247 2481; 249