← 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/Util.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::Util::::BEGIN@10Mail::Util::BEGIN@10
0000s0sMail::Util::::BEGIN@13Mail::Util::BEGIN@13
0000s0sMail::Util::::BEGIN@139Mail::Util::BEGIN@139
0000s0sMail::Util::::BEGIN@15Mail::Util::BEGIN@15
0000s0sMail::Util::::BEGIN@16Mail::Util::BEGIN@16
0000s0sMail::Util::::VersionMail::Util::Version
0000s0sMail::Util::::mailaddressMail::Util::mailaddress
0000s0sMail::Util::::maildomainMail::Util::maildomain
0000s0sMail::Util::::read_mboxMail::Util::read_mbox
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::Util;
10use vars '$VERSION';
11$VERSION = '2.21';
12
13use base 'Exporter';
14
15use strict;
16use Carp;
17
18our @EXPORT_OK = qw(read_mbox maildomain mailaddress);
19
20sub Version { our $VERSION }
21
22my ($domain, $mailaddress);
23my @sendmailcf = qw(/etc /etc/sendmail /etc/ucblib
24 /etc/mail /usr/lib /var/adm/sendmail);
25
26
27sub read_mbox($)
28{ my $file = shift;
29
30 local *FH;
31 open FH,'<', $file
32 or croak "cannot open '$file': $!\n";
33
34 local $_;
35 my @mbox;
36 my $mail = [];
37 my $blank = 1;
38
39 while(<FH>)
40 { if($blank && /^From .*\d{4}/)
41 { push @mbox, $mail if @$mail;
42 $mail = [ $_ ];
43 $blank = 0;
44 }
45 else
46 { $blank = m/^$/ ? 1 : 0;
47 push @$mail, $_;
48 }
49 }
50
51 push @mbox, $mail if @$mail;
52 close FH;
53
54 wantarray ? @mbox : \@mbox;
55}
56
57
58sub maildomain()
59{ return $domain
60 if defined $domain;
61
62 $domain = $ENV{MAILDOMAIN}
63 and return $domain;
64
65 # Try sendmail configuration file
66
67 my $config = (grep -r, map {"$_/sendmail.cf"} @sendmailcf)[0];
68
69 local *CF;
70 local $_;
71 if(defined $config && open CF, '<', $config)
72 { my %var;
73 while(<CF>)
74 { if(my ($v, $arg) = /^D([a-zA-Z])([\w.\$\-]+)/)
75 { $arg =~ s/\$([a-zA-Z])/exists $var{$1} ? $var{$1} : '$'.$1/eg;
76 $var{$v} = $arg;
77 }
78 }
79 close CF;
80 $domain = $var{j} if defined $var{j};
81 $domain = $var{M} if defined $var{M};
82
83 $domain = $1
84 if $domain && $domain =~ m/([A-Za-z0-9](?:[\.\-A-Za-z0-9]+))/;
85
86 return $domain
87 if defined $domain && $domain !~ /\$/;
88 }
89
90 # Try smail config file if exists
91
92 if(open CF, '<', "/usr/lib/smail/config")
93 { while(<CF>)
94 { if( /\A\s*hostnames?\s*=\s*(\S+)/ )
95 { $domain = (split /\:/,$1)[0];
96 last;
97 }
98 }
99 close CF;
100
101 return $domain
102 if defined $domain;
103 }
104
105 # Try a SMTP connection to 'mailhost'
106
107 if(eval {require Net::SMTP})
108 { foreach my $host (qw(mailhost localhost))
109 { # hosts are local, so short timeout
110 my $smtp = eval { Net::SMTP->new($host, Timeout => 5) };
111 if(defined $smtp)
112 { $domain = $smtp->domain;
113 $smtp->quit;
114 last;
115 }
116 }
117 }
118
119 # Use internet(DNS) domain name, if it can be found
120 $domain = Net::Domain::domainname()
121 if !defined $domain && eval {require Net::Domain};
122
123 $domain ||= "localhost";
124}
125
126
127sub mailaddress(;$)
128{ $mailaddress = shift if @_;
129
130 return $mailaddress
131 if defined $mailaddress;
132
133 # Get user name from environment
134 $mailaddress = $ENV{MAILADDRESS};
135
136 unless($mailaddress || $^O ne 'MacOS')
137 { require Mac::InternetConfig;
138
139 no strict;
140 Mac::InternetConfig->import;
141 $mailaddress = $InternetConfig{kICEmail()};
142 }
143
144 $mailaddress ||= $ENV{USER} || $ENV{LOGNAME} || eval {getpwuid $>}
145 || "postmaster";
146
147 # Add domain if it does not exist
148 $mailaddress .= '@' . maildomain
149 if $mailaddress !~ /\@/;
150
151 $mailaddress =~ s/(^.*<|>.*$)//g;
152 $mailaddress;
153}
154
1551;