summaryrefslogtreecommitdiff
path: root/cpan/lib/Mail/Mailer.pm
diff options
context:
space:
mode:
Diffstat (limited to 'cpan/lib/Mail/Mailer.pm')
-rw-r--r--cpan/lib/Mail/Mailer.pm386
1 files changed, 137 insertions, 249 deletions
diff --git a/cpan/lib/Mail/Mailer.pm b/cpan/lib/Mail/Mailer.pm
index bda244e2..7fc90d45 100644
--- a/cpan/lib/Mail/Mailer.pm
+++ b/cpan/lib/Mail/Mailer.pm
@@ -1,329 +1,217 @@
-#
-
+# Copyrights 1995-2017 by [Mark Overmeer <perl@overmeer.net>].
+# For other contributors see ChangeLog.
+# See the manual pages for details on the licensing terms.
+# Pod stripped from pm file by OODoc 2.02.
package Mail::Mailer;
+use vars '$VERSION';
+$VERSION = '2.19';
-=head1 NAME
-
-Mail::Mailer - Simple interface to electronic mailing mechanisms
-
-=head1 SYNOPSIS
-
- use Mail::Mailer;
- use Mail::Mailer qw(mail);
-
- $mailer = new Mail::Mailer;
-
- $mailer = new Mail::Mailer $type, @args;
-
- $mailer->open(\%headers);
-
- print $mailer $body;
-
- $mailer->close;
-
-
-=head1 DESCRIPTION
-
-Sends mail using any of the built-in methods. You can alter the
-behaviour of a method by passing C<$command> to the C<new> method.
-
-=over 4
-
-=item C<sendmail>
-
-Use the C<sendmail> program to deliver the mail. C<$command> is the
-path to C<sendmail>.
-
-=item C<smtp>
-
-Use the C<smtp> protocol via Net::SMTP to deliver the mail. The server
-to use can be specified in C<@args> with
-
- $mailer = new Mail::Mailer 'smtp', Server => $server;
-
-The smtp mailer does not handle C<Cc> and C<Bcc> lines, neither their
-C<Resent-*> fellows. The C<Debug> options enables debugging output
-from C<Net::SMTP>.
-
-=item C<qmail>
-
-Use qmail's qmail-inject program to deliver the mail.
-
-=item C<test>
-
-Used for debugging, this displays the data on STDOUT. No mail is ever
-sent. C<$command> is ignored.
-
-=back
-
-C<Mail::Mailer> will search for executables in the above order. The
-default mailer will be the first one found.
-
-=head2 ARGUMENTS
-
-C<new> can optionally be given a C<$command> and C<$type>. C<$type>
-is one C<sendmail>, C<mail>, ... given above. The meaning of
-C<$command> depends on C<$type>.
-
-C<open> is given a reference to a hash. The hash consists of key and
-value pairs, the key being the name of the header field (eg, C<To>),
-and the value being the corresponding contents of the header field.
-The value can either be a scalar (eg, C<gnat@frii.com>) or a reference
-to an array of scalars (C<eg, ['gnat@frii.com', 'Tim.Bunce@ig.co.uk']>).
-
-=head1 TO DO
-
-Assist formatting of fields in ...::rfc822:send_headers to ensure
-valid in the face of newlines and longlines etc.
-
-Secure all forms of send_headers() against hacker attack and invalid
-contents. Especially "\n~..." in ...::mail::send_headers.
-
-=head1 ENVIRONMENT VARIABLES
-
-=over 4
-
-=item PERL_MAILERS
-
-Augments/override the build in choice for binary used to send out
-our mail messages.
-
-Format:
-
- "type1:mailbinary1;mailbinary2;...:type2:mailbinaryX;...:..."
+use base 'IO::Handle';
-Example: assume you want you use private sendmail binary instead
-of mailx, one could set C<PERL_MAILERS> to:
-
- "mail:/does/not/exists:sendmail:$HOME/test/bin/sendmail"
-
-On systems which may include C<:> in file names, use C<|> as separator
-between type-groups.
-
- "mail:c:/does/not/exists|sendmail:$HOME/test/bin/sendmail"
-
-
-=back
-
-=head1 SEE ALSO
-
-Mail::Send
-
-=head1 AUTHORS
-
-Maintained by Mark Overmeer <mailtools@overmeer.net>
-
-Original code written by Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>,
-with a kick start from Graham Barr E<lt>F<gbarr@pobox.com>E<gt>. With
-contributions by Gerard Hickey E<lt>F<hickey@ctron.com>E<gt> Small fix
-and documentation by Nathan Torkington E<lt>F<gnat@frii.com>E<gt>.
-
-=cut
+use strict;
+use POSIX qw/_exit/;
use Carp;
-use IO::Handle;
-use vars qw(@ISA $VERSION $MailerBinary $MailerType %Mailers @Mailers);
use Config;
-use strict;
-$VERSION = "1.52";
+#--------------
-sub Version { $VERSION }
-@ISA = qw(IO::Handle);
+sub is_exe($);
-# Suggested binaries for types? Should this be handled in the object class?
-@Mailers = (
+sub Version { our $VERSION }
- # Headers-blank-Body all on stdin
- 'sendmail' => '/usr/lib/sendmail;/usr/sbin/sendmail;/usr/ucblib/sendmail',
+our @Mailers =
+ ( sendmail => '/usr/lib/sendmail;/usr/sbin/sendmail;/usr/ucblib/sendmail'
+ , smtp => undef
+ , smtps => undef
+ , qmail => '/usr/sbin/qmail-inject;/var/qmail/bin/qmail-inject'
+ , testfile => undef
+ );
- 'smtp' => undef,
- 'qmail' => '/usr/sbin/qmail-inject;/var/qmail/bin/qmail-inject',
- 'test' => undef
-);
+push @Mailers, map { split /\:/, $_, 2 }
+ split /$Config{path_sep}/, $ENV{PERL_MAILERS}
+ if $ENV{PERL_MAILERS};
-if($ENV{PERL_MAILERS})
-{ push @Mailers
- , map { split /\:/, $_, 2}
- split /$Config{path_sep}/, $ENV{PERL_MAILERS};
-}
+our %Mailers = @Mailers;
+our $MailerType;
+our $MailerBinary;
-%Mailers = @Mailers;
+# does this really need to be done? or should a default mailer be specified?
-$MailerBinary = undef;
+$Mailers{sendmail} = 'sendmail'
+ if $^O eq 'os2' && ! is_exe $Mailers{sendmail};
-# does this really need to be done? or should a default mailer be specfied?
-
-if($^O eq 'os2') {
- $Mailers{sendmail} = 'sendmail' unless is_exe($Mailers{sendmail});
-}
-
-if($^O eq 'MacOS' || $^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'os2') {
- $MailerType = 'smtp';
+if($^O =~ m/MacOS|VMS|MSWin|os2|NetWare/i )
+{ $MailerType = 'smtp';
$MailerBinary = $Mailers{$MailerType};
}
-else {
- my $i;
- for($i = 0 ; $i < @Mailers ; $i += 2) {
- $MailerType = $Mailers[$i];
- my $binary;
- if($binary = is_exe($Mailers{$MailerType})) {
- $MailerBinary = $binary;
- last;
- }
+else
+{ for(my $i = 0 ; $i < @Mailers ; $i += 2)
+ { $MailerType = $Mailers[$i];
+ if(my $binary = is_exe $Mailers{$MailerType})
+ { $MailerBinary = $binary;
+ last;
+ }
}
}
-sub import {
- shift;
+sub import
+{ shift; # class
+ @_ or return;
- if(@_) {
- my $type = shift;
- my $exe = shift || $Mailers{$type};
+ my $type = shift;
+ my $exe = shift || $Mailers{$type};
- carp "Cannot locate '$exe'"
- unless is_exe($exe);
+ is_exe $exe
+ or carp "Cannot locate '$exe'";
- $MailerType = $type;
- $Mailers{$MailerType} = $exe;
- }
+ $MailerType = $type;
+ $Mailers{$MailerType} = $exe;
}
-sub to_array {
- my($self, $thing) = @_;
- if (ref($thing)) {
- return @$thing;
- } else {
- return ($thing);
- }
+sub to_array($)
+{ my ($self, $thing) = @_;
+ ref $thing ? @$thing : $thing;
}
-sub is_exe {
- my $exe = shift || '';
- my $cmd;
+sub is_exe($)
+{ my $exe = shift || '';
- foreach $cmd (split /\;/, $exe) {
- $cmd =~ s/^\s+//;
+ foreach my $cmd (split /\;/, $exe)
+ { $cmd =~ s/^\s+//;
- # remove any options
- my $name = ($cmd =~ /^(\S+)/)[0];
+ # remove any options
+ my $name = ($cmd =~ /^(\S+)/)[0];
- # check for absolute or relative path
- return ($cmd)
- if (-x $name and ! -d $name and $name =~ m:[\\/]:);
+ # check for absolute or relative path
+ return $cmd
+ if -x $name && ! -d $name && $name =~ m![\\/]!;
- if (defined $ENV{PATH}) {
- my $dir;
- foreach $dir (split(/$Config{path_sep}/, $ENV{PATH})) {
- return "$dir/$cmd"
- if (-x "$dir/$name" && ! -d "$dir/$name");
- }
- }
+ if(defined $ENV{PATH})
+ { foreach my $dir (split /$Config{path_sep}/, $ENV{PATH})
+ { return "$dir/$cmd"
+ if -x "$dir/$name" && ! -d "$dir/$name";
+ }
+ }
}
0;
}
-sub new {
- my($class, $type, @args) = @_;
- $type = $MailerType unless $type;
- croak "Mailer '$type' not known, please specify correct type"
- unless $type;
+sub new($@)
+{ my ($class, $type, @args) = @_;
+
+ unless($type)
+ { $MailerType or croak "No MailerType specified";
+
+ warn "No real MTA found, using '$MailerType'"
+ if $MailerType eq 'testfile';
+
+ $type = $MailerType;
+ }
my $exe = $Mailers{$type};
- if(defined($exe)) {
- $exe = is_exe ($exe) if defined $type;
+ if(defined $exe)
+ { $exe = is_exe $exe
+ if defined $type;
- $exe = $MailerBinary unless $exe;
- croak "No mailer type specified (and no default available), thus can not find executable program."
- unless $exe;
+ $exe ||= $MailerBinary
+ or croak "No mailer type specified (and no default available), thus can not find executable program.";
}
$class = "Mail::Mailer::$type";
eval "require $class" or die $@;
- my $glob = $class->SUPER::new; # local($glob) = gensym; # Make glob for FileHandle and attributes
- %{*$glob} = (Exe => $exe,
- Args => [ @args ]
- );
-
- $glob; # bless $glob, $class;
+ my $glob = $class->SUPER::new; # object is a GLOB!
+ %{*$glob} = (Exe => $exe, Args => [ @args ]);
+ $glob;
}
-sub open {
- my($self, $hdrs) = @_;
- my $exe = *$self->{Exe}; # || Carp::croak "$self->open: bad exe";
- my $args = *$self->{Args};
- _cleanup_hdrs($hdrs);
- my @to = $self->who_to($hdrs);
+sub open($)
+{ my ($self, $hdrs) = @_;
+ my $exe = *$self->{Exe}; # no exe, then direct smtp
+ my $args = *$self->{Args};
+
+ my @to = $self->who_to($hdrs);
+ my $sender = $self->who_sender($hdrs);
$self->close; # just in case;
- # Fork and start a mailer
- (defined($exe) && open($self,"|-"))
- || $self->exec($exe, $args, \@to)
- || die $!;
+ if(defined $exe)
+ { # Fork and start a mailer
+ my $child = open $self, '|-';
+ defined $child or die "Failed to send: $!";
+
+ if($child==0)
+ { # Child process will handle sending, but this is not real exec()
+ # this is a setup!!!
+ unless($self->exec($exe, $args, \@to, $sender))
+ { warn $!; # setup failed
+ _exit(1); # no DESTROY(), keep it for parent
+ }
+ }
+ }
+ else
+ { # Sending is handled by a subclass
+ $self->exec(undef, $args, \@to)
+ or die $!;
+ }
- # Set the headers
$self->set_headers($hdrs);
-
- # return self (a FileHandle) ready to accept the body
$self;
}
-
-sub _cleanup_hdrs {
- my $hdrs = shift;
- my $h;
- foreach $h (values %$hdrs) {
- foreach (ref($h) ? @{$h} : $h) {
- s/\n\s*/ /g;
- s/\s+$//;
+sub _cleanup_hdrs($)
+{ foreach my $h (values %{(shift)})
+ { foreach (ref $h ? @$h : $h)
+ { s/\n\s*/ /g;
+ s/\s+$//;
+ }
}
- }
}
+sub exec($$$$)
+{ my($self, $exe, $args, $to, $sender) = @_;
-sub exec {
- my($self, $exe, $args, $to) = @_;
# Fork and exec the mailer (no shell involved to avoid risks)
- my @exe = split(/\s+/,$exe);
-
- exec(@exe, @$args, @$to);
+ my @exe = split /\s+/, $exe;
+ exec @exe, @$args, @$to;
}
sub can_cc { 1 } # overridden in subclass for mailer that can't
-sub who_to {
- my($self, $hdrs) = @_;
+sub who_to($)
+{ my($self, $hdrs) = @_;
my @to = $self->to_array($hdrs->{To});
- if (!$self->can_cc) { # Can't cc/bcc so add them to @to
- push(@to, $self->to_array($hdrs->{Cc})) if $hdrs->{Cc};
- push(@to, $self->to_array($hdrs->{Bcc})) if $hdrs->{Bcc};
+ unless($self->can_cc) # Can't cc/bcc so add them to @to
+ { push @to, $self->to_array($hdrs->{Cc} ) if $hdrs->{Cc};
+ push @to, $self->to_array($hdrs->{Bcc}) if $hdrs->{Bcc};
}
@to;
}
+sub who_sender($)
+{ my ($self, $hdrs) = @_;
+ ($self->to_array($hdrs->{Sender} || $hdrs->{From}))[0];
+}
+
sub epilogue {
# This could send a .signature, also see ::smtp subclass
}
-sub close {
- my($self, @to) = @_;
- if (fileno($self)) {
- $self->epilogue;
- close($self)
- }
+sub close(@)
+{ my $self = shift;
+ fileno $self or return;
+
+ $self->epilogue;
+ CORE::close $self;
}
+sub DESTROY { shift->close }
-sub DESTROY {
- my $self = shift;
- $self->close;
-}
+#--------------
1;
-
generated by cgit v1.2.1 (git 2.18.0) at 2026-09-02 22:19:13 +0000