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