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