File Coverage

blib/lib/Mail/Util.pm
Criterion Covered Total %
statement 15 81 18.5
branch 0 50 0.0
condition 0 25 0.0
subroutine 5 9 55.5
pod 4 4 100.0
total 24 169 14.2


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