← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:12 2021

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