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