File Coverage

blib/lib/Net/SMTPS.pm

Criterion	Covered	Total	%
statement	15	120	12.5
branch	0	54	0.0
condition	0	40	0.0
subroutine	5	11	45.4
pod	4	5	80.0
total	24	230	10.4

# ====
#  SSL/STARTTLS extention for G.Barr's Net::SMTP.
#    plus, enable arbitrary SMTP auth mechanism selection.
#      IO::Socket::SSL (also Net::SSLeay openssl),
#      Authen::SASL, MIME::Base64 should be installed.
#
package Net::SMTPS;

use vars qw ( $VERSION @ISA );

$VERSION = '0.08';

use strict;
use base qw ( Net::SMTP );
use Net::Cmd;  # import CMD_OK, CMD_MORE, ...
use Net::Config;

eval {
    require IO::Socket::IP
	and unshift @ISA, 'IO::Socket::IP';
} or eval {
    require IO::Socket::INET6
	and unshift @ISA, 'IO::Socket::INET6';
} or do {
    require IO::Socket::INET
	and unshift @ISA, 'IO::Socket::INET';
};

# Override to support SSL/TLS.
sub new {
  my $self = shift;
  my $type = ref($self) || $self;
  my ($host, %arg);
  if (@_ % 2) {
      $host = shift;
      %arg  = @_;
  }
  else {
      %arg  = @_;
      $host = delete $arg{Host};
  }
  my $ssl = delete $arg{doSSL};
  if ($ssl =~ /ssl/i) {
      $arg{SSL} = 1;
  }
  if (defined($arg{SSL}) && $arg{SSL} > 0) {
      $ssl = 'ssl';
      $arg{Port} ||= 465;
  }

  my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
  my $obj;

  # eliminate IO::Socket::SSL from @ISA for multiple call of new.
  @ISA = grep { !/IO::Socket::SSL/ } @ISA;

  my %_args = map { +"$_" => $arg{$_} } grep {! /^SSL/} keys %arg;

  my $h;
  $_args{PeerPort} = $_args{Port} || 'smtp(25)';
  $_args{Proto} = 'tcp';
  $_args{Timeout} = defined $_args{Timeout} ? $_args{Timeout} : 120;

  foreach $h (@{ref($hosts) ? $hosts : [$hosts]}) {
      $_args{PeerAddr} = ($host = $h);

      #if ($_args{Debug}) {
	#  foreach my $i (keys %_args) {
	#     print STDERR "$type>>> arg $i: $_args{$i}\n";
	#  }
      #}

      $obj = $type->SUPER::new(
	  %_args
      )
      and last;
  }

  return undef
    unless defined $obj;

  $obj->autoflush(1);

  $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);

# common in SSL
  my %ssl_args;
  if ($ssl || defined($arg{SSL}) ) {
    eval {
      require IO::Socket::SSL;
    } or do {
      $obj->set_status(500, ["Need working IO::Socket::SSL"]);
      $obj->close;
      return undef;
    };
    %ssl_args = map { +"$_" => $arg{$_} } grep {/^SSL/} keys %arg;
    $IO::Socket::SSL::DEBUG = (exists $arg{Debug} ? $arg{Debug} : undef);
  }

# OverSSL
  if (defined($ssl) && $ssl =~ /ssl/i) {
    $obj->ssl_start(\%ssl_args)
      or do {
	$obj->set_status(500, ["Cannot start SSL"]);
	$obj->close;
	return undef;
      };
  }

  unless ($obj->response() == CMD_OK) {
    $obj->close();
    return undef;
  }

  ${*$obj}{'net_smtp_arg'} = \%arg;

  ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
  ${*$obj}{'net_smtp_host'}       = $host;

  (${*$obj}{'net_smtp_banner'}) = $obj->message;
  (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;

  unless ($obj->hello($arg{Hello} || "")) {
    $obj->close();
    return undef;
  }

# STARTTLS
  if (defined($ssl) && $ssl =~ /starttls/i && defined($obj->supports('STARTTLS')) ) {
      #123006 $obj->supports('STARTTLS') returns '' issue.
      unless ($obj->starttls()) {
	  return undef;
      }
      $obj->hello($arg{Hello} || "");
  }

  $obj;
}

sub ssl_start {
    my ($self, $args) = @_;
    my $type = ref($self);

    (unshift @ISA, 'IO::Socket::SSL'
     and IO::Socket::SSL->start_SSL($self, %$args)
     and $self->isa('IO::Socket::SSL')
     and bless $self, $type     # re-bless 'cause IO::Socket::SSL blesses himself.
    ) or return undef;
}

sub starttls {
    my $self = shift;
    my %arg = %{ ${*$self}{'net_smtp_arg'} };
    my %ssl_args = map { +"$_" => $arg{$_} } grep {/^SSL/} keys %arg;
    (
     $self->_STARTTLS()
     and $self->ssl_start(\%ssl_args, @_)
    ) or do {
	$self->set_status(500, ["Cannot start SSL session"]);
	$self->close();
	return undef;
    };
}


# Override to specify a certain auth mechanism.
sub auth {
    my ($self, $username, $password, $mech) = @_;

    if ($mech) {
	$self->debug_print(1, "AUTH-my favorite: ". $mech . "\n") if $self->debug;

	my @cl_mech = split /\s+/, $mech;
	my @matched = ();
	if (exists ${*$self}{'net_smtp_esmtp'}->{'AUTH'}) {
	    my $sv = ${*$self}{'net_smtp_esmtp'}->{'AUTH'};
	    $self->debug_print(1, "AUTH-server offerred: ". $sv . "\n") if $self->debug;

	    foreach my $i (@cl_mech) {
		if (index($sv, $i) >= 0 && grep(/$i/i, @matched) == () ) {
		    push @matched, uc($i);
		}
	    }
	}
	if (@matched) {
	    ## override AUTH mech as specified.
	    ## if multiple mechs are specified, priority is still up to Authen::SASL module.
	    ${*$self}{'net_smtp_esmtp'}->{'AUTH'} = join " ", @matched;
	    $self->debug_print(1, "AUTH-negotiated: ". ${*$self}{'net_smtp_esmtp'}->{'AUTH'} . "\n") if $self->debug;
	}
    }
    $self->SUPER::auth($username, $password);
}


# Fix #121006 no timeout issue.
sub getline {
    my $self = shift;
    $self->Net::Cmd::getline(@_);
}

sub _STARTTLS { shift->command("STARTTLS")->response() == CMD_OK }

1;

__END__