File Coverage

blib/lib/Mail/Internet.pm
Criterion Covered Total %
statement 56 300 18.6
branch 17 150 11.3
condition 6 69 8.7
subroutine 14 38 36.8
pod 28 32 87.5
total 121 589 20.5


line stmt bran cond sub pod time code
1             # Copyrights 1995-2018 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.02.
5             # This code is part of the bundle MailTools. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md for Copyright.
7             # Licensed under the same terms as Perl itself.
8              
9             package Mail::Internet;
10 2     2   950 use vars '$VERSION';
  2         4  
  2         120  
11             $VERSION = '2.20';
12              
13 2     2   13 use strict;
  2         4  
  2         43  
14             # use warnings? probably breaking too much code
15              
16 2     2   10 use Carp;
  2         3  
  2         104  
17 2     2   464 use Mail::Header;
  2         4  
  2         64  
18 2     2   938 use Mail::Util qw/mailaddress/;
  2         4  
  2         120  
19 2     2   451 use Mail::Address;
  2         5  
  2         7528  
20              
21              
22             sub new(@)
23 3     3 1 241 { my $call = shift;
24 3 100       12 my $arg = @_ % 2 ? shift : undef;
25 3         5 my %opt = @_;
26              
27 3   33     17 my $class = ref($call) || $call;
28 3         6 my $self = bless {}, $class;
29              
30 3 50       9 $self->{mail_inet_head} = $opt{Header} if exists $opt{Header};
31 3 50       7 $self->{mail_inet_body} = $opt{Body} if exists $opt{Body};
32              
33 3         7 my $head = $self->head;
34 3   50     16 $head->fold_length(delete $opt{FoldLength} || 79);
35 3 50       6 $head->mail_from($opt{MailFrom}) if exists $opt{MailFrom};
36 3 100       11 $head->modify(exists $opt{Modify} ? $opt{Modify} : 1);
37              
38 3 100       8 if(!defined $arg) { }
    50          
    0          
39             elsif(ref($arg) eq 'ARRAY')
40 1 50       5 { $self->header($arg) unless exists $opt{Header};
41 1 50       7 $self->body($arg) unless exists $opt{Body};
42             }
43             elsif(defined fileno($arg))
44 0 0       0 { $self->read_header($arg) unless exists $opt{Header};
45 0 0       0 $self->read_body($arg) unless exists $opt{Body};
46             }
47             else
48 0         0 { croak "couldn't understand $arg to Mail::Internet constructor";
49             }
50              
51 3         11 $self;
52             }
53              
54              
55             sub read(@)
56 0     0 1 0 { my $self = shift;
57 0         0 $self->read_header(@_);
58 0         0 $self->read_body(@_);
59             }
60              
61             sub read_body($)
62 0     0 0 0 { my ($self, $fd) = @_;
63 0         0 $self->body( [ <$fd> ] );
64             }
65              
66             sub read_header(@)
67 0     0 0 0 { my $head = shift->head;
68 0         0 $head->read(@_);
69 0         0 $head->header;
70             }
71              
72              
73             sub extract($)
74 0     0 1 0 { my ($self, $lines) = @_;
75 0         0 $self->head->extract($lines);
76 0         0 $self->body($lines);
77             }
78              
79              
80             sub dup()
81 2     2 1 3 { my $self = shift;
82 2         6 my $dup = ref($self)->new;
83              
84 2   50     7 my $body = $self->{mail_inet_body} || [];
85 2         4 my $head = $self->{mail_inet_head};;
86              
87 2         8 $dup->{mail_inet_body} = [ @$body ];
88 2 50       7 $dup->{mail_inet_head} = $head->dup if $head;
89 2         4 $dup;
90             }
91              
92             #---------------
93              
94             sub body(;$@)
95 7     7 1 10 { my $self = shift;
96              
97 7 100 50     48 return $self->{mail_inet_body} ||= []
98             unless @_;
99              
100 1 50       5 $self->{mail_inet_body} = ref $_[0] eq 'ARRAY' ? $_[0] : [ @_ ];
101             }
102              
103              
104 10   66 10 1 62 sub head { shift->{mail_inet_head} ||= Mail::Header->new }
105              
106             #---------------
107              
108             sub print($)
109 0     0 1 0 { my $self = shift;
110 0   0     0 my $fd = shift || \*STDOUT;
111              
112 0 0 0     0 $self->print_header($fd)
113             and print $fd "\n"
114             and $self->print_body($fd);
115             }
116              
117              
118 0     0 1 0 sub print_header($) { shift->head->print(@_) }
119              
120             sub print_body($)
121 0     0 1 0 { my $self = shift;
122 0   0     0 my $fd = shift || \*STDOUT;
123              
124 0         0 foreach my $ln (@{$self->body})
  0         0  
125 0 0       0 { print $fd $ln or return 0;
126             }
127              
128 0         0 1;
129             }
130              
131              
132             sub as_string()
133 4     4 1 6 { my $self = shift;
134 4         7 $self->head->as_string . "\n" . join '', @{$self->body};
  4         8  
135             }
136              
137              
138             sub as_mbox_string($)
139 2     2 1 7 { my $self = shift->dup;
140 2         3 my $escaped = shift;
141              
142 2         5 $self->head->delete('Content-Length');
143 2 50       8 $self->escape_from unless $escaped;
144 2         5 $self->as_string . "\n";
145             }
146              
147             #---------------
148              
149 1     1 1 3 sub header { shift->head->header(@_) }
150 0     0 1 0 sub fold { shift->head->fold(@_) }
151 0     0 1 0 sub fold_length { shift->head->fold_length(@_) }
152 0     0 1 0 sub combine { shift->head->combine(@_) }
153              
154              
155             sub add(@)
156 0     0 1 0 { my $head = shift->head;
157 0         0 my $ret;
158 0         0 while(@_)
159 0         0 { my ($tag, $line) = splice @_, 0, 2;
160 0 0       0 $ret = $head->add($tag, $line, -1)
161             or return undef;
162             }
163              
164 0         0 $ret;
165             }
166              
167              
168             sub replace(@)
169 0     0 1 0 { my $head = shift->head;
170 0         0 my $ret;
171              
172 0         0 while(@_)
173 0         0 { my ($tag, $line) = splice @_, 0, 2;
174 0 0       0 $ret = $head->replace($tag, $line, 0)
175             or return undef;
176             }
177              
178 0         0 $ret;
179             }
180              
181              
182             sub get(@)
183 0     0 1 0 { my $head = shift->head;
184              
185 0 0       0 return map { $head->get($_) } @_
  0         0  
186             if wantarray;
187              
188 0         0 foreach my $tag (@_)
189 0         0 { my $r = $head->get($tag);
190 0 0       0 return $r if defined $r;
191             }
192              
193 0         0 undef;
194             }
195              
196              
197             sub delete(@)
198 0     0 1 0 { my $head = shift->head;
199 0         0 map { $head->delete($_) } @_;
  0         0  
200             }
201              
202             # Undocumented; unused???
203             sub empty()
204 0     0 0 0 { my $self = shift;
205 0         0 %$self = ();
206 0         0 1;
207             }
208              
209             #---------------
210              
211             sub remove_sig($)
212 0     0 1 0 { my $body = shift->body;
213 0   0     0 my $nlines = shift || 10;
214 0         0 my $start = @$body;
215              
216 0         0 my $i = 0;
217 0   0     0 while($i++ < $nlines && $start--)
218 0 0       0 { next if $body->[$start] !~ /^--[ ]?[\r\n]/;
219              
220 0         0 splice @$body, $start, $i;
221 0         0 last;
222             }
223             }
224              
225              
226             sub sign(@)
227 0     0 1 0 { my ($self, %arg) = @_;
228 0         0 my ($sig, @sig);
229              
230 0 0       0 if($sig = delete $arg{File})
    0          
231 0         0 { local *SIG;
232              
233 0 0       0 if(open(SIG, $sig))
234 0         0 { local $_;
235 0 0       0 while() { last unless /^(--)?\s*$/ }
  0         0  
236 0         0 @sig = ($_, , "\n");
237 0         0 close SIG;
238             }
239             }
240             elsif($sig = delete $arg{Signature})
241 0 0       0 { @sig = ref($sig) ? @$sig : split(/\n/, $sig);
242             }
243              
244 0 0       0 if(@sig)
245 0         0 { $self->remove_sig;
246 0         0 s/[\r\n]*$/\n/ for @sig;
247 0         0 push @{$self->body}, "-- \n", @sig;
  0         0  
248             }
249              
250 0         0 $self;
251             }
252              
253              
254             sub tidy_body()
255 0     0 1 0 { my $body = shift->body;
256              
257 0   0     0 shift @$body while @$body && $body->[0] =~ /^\s*$/;
258 0   0     0 pop @$body while @$body && $body->[-1] =~ /^\s*$/;
259 0         0 $body;
260             }
261              
262             #---------------
263              
264             sub reply(@)
265 0     0 1 0 { my ($self, %arg) = @_;
266 0         0 my $class = ref $self;
267 0         0 my @reply;
268              
269 0         0 local *MAILHDR;
270 0 0       0 if(open(MAILHDR, "$ENV{HOME}/.mailhdr"))
271             { # User has defined a mail header template
272 0         0 @reply = ;
273 0         0 close MAILHDR;
274             }
275              
276 0         0 my $reply = $class->new(\@reply);
277              
278             # The Subject line
279 0   0     0 my $subject = $self->get('Subject') || "";
280 0 0 0     0 $subject = "Re: " . $subject
281             if $subject =~ /\S+/ && $subject !~ /Re:/i;
282              
283 0         0 $reply->replace(Subject => $subject);
284              
285             # Locate who we are sending to
286 0   0     0 my $to = $self->get('Reply-To')
287             || $self->get('From')
288             || $self->get('Return-Path')
289             || "";
290              
291 0         0 my $sender = (Mail::Address->parse($to))[0];
292              
293 0         0 my $name = $sender->name;
294 0 0       0 unless(defined $name)
295 0         0 { my $fr = $self->get('From');
296 0 0       0 $fr = (Mail::Address->parse($fr))[0] if defined $fr;
297 0 0       0 $name = $fr->name if defined $fr;
298             }
299              
300 0   0     0 my $indent = $arg{Indent} || ">";
301 0 0       0 if($indent =~ /\%/)
302 0         0 { my %hash = ( '%' => '%');
303 0 0       0 my @name = $name ? grep( {length $_} split /[\n\s]+/, $name) : '';
  0         0  
304              
305 0         0 $hash{f} = $name[0];
306 0 0       0 $hash{F} = $#name ? substr($hash{f},0,1) : $hash{f};
307              
308 0 0       0 $hash{l} = $#name ? $name[$#name] : "";
309 0   0     0 $hash{L} = substr($hash{l},0,1) || "";
310              
311 0   0     0 $hash{n} = $name || "";
312 0         0 $hash{I} = join "", map {substr($_,0,1)} @name;
  0         0  
313              
314 0 0       0 $indent =~ s/\%(.)/defined $hash{$1} ? $hash{$1} : $1/eg;
  0         0  
315             }
316              
317 0         0 my $id = $sender->address;
318 0         0 $reply->replace(To => $id);
319              
320             # Find addresses not to include
321 0   0     0 my $mailaddresses = $ENV{MAILADDRESSES} || "";
322              
323 0         0 my %nocc = (lc($id) => 1);
324             $nocc{lc $_->address} = 1
325 0         0 for Mail::Address->parse($reply->get('Bcc'), $mailaddresses);
326              
327 0 0       0 if($arg{ReplyAll}) # Who shall we copy this to
328 0         0 { my %cc;
329 0         0 foreach my $addr (Mail::Address->parse($self->get('To'), $self->get('Cc')))
330 0         0 { my $lc = lc $addr->address;
331             $cc{$lc} = $addr->format
332 0 0       0 unless $nocc{$lc};
333             }
334 0         0 my $cc = join ', ', values %cc;
335 0         0 $reply->replace(Cc => $cc);
336             }
337              
338             # References
339 0   0     0 my $refs = $self->get('References') || "";
340 0         0 my $mid = $self->get('Message-Id');
341              
342 0 0       0 $refs .= " " . $mid if defined $mid;
343 0         0 $reply->replace(References => $refs);
344              
345             # In-Reply-To
346 0         0 my $date = $self->get('Date');
347 0         0 my $inreply = "";
348              
349 0 0       0 if(defined $mid)
    0          
350 0         0 { $inreply = $mid;
351 0         0 my @comment;
352 0 0       0 push @comment, "from $name" if defined $name;
353 0 0       0 push @comment, "on $date" if defined $date;
354 0         0 local $" = ' ';
355 0 0       0 $inreply .= " (@comment)" if @comment;
356             }
357             elsif(defined $name)
358 0         0 { $inreply = $name . "'s message";
359 0 0       0 $inreply .= "of " . $date if defined $date;
360             }
361 0         0 $reply->replace('In-Reply-To' => $inreply);
362              
363             # Quote the body
364 0         0 my $body = $reply->body;
365 0         0 @$body = @{$self->body}; # copy body
  0         0  
366 0         0 $reply->remove_sig;
367 0         0 $reply->tidy_body;
368 0         0 s/\A/$indent/ for @$body;
369              
370             # Add references
371 0 0       0 unshift @{$body}, (defined $name ? $name . " " : "") . "<$id> writes:\n";
  0         0  
372              
373 0 0 0     0 if(defined $arg{Keep} && ref $arg{Keep} eq 'ARRAY') # Include lines
374 0         0 { foreach my $keep (@{$arg{Keep}})
  0         0  
375 0         0 { my $ln = $self->get($keep);
376 0 0       0 $reply->replace($keep => $ln) if defined $ln;
377             }
378             }
379              
380 0 0 0     0 if(defined $arg{Exclude} && ref $arg{Exclude} eq 'ARRAY') # Exclude lines
381 0         0 { $reply->delete(@{$arg{Exclude}});
  0         0  
382             }
383              
384 0         0 $reply->head->cleanup; # remove empty header lines
385 0         0 $reply;
386             }
387              
388              
389             sub smtpsend($@)
390 0     0 1 0 { my ($self, %opt) = @_;
391              
392 0         0 require Net::SMTP;
393 0         0 require Net::Domain;
394              
395 0         0 my $host = $opt{Host};
396 0   0     0 my $envelope = $opt{MailFrom} || mailaddress();
397 0         0 my $quit = 1;
398              
399 0         0 my ($smtp, @hello);
400              
401             push @hello, Hello => $opt{Hello}
402 0 0       0 if defined $opt{Hello};
403              
404             push @hello, Port => $opt{Port}
405 0 0       0 if exists $opt{Port};
406              
407             push @hello, Debug => $opt{Debug}
408 0 0       0 if exists $opt{Debug};
409              
410 0 0 0     0 if(!defined $host)
    0          
411 0         0 { local $SIG{__DIE__};
412 0         0 my @hosts = qw(mailhost localhost);
413             unshift @hosts, split /\:/, $ENV{SMTPHOSTS}
414 0 0       0 if defined $ENV{SMTPHOSTS};
415              
416 0         0 foreach $host (@hosts)
417 0         0 { $smtp = eval { Net::SMTP->new($host, @hello) };
  0         0  
418 0 0       0 last if defined $smtp;
419             }
420             }
421             elsif(UNIVERSAL::isa($host,'Net::SMTP')
422             || UNIVERSAL::isa($host,'Net::SMTP::SSL'))
423 0         0 { $smtp = $host;
424 0         0 $quit = 0;
425             }
426             else
427 0         0 { local $SIG{__DIE__};
428 0         0 $smtp = eval { Net::SMTP->new($host, @hello) };
  0         0  
429             }
430              
431 0 0       0 defined $smtp or return ();
432              
433 0         0 my $head = $self->cleaned_header_dup;
434              
435             # Who is it to
436              
437 0 0       0 my @rcpt = map { ref $_ ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'};
  0         0  
  0         0  
438 0 0       0 @rcpt = map { $head->get($_) } qw(To Cc Bcc)
  0         0  
439             unless @rcpt;
440              
441 0         0 my @addr = map {$_->address} Mail::Address->parse(@rcpt);
  0         0  
442 0 0       0 @addr or return ();
443              
444 0         0 $head->delete('Bcc');
445              
446             # Send it
447              
448             my $ok = $smtp->mail($envelope)
449             && $smtp->to(@addr)
450 0   0     0 && $smtp->data(join("", @{$head->header}, "\n", @{$self->body}));
451              
452 0 0       0 $quit && $smtp->quit;
453 0 0       0 $ok ? @addr : ();
454             }
455              
456              
457             sub send($@)
458 0     0 1 0 { my ($self, $type, @args) = @_;
459              
460 0         0 require Mail::Mailer;
461              
462 0         0 my $head = $self->cleaned_header_dup;
463 0         0 my $mailer = Mail::Mailer->new($type, @args);
464              
465 0         0 $mailer->open($head->header_hashref);
466 0         0 $self->print_body($mailer);
467 0         0 $mailer->close;
468             }
469              
470              
471             sub nntppost
472 0     0 1 0 { my ($self, %opt) = @_;
473              
474 0         0 require Net::NNTP;
475              
476 0   0     0 my $groups = $self->get('Newsgroups') || "";
477 0         0 my @groups = split /[\s,]+/, $groups;
478 0 0       0 @groups or return ();
479              
480 0         0 my $head = $self->cleaned_header_dup;
481              
482             # Remove these incase the NNTP host decides to mail as well as me
483 0         0 $head->delete(qw(To Cc Bcc));
484              
485 0         0 my $news;
486 0         0 my $quit = 1;
487              
488 0         0 my $host = $opt{Host};
489 0 0 0     0 if(ref($host) && UNIVERSAL::isa($host,'Net::NNTP'))
490 0         0 { $news = $host;
491 0         0 $quit = 0;
492             }
493             else
494 0         0 { my @opt = $opt{Host};
495              
496             push @opt, Port => $opt{Port}
497 0 0       0 if exists $opt{Port};
498              
499             push @opt, Debug => $opt{Debug}
500 0 0       0 if exists $opt{Debug};
501              
502 0 0       0 $news = Net::NNTP->new(@opt)
503             or return ();
504             }
505              
506 0         0 $news->post(@{$head->header}, "\n", @{$self->body});
  0         0  
  0         0  
507 0         0 my $rc = $news->code;
508              
509 0 0       0 $news->quit if $quit;
510              
511 0 0       0 $rc == 240 ? @groups : ();
512             }
513              
514              
515             sub escape_from
516 2     2 1 4 { my $body = shift->body;
517 2         5 scalar grep { s/\A(>*From) />$1 /o } @$body;
  24         71  
518             }
519              
520              
521              
522             sub unescape_from
523 0     0 1   { my $body = shift->body;
524 0           scalar grep { s/\A>(>*From) /$1 /o } @$body;
  0            
525             }
526              
527             # Don't tell people it exists
528             sub cleaned_header_dup()
529 0     0 0   { my $head = shift->head->dup;
530              
531 0           $head->delete('From '); # Just in case :-)
532              
533             # An original message should not have any Received lines
534 0           $head->delete('Received');
535              
536 0 0         $head->replace('X-Mailer', "Perl5 Mail::Internet v".$Mail::Internet::VERSION)
537             unless $head->count('X-Mailer');
538              
539 0   0       my $name = eval {local $SIG{__DIE__}; (getpwuid($>))[6]} || $ENV{NAME} ||"";
540              
541 0           while($name =~ s/\([^\(\)]*\)//) { 1; }
  0            
542              
543 0 0         if($name =~ /[^\w\s]/)
544 0           { $name =~ s/"/\"/g;
545 0           $name = '"' . $name . '"';
546             }
547              
548 0           my $from = sprintf "%s <%s>", $name, mailaddress();
549 0           $from =~ s/\s{2,}/ /g;
550              
551 0           foreach my $tag (qw(From Sender))
552 0 0         { $head->get($tag) or $head->add($tag, $from);
553             }
554              
555 0           $head;
556             }
557              
558             1;