File Coverage

blib/lib/Mail/Mailer.pm
Criterion Covered Total %
statement 43 90 47.7
branch 8 46 17.3
condition 5 20 25.0
subroutine 10 20 50.0
pod 3 11 27.2
total 69 187 36.9


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::Mailer;
10 3     3   861 use vars '$VERSION';
  3         11  
  3         196  
11             $VERSION = '2.21';
12              
13 3     3   16 use base 'IO::Handle';
  3         6  
  3         1731  
14              
15 3     3   19653 use strict;
  3         6  
  3         68  
16 3     3   1630 use POSIX qw/_exit/;
  3         22969  
  3         17  
17              
18 3     3   4346 use Carp;
  3         6  
  3         158  
19 3     3   17 use Config;
  3         5  
  3         4674  
20              
21             #--------------
22              
23              
24             sub is_exe($);
25              
26 0     0 1 0 sub Version { our $VERSION }
27              
28             our @Mailers =
29             ( sendmail => '/usr/lib/sendmail;/usr/sbin/sendmail;/usr/ucblib/sendmail'
30             , smtp => undef
31             , smtps => undef
32             , qmail => '/usr/sbin/qmail-inject;/var/qmail/bin/qmail-inject'
33             , testfile => undef
34             );
35              
36             push @Mailers, map { split /\:/, $_, 2 }
37             split /$Config{path_sep}/, $ENV{PERL_MAILERS}
38             if $ENV{PERL_MAILERS};
39              
40             our %Mailers = @Mailers;
41             our $MailerType;
42             our $MailerBinary;
43              
44             # does this really need to be done? or should a default mailer be specified?
45              
46             $Mailers{sendmail} = 'sendmail'
47             if $^O eq 'os2' && ! is_exe $Mailers{sendmail};
48              
49             if($^O =~ m/MacOS|VMS|MSWin|os2|NetWare/i )
50             { $MailerType = 'smtp';
51             $MailerBinary = $Mailers{$MailerType};
52             }
53             else
54             { for(my $i = 0 ; $i < @Mailers ; $i += 2)
55             { $MailerType = $Mailers[$i];
56             if(my $binary = is_exe $Mailers{$MailerType})
57             { $MailerBinary = $binary;
58             last;
59             }
60             }
61             }
62              
63             sub import
64 1     1   10 { shift; # class
65 1 50       1279 @_ or return;
66              
67 0         0 my $type = shift;
68 0   0     0 my $exe = shift || $Mailers{$type};
69              
70 0 0       0 is_exe $exe
71             or carp "Cannot locate '$exe'";
72              
73 0         0 $MailerType = $type;
74 0         0 $Mailers{$MailerType} = $exe;
75             }
76              
77             sub to_array($)
78 0     0 0 0 { my ($self, $thing) = @_;
79 0 0       0 ref $thing ? @$thing : $thing;
80             }
81              
82             sub is_exe($)
83 15   100 15 0 46 { my $exe = shift || '';
84              
85 15         75 foreach my $cmd (split /\;/, $exe)
86 15         55 { $cmd =~ s/^\s+//;
87              
88             # remove any options
89 15         62 my $name = ($cmd =~ /^(\S+)/)[0];
90              
91             # check for absolute or relative path
92 15 0 33     254 return $cmd
      33        
93             if -x $name && ! -d $name && $name =~ m![\\/]!;
94              
95 15 50       49 if(defined $ENV{PATH})
96 15         213 { foreach my $dir (split /$Config{path_sep}/, $ENV{PATH})
97 135 50 33     1437 { return "$dir/$cmd"
98             if -x "$dir/$name" && ! -d "$dir/$name";
99             }
100             }
101             }
102 15         59 0;
103             }
104              
105              
106             sub new($@)
107 1     1 1 18 { my ($class, $type, @args) = @_;
108              
109 1 50       4 unless($type)
110 1 50       3 { $MailerType or croak "No MailerType specified";
111              
112 1 50       77 warn "No real MTA found, using '$MailerType'"
113             if $MailerType eq 'testfile';
114              
115 1         6 $type = $MailerType;
116             }
117              
118 1         3 my $exe = $Mailers{$type};
119              
120 1 50       5 if(defined $exe)
121 0 0       0 { $exe = is_exe $exe
122             if defined $type;
123              
124 0 0 0     0 $exe ||= $MailerBinary
125             or croak "No mailer type specified (and no default available), thus can not find executable program.";
126             }
127              
128 1         3 $class = "Mail::Mailer::$type";
129 1 50       58 eval "require $class" or die $@;
130              
131 1         17 my $glob = $class->SUPER::new; # object is a GLOB!
132 1         33 %{*$glob} = (Exe => $exe, Args => [ @args ]);
  1         13  
133 1         4 $glob;
134             }
135              
136              
137             sub open($)
138 0     0 1 0 { my ($self, $hdrs) = @_;
139 0         0 my $exe = *$self->{Exe}; # no exe, then direct smtp
140 0         0 my $args = *$self->{Args};
141              
142 0         0 my @to = $self->who_to($hdrs);
143 0         0 my $sender = $self->who_sender($hdrs);
144            
145 0         0 $self->close; # just in case;
146              
147 0 0       0 if(defined $exe)
148             { # Fork and start a mailer
149 0         0 my $child = open $self, '|-';
150 0 0       0 defined $child or die "Failed to send: $!";
151              
152 0 0       0 if($child==0)
153             { # Child process will handle sending, but this is not real exec()
154             # this is a setup!!!
155 0 0       0 unless($self->exec($exe, $args, \@to, $sender))
156 0         0 { warn $!; # setup failed
157 0         0 _exit(1); # no DESTROY(), keep it for parent
158             }
159             }
160             }
161             else
162             { # Sending is handled by a subclass
163 0 0       0 $self->exec(undef, $args, \@to)
164             or die $!;
165             }
166              
167 0         0 $self->set_headers($hdrs);
168 0         0 $self;
169             }
170              
171             sub _cleanup_hdrs($)
172 0     0   0 { foreach my $h (values %{(shift)})
  0         0  
173 0 0       0 { foreach (ref $h ? @$h : $h)
174 0         0 { s/\n\s*/ /g;
175 0         0 s/\s+$//;
176             }
177             }
178             }
179              
180             sub exec($$$$)
181 0     0 0 0 { my($self, $exe, $args, $to, $sender) = @_;
182              
183             # Fork and exec the mailer (no shell involved to avoid risks)
184 0         0 my @exe = split /\s+/, $exe;
185 0         0 exec @exe, @$args, @$to;
186             }
187              
188 0     0 0 0 sub can_cc { 1 } # overridden in subclass for mailer that can't
189              
190             sub who_to($)
191 0     0 0 0 { my($self, $hdrs) = @_;
192 0         0 my @to = $self->to_array($hdrs->{To});
193 0 0       0 unless($self->can_cc) # Can't cc/bcc so add them to @to
194 0 0       0 { push @to, $self->to_array($hdrs->{Cc} ) if $hdrs->{Cc};
195 0 0       0 push @to, $self->to_array($hdrs->{Bcc}) if $hdrs->{Bcc};
196             }
197 0         0 @to;
198             }
199              
200             sub who_sender($)
201 0     0 0 0 { my ($self, $hdrs) = @_;
202 0   0     0 ($self->to_array($hdrs->{Sender} || $hdrs->{From}))[0];
203             }
204              
205       0 0   sub epilogue {
206             # This could send a .signature, also see ::smtp subclass
207             }
208              
209             sub close(@)
210 0     0 0 0 { my $self = shift;
211 0 0       0 fileno $self or return;
212              
213 0         0 $self->epilogue;
214 0         0 CORE::close $self;
215             }
216              
217 1     1   11 sub DESTROY { shift->close }
218              
219             #--------------
220              
221             1;