package Test::Smoke::Mailer;
use strict;
use vars qw( $VERSION $P5P $NOCC_RE);
$VERSION = '0.015';
use Test::Smoke::Util qw( parse_report_Config );
$P5P = 'perl5-porters@perl.org';
$NOCC_RE = ' (?:PASS\b|FAIL\(X\))';
my %CONFIG = (
df_mailer => 'Mail::Sendmail',
df_ddir => undef,
df_v => 0,
df_rptfile => 'mktest.rpt',
df_to => 'daily-build-reports@perl.org',
df_from => '',
df_cc => '',
df_swcc => '-c',
df_swbcc => '-b',
df_bcc => '',
df_ccp5p_onfail => 0,
df_mserver => 'localhost',
df_msuser => undef,
df_mspass => undef,
df_mailbin => 'mail',
mail => [qw( bcc cc mailbin )],
df_mailxbin => 'mailx',
mailx => [qw( bcc cc mailxbin swcc swbcc )],
df_sendemailbin => 'sendemail',
sendemail => [qw( from bcc cc sendemailbin mserver msuser mspass )],
df_sendmailbin => 'sendmail',
sendmail => [qw( from bcc cc sendmailbin )],
'Mail::Sendmail' => [qw( from bcc cc mserver )],
'MIME::Lite' => [qw( from bcc cc mserver msuser mspass )],
valid_mailer => {
sendmail => 1,
mail => 1,
mailx => 1,
sendemail => 1,
'Mail::Sendmail' => 1,
'MIME::Lite' => 1,
},
);
=head1 NAME
Test::Smoke::Mailer - Wrapper to send the report.
=head1 SYNOPSIS
use Test::Smoke::Mailer;
my %args = ( mhowto => 'smtp', mserver => 'smtp.your.domain' );
my $mailer = Test::Smoke::Mailer->new( $ddir, %args );
$mailer->mail or die "Problem in mailing: " . $mailer->error;
=head1 DESCRIPTION
This little wrapper still allows you to use the B<sendmail>, B<sendemail>,
B<mail> or B<mailx> programs, but prefers to use the B<Mail::Sendmail>
module (which comes with this distribution) to send the reports.
=head1 METHODS
=over 4
=item Test::Smoke::Mailer->new( $mailer[, %args] )
Can we provide sensible defaults for the mail stuff?
mhowto => [Module::Name|sendmail|mail|mailx|sendemail]
mserver => an SMTP server || localhost
mbin => the full path to the mail binary
mto => list of addresses (comma separated!)
mfrom => single address
mcc => list of addresses (coma separated!)
=cut
sub new {
my $proto = shift;
my $class = ref $proto || $proto;
my $mailer = shift || $CONFIG{df_mailer};
unless ( exists $CONFIG{valid_mailer}->{ $mailer } ) {
require Carp;
Carp::croak( "Invalid mailer '$mailer'" );
};
my %args_raw = @_ ? UNIVERSAL::isa( $_[0], 'HASH' ) ? %{ $_[0] } : @_ : ();
my %args = map {
( my $key = $_ ) =~ s/^-?(.+)$/lc $1/e;
( $key => $args_raw{ $_ } );
} keys %args_raw;
my %fields = map {
my $value = exists $args{$_} ? $args{ $_ } : $CONFIG{ "df_$_" };
( $_ => $value )
} ( rptfile => v => ddir => to => ccp5p_onfail => @{ $CONFIG{ $mailer } } );
$fields{ddir} = File::Spec->rel2abs( $fields{ddir} );
DO_NEW: {
local $_ = $mailer;
/^sendmail$/ && return Test::Smoke::Mailer::Sendmail->new( %fields );
/^mailx?$/ && return Test::Smoke::Mailer::Mail_X->new( %fields );
/^sendemail?$/ && return Test::Smoke::Mailer::SendEmail->new( %fields );
/^Mail::Sendmail$/ &&
return Test::Smoke::Mailer::Mail_Sendmail->new( %fields );
/^MIME::Lite$/ &&
return Test::Smoke::Mailer::MIME_Lite->new( %fields );
}
}
=item $mailer->fetch_report( )
C<fetch_report()> reads B<mktest.rpt> from C<{ddir}> and return the
subject line for the mail-message.
=cut
sub fetch_report {
my $self = shift;
$self->{file} = File::Spec->catfile( $self->{ddir}, $self->{rptfile} );
local *REPORT;
if ( open REPORT, "< $self->{file}" ) {
$self->{body} = do { local $/; <REPORT> };
close REPORT;
} else {
require Carp;
Carp::croak( "Cannot read '$self->{file}': $!" );
}
my @config = parse_report_Config( $self->{body} );
return sprintf "Smoke [%s] %s %s %s %s (%s)", @config[6, 1, 5, 2, 3, 4];
}
=item $mailer->error( )
C<error()> returns the value of C<< $mailer->{error} >>.
=cut
sub error {
my $self = shift;
return $self->{error} || '';
}
=item $self->_get_cc( $subject )
C<_get_cc()> implements the C<--ccp5p_onfail> option. It looks at the
subject to see if the smoke FAILed and then adds the I<perl5-porters>
mailing-list to the C<Cc:> field unless it is already part of C<To:>
or C<Cc:>.
The new behaviour is to only return C<Cc:> on fail. This is determined
by the new global regex kept in C<< $Test::Smoke::Mailer::NOCC_RE >>.
=cut
sub _get_cc {
my( $self, $subject ) = @_;
return "" if $subject =~ m/$NOCC_RE/;
return $self->{cc} || "" unless $self->{ccp5p_onfail};
my $p5p = $Test::Smoke::Mailer::P5P or return $self->{cc};
my @cc = $self->{cc} ? $self->{cc} : ();
push @cc, $p5p unless $self->{to} =~ /\Q$p5p\E/ ||
$self->{cc} =~ /\Q$p5p\E/;
return join ", ", @cc;
}
=item Test::Smoke::Mailer->config( $key[, $value] )
C<config()> is an interface to the package lexical C<%CONFIG>,
which holds all the default values for the C<new()> arguments.
With the special key B<all_defaults> this returns a reference
to a hash holding all the default values.
=cut
sub config {
my $dummy = shift;
my $key = lc shift;
if ( $key eq 'all_defaults' ) {
my %default = map {
my( $pass_key ) = $_ =~ /^df_(.+)/;
( $pass_key => $CONFIG{ $_ } );
} grep /^df_/ => keys %CONFIG;
return \%default;
}
return undef unless exists $CONFIG{ "df_$key" };
$CONFIG{ "df_$key" } = shift if @_;
return $CONFIG{ "df_$key" };
}
1;
=back
=head1 Test::Smoke::Mailer::Sendmail
This handles sending the message by piping it to the B<sendmail> program.
=over 4
=cut
package Test::Smoke::Mailer::Sendmail;
@Test::Smoke::Mailer::Sendmail::ISA = qw( Test::Smoke::Mailer );
=item Test::Smoke::Mailer::Sendmail->new( %args )
Keys for C<%args>:
* ddir
* sendmailbin
* to
* from
* cc
* v
=cut
sub new {
my $proto = shift;
my $class = ref $proto || $proto;
return bless { @_ }, $class;
}
=item $mailer->mail( )
C<mail()> sets up a header and body and pipes them to the B<sendmail>
program.
=cut
sub mail {
my $self = shift;
my $subject = $self->fetch_report();
my $cc = $self->_get_cc( $subject );
my $header = "To: $self->{to}\n";
$header .= "From: $self->{from}\n"
if exists $self->{from} && $self->{from};
$header .= "Cc: $cc\n" if $cc;
$header .= "Bcc: $self->{bcc}\n" if $self->{bcc};
$header .= "Subject: $subject\n\n";
$self->{v} > 1 and print "[$self->{sendmailbin} -i -t]\n";
$self->{v} and print "Sending report to $self->{to} ";
local *MAILER;
if ( open MAILER, "| $self->{sendmailbin} -i -t " ) {
print MAILER $header, $self->{body};
close MAILER or
$self->{error} = "Error in pipe to sendmail: $! (" . $?>>8 . ")";
} else {
$self->{error} = "Cannot fork ($self->{sendmailbin}): $!";
}
$self->{v} and print $self->{error} ? "not OK\n" : "OK\n";
return ! $self->{error};
}
=back
=head1 Test::Smoke::Mailer::Mail_X
This handles sending the message with either the B<mail> or B<mailx> program.
=over 4
=cut
package Test::Smoke::Mailer::Mail_X;
@Test::Smoke::Mailer::Mail_X::ISA = qw( Test::Smoke::Mailer );
=item Test::Smoke::Mailer::Mail_X->new( %args )
Keys for C<%args>:
* ddir
* mailbin/mailxbin
* to
* cc
* v
=cut
sub new {
my $proto = shift;
my $class = ref $proto || $proto;
return bless { @_ }, $class;
}
=item $mailer->mail( )
C<mail()> sets up the commandline and body and pipes it to either the
B<mail> or the B<mailx> program.
=cut
sub mail {
my $self = shift;
my $mailer = $self->{mailbin} || $self->{mailxbin};
my $subject = $self->fetch_report();
my $cc = $self->_get_cc( $subject );
my $cmdline = qq|$mailer -s '$subject'|;
$self->{swcc} ||= '-c', $cmdline .= qq| $self->{swcc} '$cc'| if $cc;
$self->{swbcc} ||= '-b', $cmdline .= qq| $self->{swbcc} '$self->{bcc}'|
if $self->{bcc};
$cmdline .= qq| $self->{to}|;
$self->{v} > 1 and print "[$cmdline]\n";
$self->{v} and print "Sending report to $self->{to} ";
local *MAILER;
if ( open MAILER, "| $cmdline " ) {
print MAILER $self->{body};
close MAILER or
$self->{error} = "Error in pipe to '$mailer': $! (" . $?>>8 . ")";
} else {
$self->{error} = "Cannot fork '$mailer': $!";
}
$self->{v} and print $self->{error} ? "not OK\n" : "OK\n";
return ! $self->{error};
}
=back
=head1 Test::Smoke::Mailer::SendEmail
This handles sending the message with the B<sendEmail> program.
=over 4
=cut
package Test::Smoke::Mailer::SendEmail;
@Test::Smoke::Mailer::SendEmail::ISA = qw( Test::Smoke::Mailer );
=item Test::Smoke::Mailer::SendEmail->new( %args )
Keys for C<%args>:
* ddir
* mserver
* msuser
* mspass
* sendemailbin
* to
* from
* cc
* v
=cut
sub new {
my $proto = shift;
my $class = ref $proto || $proto;
return bless { @_ }, $class;
}
=item $mailer->mail( )
C<mail()> sets up the commandline and body and passes it to the
B<sendemail> program.
=cut
sub mail {
my $self = shift;
my $mailer = $self->{sendemailbin};
my $subject = $self->fetch_report();
my $cc = $self->_get_cc( $subject );
my $cmdline = qq|$mailer -u "$subject"|;
$self->{swcc} ||= '-cc', $cmdline .= qq| $self->{swcc} "$cc"| if $cc;
$self->{swbcc} ||= '-bcc', $cmdline .= qq| $self->{swbcc} "$self->{bcc}"|
if $self->{bcc};
$cmdline .= qq| -t "$self->{to}"|;
$cmdline .= qq| -f "$self->{from}"| if $self->{from};
$cmdline .= qq| -s "$self->{mserver}"| if $self->{mserver};
$cmdline .= qq| -xu "$self->{msuser}"| if $self->{msuser};
$cmdline .= qq| -xp "$self->{mspass}"| if defined $self->{mspass};
$cmdline .= qq| -o message-file="$self->{file}"|;
$self->{v} > 1 and print "[$cmdline]\n";
$self->{v} and print "Sending report to $self->{to}\n";
system $cmdline;
if ($?) {
$self->{error} = "Error executing '$mailer': " . $?>>8;
}
$self->{v} and print $self->{error} ? "not OK\n" : "OK\n";
return ! $self->{error};
}
=back
=head1 Test::Smoke::Mailer::Mail_Sendmail
This handles sending the message using the B<Mail::Sendmail> module.
=over 4
=cut
package Test::Smoke::Mailer::Mail_Sendmail;
@Test::Smoke::Mailer::Mail_Sendmail::ISA = qw( Test::Smoke::Mailer );
=item Test::Smoke::Mailer::Mail_Sendmail->new( %args )
Keys for C<%args>:
* ddir
* mserver
* to
* from
* cc
* v
=cut
sub new {
my $proto = shift;
my $class = ref $proto || $proto;
bless { @_ }, $class;
}
=item $mailer->mail( )
C<mail()> sets up the message to be send by B<Mail::Sendmail>.
=cut
sub mail {
my $self = shift;
eval { require Mail::Sendmail; };
$self->{error} = $@ and return undef;
my $subject = $self->fetch_report();
my $cc = $self->_get_cc( $subject );
my %message = (
To => $self->{to},
Subject => $subject,
Body => $self->{body},
);
$message{cc} = $cc if $cc;
$message{bcc} = $self->{bcc} if $self->{bcc};
$message{from} = $self->{from} if $self->{from};
$message{smtp} = $self->{mserver} if $self->{mserver};
$message{ 'Content-type' } = qq!text/plain; charset="UTF8"!
if exists $ENV{LANG} && $ENV{LANG} =~ /utf-?8$/i;
$self->{v} > 1 and print "[Mail::Sendmail]\n";
$self->{v} and print "Sending report to $self->{to} ";
Mail::Sendmail::sendmail( %message ) or
$self->{error} = $Mail::Sendmail::error;
$self->{v} and print $self->{error} ? "not OK\n" : "OK\n";
return ! $self->{error};
}
=back
=head1 Test::Smoke::Mailer::MIME_Lite
This handles sending the message using the B<MIME::Lite> module.
=over 4
=cut
package Test::Smoke::Mailer::MIME_Lite;
@Test::Smoke::Mailer::MIME_Lite::ISA = qw( Test::Smoke::Mailer );
=item Test::Smoke::Mailer::MIME_Lite->new( %args )
Keys for C<%args>:
* ddir
* mserver
* msuser
* mspass
* to
* from
* cc
* v
=cut
sub new {
my $proto = shift;
my $class = ref $proto || $proto;
bless { @_ }, $class;
}
=item $mailer->mail( )
C<mail()> sets up the message to be send by B<MIME::Lite>.
=cut
sub mail {
my $self = shift;
eval { require MIME::Lite; };
$self->{error} = $@ and return undef;
my $subject = $self->fetch_report();
my $cc = $self->_get_cc( $subject );
my %message = (
To => $self->{to},
Subject => $subject,
Type => "TEXT",
Data => $self->{body},
);
$message{Cc} = $cc if $cc;
$message{Bcc} = $self->{bcc} if $self->{bcc};
$message{From} = $self->{from} if $self->{from};
if ($self->{mserver}) {
my %authinfo = ();
$authinfo{AuthUser} = $self->{msuser} if $self->{msuser};
$authinfo{AuthPass} = $self->{mspass} if defined $self->{mspass};
MIME::Lite->send(
smtp => $self->{mserver},
FromSender => $self->{from},
Debug => ($self->{v} > 1),
%authinfo,
);
}
my $ml_msg = MIME::Lite->new( %message );
$ml_msg->attr( 'content-type.charset' => 'UTF8' )
if exists $ENV{LANG} && $ENV{LANG} =~ /utf-?8$/i;
$self->{v} > 1 and print "[MIME::Lite]\n";
$self->{v} and print "Sending report to $self->{to} ";
$ml_msg->send or $self->{error} = "Problem sending mail";
$self->{v} and print $self->{error} ? "not OK\n" : "OK\n";
return ! $self->{error};
}
=back
=head1 COPYRIGHT
(c) 2002-2003, All rights reserved.
* Abe Timmerman <abeltje@cpan.org>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
See:
* <http://www.perl.com/perl/misc/Artistic.html>,
* <http://www.gnu.org/copyleft/gpl.html>
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
=cut