1#!perl 2 3use 5.008001; 4 5use strict; 6use warnings; 7 8use Config; 9use File::Temp 'tempfile'; 10use Net::SMTP; 11use Test::More; 12 13my $debug = 0; # Net::SMTP Debug => .. 14 15my $parent = 0; 16 17plan skip_all => "no SSL support found in Net::SMTP" if ! Net::SMTP->can_ssl; 18 19plan skip_all => "fork not supported on this platform" 20 unless $Config::Config{d_fork} || $Config::Config{d_pseudofork} || 21 (($^O eq 'MSWin32' || $^O eq 'NetWare') and 22 $Config::Config{useithreads} and 23 $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/); 24 25my $srv = IO::Socket::INET->new( 26 LocalAddr => '127.0.0.1', 27 Listen => 10 28); 29plan skip_all => "cannot create listener on localhost: $!" if ! $srv; 30my $saddr = $srv->sockhost.':'.$srv->sockport; 31 32plan tests => 2; 33 34require IO::Socket::SSL::Utils; 35my ($ca,$key) = IO::Socket::SSL::Utils::CERT_create( CA => 1 ); 36my ($fh,$cafile) = tempfile(); 37print $fh IO::Socket::SSL::Utils::PEM_cert2string($ca); 38close($fh); 39 40$parent = $$; 41END { unlink($cafile) if $$ == $parent } 42 43my ($cert) = IO::Socket::SSL::Utils::CERT_create( 44 subject => { CN => 'smtp.example.com' }, 45 issuer_cert => $ca, issuer_key => $key, 46 key => $key 47); 48 49test(1); # direct ssl 50test(0); # starttls 51 52 53sub test { 54 my $ssl = shift; 55 defined( my $pid = fork()) or die "fork failed: $!"; 56 exit(smtp_server($ssl)) if ! $pid; 57 smtp_client($ssl); 58 wait; 59} 60 61 62sub smtp_client { 63 my $ssl = shift; 64 my %sslopt = ( 65 SSL_verifycn_name => 'smtp.example.com', 66 SSL_ca_file => $cafile 67 ); 68 $sslopt{SSL} = 1 if $ssl; 69 my $cl = Net::SMTP->new($saddr, %sslopt, Debug => $debug); 70 note("created Net::SMTP object"); 71 if (!$cl) { 72 fail( ($ssl ? "SSL ":"" )."SMTP connect failed"); 73 } elsif ($ssl) { 74 $cl->quit; 75 pass("SSL SMTP connect success"); 76 } elsif ( ! $cl->starttls ) { 77 no warnings 'once'; 78 fail("starttls failed: $IO::Socket::SSL::SSL_ERROR"); 79 } else { 80 $cl->quit; 81 pass("starttls success"); 82 } 83} 84 85sub smtp_server { 86 my $ssl = shift; 87 my $cl = $srv->accept or die "accept failed: $!"; 88 my %sslargs = ( 89 SSL_server => 1, 90 SSL_cert => $cert, 91 SSL_key => $key, 92 ); 93 if ( $ssl ) { 94 if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) { 95 diag("initial ssl handshake with client failed"); 96 return; 97 } 98 } 99 100 print $cl "220 welcome\r\n"; 101 while (<$cl>) { 102 my ($cmd,$arg) = m{^(\S+)(?: +(.*))?\r\n} or die $_; 103 $cmd = uc($cmd); 104 if ($cmd eq 'QUIT' ) { 105 print $cl "250 bye\r\n"; 106 last; 107 } elsif ( $cmd eq 'HELO' ) { 108 print $cl "250 localhost\r\n"; 109 } elsif ( $cmd eq 'EHLO' ) { 110 print $cl "250-localhost\r\n". 111 ( $ssl ? "" : "250-STARTTLS\r\n" ). 112 "250 HELP\r\n"; 113 } elsif ( ! $ssl and $cmd eq 'STARTTLS' ) { 114 print $cl "250 starting ssl\r\n"; 115 if ( ! IO::Socket::SSL->start_SSL($cl, %sslargs)) { 116 diag("initial ssl handshake with client failed"); 117 return; 118 } 119 $ssl = 1; 120 } else { 121 diag("received unknown command: $cmd"); 122 print "500 unknown cmd\r\n"; 123 } 124 } 125 126 note("SMTP dialog done"); 127} 128