File Coverage

blib/lib/Test/Reporter/Transport/Net/SMTP/Authen.pm

Criterion	Covered	Total	%
statement	15	132	11.3
branch	0	70	0.0
condition	0	17	0.0
subroutine	5	12	41.6
pod	2	4	50.0
total	22	235	9.3

use strict;
use warnings;
package Test::Reporter::Transport::Net::SMTP::Authen;
use base 'Test::Reporter::Transport::Net::SMTP';
use vars qw/$VERSION/;
$VERSION = '1.02';
$VERSION = eval $VERSION;
use Exporter 'import';
our @EXPORT_OK=qw(install);

sub install($$$){
    my ($smtp, $user, $password) = @_;
    if ( @_ != 3){
	croak( "Usage: install(\$smtp_server, \$user, \$password)" );
    };
    unless( $ENV{PERL_CPAN_REPORTER_DIR} ||  $ENV{HOME} ){
	require Carp;
	croak( "Please define your enviroment variable PERL_CPAN_REPORTER_DIR or HOME" );
    }
    my $reporter_folder = $ENV{PERL_CPAN_REPORTER_DIR} ||= $ENV{HOME} . '/.cpanreporter';
    require File::Path;
    require Carp;
    File::Path->import('mkpath');
    mkpath( $reporter_folder );
    open my $fh , '>', $reporter_folder .'/config.ini' or Carp::croak( "Can't write config.ini in $reporter_folder $!");
    $a = select ($fh);
    print "edit_report=no\n";
    print "email_from=$user\n";
    print "send_report=yes\n";
    print "smtp_server=$smtp\n";
    print "transport=Net::SMTP::Authen User $user Password $password\n";
    close $fh or Carp::croak ("Can't finish write $reporter_folder/config.ini $!");
    select $a;
    print STDERR "Writen $reporter_folder/config.ini .\n\tType cpan \n";
    print STDERR 	"\to conf test_report 1\n";
    print STDERR 	"\to conf commit\n";
}

sub new {
    my ($class, @args) = @_;
    bless { args => \@args } => $class;
}

sub _net_class {
    my ($self) = @_;
    my $class = ref $self ? ref $self : $self;
    my ($net_class) = ($class =~ /^Test::Reporter::Transport::(.+)\z/);
	return 'Net::SMTP' if $net_class eq 'Net::SMTP::Authen';
    return $net_class;
}

sub _perform_auth{
    my $self = shift;
    my $transport = shift;
    my $args = $$self{args};
    my %opts = ( @$args );

    my ($user_name) = $opts{'User'} || $opts{'Username'};
    my ($password) = $opts{'Password'} || $opts{'Pass'};
    die "No user_name" unless $user_name;
    return 1 if ($self->_net_class() eq 'Net::SMTP::TLS');
    return $transport->auth($user_name, $password);
}


sub send {
    my ($self, $report, $recipients) = @_;
    $recipients ||= [];

    my $helo          = $report->_maildomain(); # XXX: tight -- rjbs, 2008-04-06
    my $from          = $report->from();
    my $via           = $report->via();
    my @tmprecipients = ();
    my @bad           = ();
    my $smtp;

    my $mx;

    my $transport = $self->_net_class;

    # Sorry.  Tight coupling happened before I got here. -- rjbs, 2008-04-06
    for my $server (@{$report->{_mx}}) {
        eval {
            $smtp = $transport->new(
                $server,
                Hello   => $helo,
                Timeout => $report->timeout(),
                Debug   => $report->debug(),
                $report->transport_args(),
            );
        };

        if (defined $smtp) {
            $mx = $server;
            last;
        }
    }

    die "Unable to connect to any MX's: $@" unless $mx && $smtp;

    my $cc_str;
    if (@$recipients) {
        if ($mx =~ /(?:^|\.)(?:perl|cpan)\.org$/) {
            for my $recipient (sort @$recipients) {
                if ($recipient =~ /(?:@|\.)(?:perl|cpan)\.org$/) {
                    push @tmprecipients, $recipient;
                } else {
                    push @bad, $recipient;
                }
            }

            if (@bad) {
                warn __PACKAGE__, ": Will not attempt to cc the following recipients since perl.org MX's will not relay for them. Either use Test::Reporter::Transport::Mail::Send, use other MX's, or only cc address ending in cpan.org or perl.org: ${\(join ', ', @bad)}.\n";
            }

            $recipients = \@tmprecipients;
        }

        $cc_str = join ', ', @$recipients;
        chomp $cc_str;
        chomp $cc_str;
    }

    $via = ', via ' . $via if $via;

    my $envelope_sender = $from;
    $envelope_sender =~ s/\s\([^)]+\)$//; # email only; no name

    # Net::SMTP returns 1 or undef for pass/fail
    # Net::SMTP::TLS croaks on fail but may not return 1 on pass
    # so this closure lets us die on an undef return only for Net::SMTP
    my $die = sub { die $smtp->message if ref $smtp eq 'Net::SMTP' };


    eval {
	trace(1);
	$self->_perform_auth($smtp) or $die->();
	trace();

        $smtp->mail($envelope_sender) or $die->();
	trace();
        $smtp->to($report->address) or $die->();
	trace();
        if ( @$recipients ) { $smtp->cc(@$recipients) or $die->() };
	trace();
        $smtp->data() or $die->();
	trace();
        $smtp->datasend("Date: ", $self->_format_date, "\n") or $die->();
	trace();
        $smtp->datasend("Subject: ", $report->subject, "\n") or $die->();
	trace();
        $smtp->datasend("From: $from\n") or $die->();
	trace();
        $smtp->datasend("To: ", $report->address, "\n") or $die->();
	trace();
        if ( @$recipients ) { $smtp->datasend("Cc: $cc_str\n") or $die->() };
	trace();
        $smtp->datasend("Message-ID: ", $report->message_id(), "\n") or $die->();
	trace();
        $smtp->datasend("X-Reported-Via: Test::Reporter $Test::Reporter::VERSION$via\n") or $die->();
	trace();
        $smtp->datasend("\n") or $die->();
	trace();
	trace();
        $smtp->datasend($report->report()) or $die->();
	trace();
        $smtp->dataend() or $die->();
	trace();
        $smtp->quit or $die->();
	trace();
        1;
    } or die "$transport - $@";

    return 1;
}

1;

sub trace{
    my $mess = shift;
    my ($package, $file, $line, $func) = caller 1;
    my ($package1, $file1, $line1, $func1) = caller 0;
    #print STDERR "[$line:$line1] ";
}

__END__