find . -name '*.t' -exec perltidy -b {} \;
This commit is contained in:
parent
f988f0337c
commit
58aab2ad20
@ -7,35 +7,46 @@ use_ok('Test::Qpsmtpd');
|
|||||||
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
||||||
is(($smtpd->command('EHLO localhost'))[0], 250, 'EHLO localhost');
|
is(($smtpd->command('EHLO localhost'))[0], 250, 'EHLO localhost');
|
||||||
|
|
||||||
is(($smtpd->command('MAIL FROM:<ask@perl.org>'))[0], 250, 'MAIL FROM:<ask@perl.org>');
|
is(($smtpd->command('MAIL FROM:<ask@perl.org>'))[0],
|
||||||
is($smtpd->transaction->sender->address, 'ask@perl.org', 'got the right sender');
|
250, 'MAIL FROM:<ask@perl.org>');
|
||||||
|
is($smtpd->transaction->sender->address, 'ask@perl.org',
|
||||||
|
'got the right sender');
|
||||||
|
|
||||||
is(($smtpd->command('MAIL FROM:<ask @perl.org>'))[0], 250, 'MAIL FROM:<ask @perl.org>');
|
is(($smtpd->command('MAIL FROM:<ask @perl.org>'))[0],
|
||||||
is($smtpd->transaction->sender->address, 'ask @perl.org', 'got the right sender');
|
250, 'MAIL FROM:<ask @perl.org>');
|
||||||
|
is($smtpd->transaction->sender->address,
|
||||||
|
'ask @perl.org',
|
||||||
|
'got the right sender');
|
||||||
|
|
||||||
is(($smtpd->command('MAIL FROM:ask@perl.org'))[0], 250, 'MAIL FROM:ask@perl.org');
|
is(($smtpd->command('MAIL FROM:ask@perl.org'))[0],
|
||||||
is($smtpd->transaction->sender->format, '<ask@perl.org>', 'got the right sender');
|
250, 'MAIL FROM:ask@perl.org');
|
||||||
|
is($smtpd->transaction->sender->format,
|
||||||
|
'<ask@perl.org>', 'got the right sender');
|
||||||
|
|
||||||
is(($smtpd->command('MAIL FROM:ask@[1.2.3.4]'))[0], 250, 'MAIL FROM:ask@[1.2.3.4]');
|
is(($smtpd->command('MAIL FROM:ask@[1.2.3.4]'))[0],
|
||||||
is($smtpd->transaction->sender->format, '<ask@[1.2.3.4]>', 'got the right sender');
|
250, 'MAIL FROM:ask@[1.2.3.4]');
|
||||||
|
is($smtpd->transaction->sender->format,
|
||||||
|
'<ask@[1.2.3.4]>', 'got the right sender');
|
||||||
|
|
||||||
my $command = 'MAIL FROM:<ask@perl.org> SIZE=1230';
|
my $command = 'MAIL FROM:<ask@perl.org> SIZE=1230';
|
||||||
is(($smtpd->command($command))[0], 250, $command);
|
is(($smtpd->command($command))[0], 250, $command);
|
||||||
is($smtpd->transaction->sender->format, '<ask@perl.org>', 'got the right sender');
|
is($smtpd->transaction->sender->format,
|
||||||
|
'<ask@perl.org>', 'got the right sender');
|
||||||
|
|
||||||
$command = 'MAIL FROM:<>';
|
$command = 'MAIL FROM:<>';
|
||||||
is(($smtpd->command($command))[0], 250, $command);
|
is(($smtpd->command($command))[0], 250, $command);
|
||||||
is($smtpd->transaction->sender->format, '<>', 'got the right sender');
|
is($smtpd->transaction->sender->format, '<>', 'got the right sender');
|
||||||
|
|
||||||
$command = 'MAIL FROM:<ask@p.qpsmtpd-test.askask.com> SIZE=1230';
|
$command = 'MAIL FROM:<ask@p.qpsmtpd-test.askask.com> SIZE=1230';
|
||||||
is(($smtpd->command($command))[0], 250, $command);
|
is(($smtpd->command($command))[0], 250, $command);
|
||||||
is($smtpd->transaction->sender->format, '<ask@p.qpsmtpd-test.askask.com>', 'got the right sender');
|
is($smtpd->transaction->sender->format,
|
||||||
|
'<ask@p.qpsmtpd-test.askask.com>',
|
||||||
|
'got the right sender');
|
||||||
|
|
||||||
$command = 'MAIL FROM:<ask@perl.org> SIZE=1230 CORRECT-WITHOUT-ARG';
|
$command = 'MAIL FROM:<ask@perl.org> SIZE=1230 CORRECT-WITHOUT-ARG';
|
||||||
is(($smtpd->command($command))[0], 250, $command);
|
is(($smtpd->command($command))[0], 250, $command);
|
||||||
|
|
||||||
$command = 'MAIL FROM:';
|
$command = 'MAIL FROM:';
|
||||||
is(($smtpd->command($command))[0], 250, $command);
|
is(($smtpd->command($command))[0], 250, $command);
|
||||||
is($smtpd->transaction->sender->format, '<>', 'got the right sender');
|
is($smtpd->transaction->sender->format, '<>', 'got the right sender');
|
||||||
|
|
||||||
|
|
||||||
|
122
t/auth.t
122
t/auth.t
@ -19,119 +19,121 @@ use_ok('Qpsmtpd::Auth');
|
|||||||
|
|
||||||
my ($smtpd, $conn) = Test::Qpsmtpd->new_conn();
|
my ($smtpd, $conn) = Test::Qpsmtpd->new_conn();
|
||||||
|
|
||||||
ok( $smtpd, "get new connection ($smtpd)");
|
ok($smtpd, "get new connection ($smtpd)");
|
||||||
isa_ok( $conn, 'Qpsmtpd::Connection', "get new connection");
|
isa_ok($conn, 'Qpsmtpd::Connection', "get new connection");
|
||||||
|
|
||||||
#warn Dumper($smtpd) and exit;
|
#warn Dumper($smtpd) and exit;
|
||||||
#my $hooks = $smtpd->hooks;
|
#my $hooks = $smtpd->hooks;
|
||||||
#warn Dumper($hooks) and exit;
|
#warn Dumper($hooks) and exit;
|
||||||
|
|
||||||
my $r;
|
my $r;
|
||||||
my $user = 'good@example.com';
|
my $user = 'good@example.com';
|
||||||
my $pass = 'good_pass';
|
my $pass = 'good_pass';
|
||||||
my $enc_plain= Qpsmtpd::Auth::e64( join("\0", '', $user, $pass ) );
|
my $enc_plain = Qpsmtpd::Auth::e64(join("\0", '', $user, $pass));
|
||||||
|
|
||||||
# get_auth_details_plain: plain auth method handles credentials properly
|
# get_auth_details_plain: plain auth method handles credentials properly
|
||||||
my ($loginas,$ruser,$passClear) = Qpsmtpd::Auth::get_auth_details_plain($smtpd, $enc_plain);
|
my ($loginas, $ruser, $passClear) =
|
||||||
cmp_ok( $user, 'eq', $user, "get_auth_details_plain, user");
|
Qpsmtpd::Auth::get_auth_details_plain($smtpd, $enc_plain);
|
||||||
cmp_ok( $passClear, 'eq', $pass, "get_auth_details_plain, password");
|
cmp_ok($user, 'eq', $user, "get_auth_details_plain, user");
|
||||||
|
cmp_ok($passClear, 'eq', $pass, "get_auth_details_plain, password");
|
||||||
|
|
||||||
my $bad_auth = Qpsmtpd::Auth::e64( join("\0", 'loginas', 'user@foo', 'passer') );
|
my $bad_auth = Qpsmtpd::Auth::e64(join("\0", 'loginas', 'user@foo', 'passer'));
|
||||||
($loginas,$ruser,$passClear) = Qpsmtpd::Auth::get_auth_details_plain($smtpd, $bad_auth );
|
($loginas, $ruser, $passClear) =
|
||||||
ok( ! $loginas, "get_auth_details_plain, loginas -");
|
Qpsmtpd::Auth::get_auth_details_plain($smtpd, $bad_auth);
|
||||||
ok( !$ruser, "get_auth_details_plain, user -");
|
ok(!$loginas, "get_auth_details_plain, loginas -");
|
||||||
ok( !$passClear, "get_auth_details_plain, pass -");
|
ok(!$ruser, "get_auth_details_plain, user -");
|
||||||
|
ok(!$passClear, "get_auth_details_plain, pass -");
|
||||||
|
|
||||||
# these plugins test against whicever loaded plugin provides their selected
|
# these plugins test against whicever loaded plugin provides their selected
|
||||||
# auth type. Right now, they end up testing against auth_flat_file.
|
# auth type. Right now, they end up testing against auth_flat_file.
|
||||||
|
|
||||||
# PLAIN
|
# PLAIN
|
||||||
$r = Qpsmtpd::Auth::SASL($smtpd, 'plain', $enc_plain);
|
$r = Qpsmtpd::Auth::SASL($smtpd, 'plain', $enc_plain);
|
||||||
cmp_ok( OK, '==', $r, "plain auth");
|
cmp_ok(OK, '==', $r, "plain auth");
|
||||||
|
|
||||||
if ( $ENV{QPSMTPD_DEVELOPER} && is_interactive() ) {
|
if ($ENV{QPSMTPD_DEVELOPER} && is_interactive()) {
|
||||||
# same thing, but must be entered interactively
|
|
||||||
|
# same thing, but must be entered interactively
|
||||||
print "answer: $enc_plain\n";
|
print "answer: $enc_plain\n";
|
||||||
$r = Qpsmtpd::Auth::SASL($smtpd, 'plain', '');
|
$r = Qpsmtpd::Auth::SASL($smtpd, 'plain', '');
|
||||||
cmp_ok( OK, '==', $r, "SASL, plain");
|
cmp_ok(OK, '==', $r, "SASL, plain");
|
||||||
};
|
}
|
||||||
|
|
||||||
|
|
||||||
# LOGIN
|
# LOGIN
|
||||||
|
|
||||||
if ( $ENV{QPSMTPD_DEVELOPER} && is_interactive() ) {
|
if ($ENV{QPSMTPD_DEVELOPER} && is_interactive()) {
|
||||||
|
|
||||||
my $enc_user = Qpsmtpd::Auth::e64( $user );
|
my $enc_user = Qpsmtpd::Auth::e64($user);
|
||||||
my $enc_pass = Qpsmtpd::Auth::e64( $pass );
|
my $enc_pass = Qpsmtpd::Auth::e64($pass);
|
||||||
|
|
||||||
# get_base64_response
|
# get_base64_response
|
||||||
print "answer: $enc_user\n";
|
print "answer: $enc_user\n";
|
||||||
$r = Qpsmtpd::Auth::get_base64_response( $smtpd, 'Username' );
|
$r = Qpsmtpd::Auth::get_base64_response($smtpd, 'Username');
|
||||||
cmp_ok( $r, 'eq', $user, "get_base64_response +");
|
cmp_ok($r, 'eq', $user, "get_base64_response +");
|
||||||
|
|
||||||
# get_auth_details_login
|
# get_auth_details_login
|
||||||
print "answer: $enc_pass\n";
|
print "answer: $enc_pass\n";
|
||||||
($ruser,$passClear) = Qpsmtpd::Auth::get_auth_details_login( $smtpd, $enc_user );
|
($ruser, $passClear) =
|
||||||
cmp_ok( $ruser, 'eq', $user, "get_auth_details_login, user +");
|
Qpsmtpd::Auth::get_auth_details_login($smtpd, $enc_user);
|
||||||
cmp_ok( $passClear, 'eq', $pass, "get_auth_details_login, pass +");
|
cmp_ok($ruser, 'eq', $user, "get_auth_details_login, user +");
|
||||||
|
cmp_ok($passClear, 'eq', $pass, "get_auth_details_login, pass +");
|
||||||
|
|
||||||
print "encoded pass: $enc_pass\n";
|
print "encoded pass: $enc_pass\n";
|
||||||
$r = Qpsmtpd::Auth::SASL($smtpd, 'login', $enc_user);
|
$r = Qpsmtpd::Auth::SASL($smtpd, 'login', $enc_user);
|
||||||
cmp_ok( OK, '==', $r, "SASL, login");
|
cmp_ok(OK, '==', $r, "SASL, login");
|
||||||
};
|
}
|
||||||
|
|
||||||
|
|
||||||
# CRAM-MD5
|
# CRAM-MD5
|
||||||
|
|
||||||
if ( $ENV{QPSMTPD_DEVELOPER} && is_interactive() ) {
|
if ($ENV{QPSMTPD_DEVELOPER} && is_interactive()) {
|
||||||
print "starting SASL\n";
|
print "starting SASL\n";
|
||||||
|
|
||||||
# since we don't have bidirection communication here, we pre-generate a ticket
|
# since we don't have bidirection communication here, we pre-generate a ticket
|
||||||
my $ticket = sprintf( '<%x.%x@%s>', rand(1000000), time(), $smtpd->config('me') );
|
my $ticket =
|
||||||
my $hash_pass = hmac_md5_hex( $ticket, $pass );
|
sprintf('<%x.%x@%s>', rand(1000000), time(), $smtpd->config('me'));
|
||||||
my $enc_answer = Qpsmtpd::Auth::e64( join(' ', $user, $hash_pass ) );
|
my $hash_pass = hmac_md5_hex($ticket, $pass);
|
||||||
|
my $enc_answer = Qpsmtpd::Auth::e64(join(' ', $user, $hash_pass));
|
||||||
print "answer: $enc_answer\n";
|
print "answer: $enc_answer\n";
|
||||||
my (@r) = Qpsmtpd::Auth::get_auth_details_cram_md5( $smtpd, $ticket );
|
my (@r) = Qpsmtpd::Auth::get_auth_details_cram_md5($smtpd, $ticket);
|
||||||
cmp_ok( $r[0], 'eq', $ticket, "get_auth_details_cram_md5, ticket" );
|
cmp_ok($r[0], 'eq', $ticket, "get_auth_details_cram_md5, ticket");
|
||||||
cmp_ok( $r[1], 'eq', $user, "get_auth_details_cram_md5, user" );
|
cmp_ok($r[1], 'eq', $user, "get_auth_details_cram_md5, user");
|
||||||
cmp_ok( $r[2], 'eq', $hash_pass, "get_auth_details_cram_md5, passHash" );
|
cmp_ok($r[2], 'eq', $hash_pass, "get_auth_details_cram_md5, passHash");
|
||||||
#warn Data::Dumper::Dumper(\@r);
|
|
||||||
|
|
||||||
# this isn't going to work without bidirection communication to get the ticket
|
#warn Data::Dumper::Dumper(\@r);
|
||||||
#$r = Qpsmtpd::Auth::SASL($smtpd, 'cram-md5' );
|
|
||||||
#cmp_ok( OK, '==', $r, "login auth");
|
|
||||||
};
|
|
||||||
|
|
||||||
|
# this isn't going to work without bidirection communication to get the ticket
|
||||||
|
#$r = Qpsmtpd::Auth::SASL($smtpd, 'cram-md5' );
|
||||||
|
#cmp_ok( OK, '==', $r, "login auth");
|
||||||
|
}
|
||||||
|
|
||||||
sub is_interactive {
|
sub is_interactive {
|
||||||
|
|
||||||
## no critic
|
## no critic
|
||||||
# borrowed from IO::Interactive
|
# borrowed from IO::Interactive
|
||||||
my ($out_handle) = ( @_, select ); # Default to default output handle
|
my ($out_handle) = (@_, select); # Default to default output handle
|
||||||
|
|
||||||
# Not interactive if output is not to terminal...
|
# Not interactive if output is not to terminal...
|
||||||
return if not -t $out_handle;
|
return if not -t $out_handle;
|
||||||
|
|
||||||
# If *ARGV is opened, we're interactive if...
|
# If *ARGV is opened, we're interactive if...
|
||||||
if ( openhandle * ARGV ) {
|
if (openhandle * ARGV) {
|
||||||
|
|
||||||
# ...it's currently opened to the magic '-' file
|
# ...it's currently opened to the magic '-' file
|
||||||
return -t *STDIN if defined $ARGV && $ARGV eq '-';
|
return -t *STDIN if defined $ARGV && $ARGV eq '-';
|
||||||
|
|
||||||
# ...it's at end-of-file and the next file is the magic '-' file
|
# ...it's at end-of-file and the next file is the magic '-' file
|
||||||
return @ARGV > 0 && $ARGV[0] eq '-' && -t *STDIN if eof *ARGV;
|
return @ARGV > 0 && $ARGV[0] eq '-' && -t *STDIN if eof *ARGV;
|
||||||
|
|
||||||
# ...it's directly attached to the terminal
|
# ...it's directly attached to the terminal
|
||||||
return -t *ARGV;
|
return -t *ARGV;
|
||||||
};
|
}
|
||||||
|
|
||||||
# If *ARGV isn't opened, it will be interactive if *STDIN is attached
|
# If *ARGV isn't opened, it will be interactive if *STDIN is attached
|
||||||
# to a terminal and either there are no files specified on the command line
|
# to a terminal and either there are no files specified on the command line
|
||||||
# or if there are files and the first is the magic '-' file
|
# or if there are files and the first is the magic '-' file
|
||||||
return -t *STDIN && ( @ARGV == 0 || $ARGV[0] eq '-' );
|
return -t *STDIN && (@ARGV == 0 || $ARGV[0] eq '-');
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
__END__
|
__END__
|
||||||
|
|
||||||
if ( ref $r ) {
|
if ( ref $r ) {
|
||||||
|
19
t/config.t
19
t/config.t
@ -7,15 +7,15 @@ use_ok('Test::Qpsmtpd');
|
|||||||
|
|
||||||
my @mes;
|
my @mes;
|
||||||
|
|
||||||
BEGIN { # need this to happen before anything else
|
BEGIN { # need this to happen before anything else
|
||||||
my $cwd = `pwd`;
|
my $cwd = `pwd`;
|
||||||
chomp($cwd);
|
chomp($cwd);
|
||||||
@mes = qw{ ./config.sample/me ./t/config/me };
|
@mes = qw{ ./config.sample/me ./t/config/me };
|
||||||
foreach my $f ( @mes ) {
|
foreach my $f (@mes) {
|
||||||
open my $me_config, '>', $f;
|
open my $me_config, '>', $f;
|
||||||
print $me_config "some.host.example.org";
|
print $me_config "some.host.example.org";
|
||||||
close $me_config;
|
close $me_config;
|
||||||
};
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
||||||
@ -25,12 +25,13 @@ is($smtpd->config('me'), 'some.host.example.org', 'config("me")');
|
|||||||
# test for ignoring leading/trailing whitespace (relayclients has a
|
# test for ignoring leading/trailing whitespace (relayclients has a
|
||||||
# line with both)
|
# line with both)
|
||||||
my $relayclients = join ",", sort $smtpd->config('relayclients');
|
my $relayclients = join ",", sort $smtpd->config('relayclients');
|
||||||
is($relayclients,
|
is(
|
||||||
'127.0.0.1,192.0.,2001:0DB8,2001:0DB8:0000:0000:0000:0000:0000:0001,2001:DB8::1,2001:DB8::1/32',
|
$relayclients,
|
||||||
'config("relayclients") are trimmed');
|
'127.0.0.1,192.0.,2001:0DB8,2001:0DB8:0000:0000:0000:0000:0000:0001,2001:DB8::1,2001:DB8::1/32',
|
||||||
|
'config("relayclients") are trimmed'
|
||||||
|
);
|
||||||
|
|
||||||
foreach my $f ( @mes ) {
|
foreach my $f (@mes) {
|
||||||
unlink $f if -f $f;
|
unlink $f if -f $f;
|
||||||
};
|
}
|
||||||
|
|
||||||
|
|
||||||
|
6
t/misc.t
6
t/misc.t
@ -8,10 +8,8 @@ ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
|||||||
# fault method
|
# fault method
|
||||||
is(($smtpd->fault)->[0], 451, 'fault returns 451');
|
is(($smtpd->fault)->[0], 451, 'fault returns 451');
|
||||||
is(($smtpd->fault("test message"))->[1],
|
is(($smtpd->fault("test message"))->[1],
|
||||||
"Internal error - try again later - test message",
|
"Internal error - try again later - test message",
|
||||||
'returns the input message'
|
'returns the input message');
|
||||||
);
|
|
||||||
|
|
||||||
|
|
||||||
# vrfy command
|
# vrfy command
|
||||||
is(($smtpd->command('VRFY <foo@bar>'))[0], 252, 'VRFY command');
|
is(($smtpd->command('VRFY <foo@bar>'))[0], 252, 'VRFY command');
|
||||||
|
@ -7,11 +7,8 @@ my $qp = Test::Qpsmtpd->new();
|
|||||||
|
|
||||||
$qp->run_plugin_tests();
|
$qp->run_plugin_tests();
|
||||||
|
|
||||||
foreach my $file (
|
foreach my $file ("./t/config/greylist.dbm", "./t/config/greylist.dbm.lock") {
|
||||||
"./t/config/greylist.dbm",
|
next if !-f $file;
|
||||||
"./t/config/greylist.dbm.lock"
|
|
||||||
) {
|
|
||||||
next if ! -f $file;
|
|
||||||
unlink $file;
|
unlink $file;
|
||||||
};
|
}
|
||||||
|
|
||||||
|
@ -13,96 +13,96 @@ my $ao;
|
|||||||
|
|
||||||
$as = '<>';
|
$as = '<>';
|
||||||
$ao = Qpsmtpd::Address->parse($as);
|
$ao = Qpsmtpd::Address->parse($as);
|
||||||
ok ($ao, "parse $as");
|
ok($ao, "parse $as");
|
||||||
is ($ao->format, $as, "format $as");
|
is($ao->format, $as, "format $as");
|
||||||
|
|
||||||
$as = '<postmaster>';
|
$as = '<postmaster>';
|
||||||
$ao = Qpsmtpd::Address->parse($as);
|
$ao = Qpsmtpd::Address->parse($as);
|
||||||
ok ($ao, "parse $as");
|
ok($ao, "parse $as");
|
||||||
is ($ao->format, $as, "format $as");
|
is($ao->format, $as, "format $as");
|
||||||
|
|
||||||
$as = '<foo@example.com>';
|
$as = '<foo@example.com>';
|
||||||
$ao = Qpsmtpd::Address->parse($as);
|
$ao = Qpsmtpd::Address->parse($as);
|
||||||
ok ($ao, "parse $as");
|
ok($ao, "parse $as");
|
||||||
is ($ao->format, $as, "format $as");
|
is($ao->format, $as, "format $as");
|
||||||
|
|
||||||
is ($ao->user, 'foo', 'user');
|
is($ao->user, 'foo', 'user');
|
||||||
is ($ao->host, 'example.com', 'host');
|
is($ao->host, 'example.com', 'host');
|
||||||
|
|
||||||
# the \ before the @ in the local part is not required, but
|
# the \ before the @ in the local part is not required, but
|
||||||
# allowed. For simplicity we add a backslash before all characters
|
# allowed. For simplicity we add a backslash before all characters
|
||||||
# which are not allowed in a dot-string.
|
# which are not allowed in a dot-string.
|
||||||
$as = '<"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at>';
|
$as = '<"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at>';
|
||||||
$ao = Qpsmtpd::Address->parse($as);
|
$ao = Qpsmtpd::Address->parse($as);
|
||||||
ok ($ao, "parse $as");
|
ok($ao, "parse $as");
|
||||||
is ($ao->format, '<"musa_ibrah\@caramail.comandrea.luger"@wifo.ac.at>', "format $as");
|
is($ao->format, '<"musa_ibrah\@caramail.comandrea.luger"@wifo.ac.at>',
|
||||||
|
"format $as");
|
||||||
|
|
||||||
# email addresses with spaces
|
# email addresses with spaces
|
||||||
$as = '<foo bar@example.com>';
|
$as = '<foo bar@example.com>';
|
||||||
$ao = Qpsmtpd::Address->parse($as);
|
$ao = Qpsmtpd::Address->parse($as);
|
||||||
ok ($ao, "parse $as");
|
ok($ao, "parse $as");
|
||||||
is ($ao->format, '<"foo\ bar"@example.com>', "format $as");
|
is($ao->format, '<"foo\ bar"@example.com>', "format $as");
|
||||||
|
|
||||||
$as = 'foo@example.com';
|
$as = 'foo@example.com';
|
||||||
$ao = Qpsmtpd::Address->new($as);
|
$ao = Qpsmtpd::Address->new($as);
|
||||||
ok ($ao, "new $as");
|
ok($ao, "new $as");
|
||||||
is ($ao->address, $as, "address $as");
|
is($ao->address, $as, "address $as");
|
||||||
|
|
||||||
$as = '<foo@example.com>';
|
$as = '<foo@example.com>';
|
||||||
$ao = Qpsmtpd::Address->new($as);
|
$ao = Qpsmtpd::Address->new($as);
|
||||||
ok ($ao, "new $as");
|
ok($ao, "new $as");
|
||||||
is ($ao->address, 'foo@example.com', "address $as");
|
is($ao->address, 'foo@example.com', "address $as");
|
||||||
|
|
||||||
$as = '<foo@foo.x.example.com>';
|
$as = '<foo@foo.x.example.com>';
|
||||||
$ao = Qpsmtpd::Address->new($as);
|
$ao = Qpsmtpd::Address->new($as);
|
||||||
ok ($ao, "new $as");
|
ok($ao, "new $as");
|
||||||
is ($ao->format, $as, "format $as");
|
is($ao->format, $as, "format $as");
|
||||||
|
|
||||||
$as = 'foo@foo.x.example.com';
|
$as = 'foo@foo.x.example.com';
|
||||||
ok ($ao = Qpsmtpd::Address->parse('<'.$as.'>'), "parse $as");
|
ok($ao = Qpsmtpd::Address->parse('<' . $as . '>'), "parse $as");
|
||||||
is ($ao && $ao->address, $as, "address $as");
|
is($ao && $ao->address, $as, "address $as");
|
||||||
|
|
||||||
# Not sure why we can change the address like this, but we can so test it ...
|
# Not sure why we can change the address like this, but we can so test it ...
|
||||||
is ($ao && $ao->address('test@example.com'), 'test@example.com', 'address(test@example.com)');
|
is($ao && $ao->address('test@example.com'),
|
||||||
|
'test@example.com', 'address(test@example.com)');
|
||||||
|
|
||||||
$as = '<foo@foo.x.example.com>';
|
$as = '<foo@foo.x.example.com>';
|
||||||
$ao = Qpsmtpd::Address->new($as);
|
$ao = Qpsmtpd::Address->new($as);
|
||||||
ok ($ao, "new $as");
|
ok($ao, "new $as");
|
||||||
is ($ao->format, $as, "format $as");
|
is($ao->format, $as, "format $as");
|
||||||
is ("$ao", $as, "overloaded stringify $as");
|
is("$ao", $as, "overloaded stringify $as");
|
||||||
|
|
||||||
$as = 'foo@foo.x.example.com';
|
$as = 'foo@foo.x.example.com';
|
||||||
ok ($ao = Qpsmtpd::Address->parse("<$as>"), "parse <$as>");
|
ok($ao = Qpsmtpd::Address->parse("<$as>"), "parse <$as>");
|
||||||
is ($ao && $ao->address, $as, "address $as");
|
is($ao && $ao->address, $as, "address $as");
|
||||||
ok ($ao eq $as, "overloaded 'cmp' operator");
|
ok($ao eq $as, "overloaded 'cmp' operator");
|
||||||
|
|
||||||
my @unsorted_list = map { Qpsmtpd::Address->new($_) }
|
my @unsorted_list = map { Qpsmtpd::Address->new($_) } qw(
|
||||||
qw(
|
"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at
|
||||||
"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at
|
foo@example.com
|
||||||
foo@example.com
|
ask@perl.org
|
||||||
ask@perl.org
|
foo@foo.x.example.com
|
||||||
foo@foo.x.example.com
|
jpeacock@cpan.org
|
||||||
jpeacock@cpan.org
|
test@example.com
|
||||||
test@example.com
|
);
|
||||||
);
|
|
||||||
|
|
||||||
# NOTE that this is sorted by _host_ not by _domain_
|
# NOTE that this is sorted by _host_ not by _domain_
|
||||||
my @sorted_list = map { Qpsmtpd::Address->new($_) }
|
my @sorted_list = map { Qpsmtpd::Address->new($_) } qw(
|
||||||
qw(
|
jpeacock@cpan.org
|
||||||
jpeacock@cpan.org
|
foo@example.com
|
||||||
foo@example.com
|
test@example.com
|
||||||
test@example.com
|
foo@foo.x.example.com
|
||||||
foo@foo.x.example.com
|
ask@perl.org
|
||||||
ask@perl.org
|
"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at
|
||||||
"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at
|
);
|
||||||
);
|
|
||||||
|
|
||||||
my @test_list = sort @unsorted_list;
|
my @test_list = sort @unsorted_list;
|
||||||
|
|
||||||
is_deeply( \@test_list, \@sorted_list, "sort via overloaded 'cmp' operator");
|
is_deeply(\@test_list, \@sorted_list, "sort via overloaded 'cmp' operator");
|
||||||
|
|
||||||
# RT#38746 - non-RFC compliant address should return undef
|
# RT#38746 - non-RFC compliant address should return undef
|
||||||
|
|
||||||
$as='<user@example.com#>';
|
$as = '<user@example.com#>';
|
||||||
$ao = Qpsmtpd::Address->new($as);
|
$ao = Qpsmtpd::Address->new($as);
|
||||||
is ($ao, undef, "illegal $as");
|
is($ao, undef, "illegal $as");
|
||||||
|
10
t/rset.t
10
t/rset.t
@ -7,7 +7,9 @@ use_ok('Test::Qpsmtpd');
|
|||||||
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
||||||
is(($smtpd->command('EHLO localhost'))[0], 250, 'EHLO localhost');
|
is(($smtpd->command('EHLO localhost'))[0], 250, 'EHLO localhost');
|
||||||
|
|
||||||
is(($smtpd->command('MAIL FROM:<ask@perl.org>'))[0], 250, 'MAIL FROM:<ask@perl.org>');
|
is(($smtpd->command('MAIL FROM:<ask@perl.org>'))[0],
|
||||||
is($smtpd->transaction->sender->address, 'ask@perl.org', 'got the right sender');
|
250, 'MAIL FROM:<ask@perl.org>');
|
||||||
is(($smtpd->command('RSET'))[0], 250, 'RSET');
|
is($smtpd->transaction->sender->address, 'ask@perl.org',
|
||||||
is($smtpd->transaction->sender, undef, 'No sender stored after rset');
|
'got the right sender');
|
||||||
|
is(($smtpd->command('RSET'))[0], 250, 'RSET');
|
||||||
|
is($smtpd->transaction->sender, undef, 'No sender stored after rset');
|
||||||
|
@ -5,7 +5,7 @@ use strict;
|
|||||||
use lib 't';
|
use lib 't';
|
||||||
use_ok('Test::Qpsmtpd');
|
use_ok('Test::Qpsmtpd');
|
||||||
|
|
||||||
BEGIN { # need this to happen before anything else
|
BEGIN { # need this to happen before anything else
|
||||||
my $cwd = `pwd`;
|
my $cwd = `pwd`;
|
||||||
chomp($cwd);
|
chomp($cwd);
|
||||||
open my $spooldir, '>', "./config.sample/spool_dir";
|
open my $spooldir, '>', "./config.sample/spool_dir";
|
||||||
@ -15,13 +15,13 @@ BEGIN { # need this to happen before anything else
|
|||||||
|
|
||||||
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
||||||
|
|
||||||
my ($spool_dir,$tempfile,$tempdir) = ( $smtpd->spool_dir,
|
my ($spool_dir, $tempfile, $tempdir) =
|
||||||
$smtpd->temp_file(), $smtpd->temp_dir() );
|
($smtpd->spool_dir, $smtpd->temp_file(), $smtpd->temp_dir());
|
||||||
|
|
||||||
ok( $spool_dir =~ m!t/tmp/$!, "Located the spool directory");
|
ok($spool_dir =~ m!t/tmp/$!, "Located the spool directory");
|
||||||
ok( $tempfile =~ /^$spool_dir/, "Temporary filename" );
|
ok($tempfile =~ /^$spool_dir/, "Temporary filename");
|
||||||
ok( $tempdir =~ /^$spool_dir/, "Temporary directory" );
|
ok($tempdir =~ /^$spool_dir/, "Temporary directory");
|
||||||
ok( -d $tempdir, "And that directory exists" );
|
ok(-d $tempdir, "And that directory exists");
|
||||||
|
|
||||||
unlink "./config.sample/spool_dir";
|
unlink "./config.sample/spool_dir";
|
||||||
rmtree($spool_dir);
|
rmtree($spool_dir);
|
||||||
|
@ -4,38 +4,39 @@ use English qw/ -no_match_vars /;
|
|||||||
use File::Find;
|
use File::Find;
|
||||||
use Test::More;
|
use Test::More;
|
||||||
|
|
||||||
if ( ! $ENV{'QPSMTPD_DEVELOPER'} ) {
|
if (!$ENV{'QPSMTPD_DEVELOPER'}) {
|
||||||
plan skip_all => "not a developer, skipping POD tests";
|
plan skip_all => "not a developer, skipping POD tests";
|
||||||
};
|
}
|
||||||
|
|
||||||
use lib 'lib';
|
use lib 'lib';
|
||||||
|
|
||||||
my $this_perl = $Config{'perlpath'} || $EXECUTABLE_NAME;
|
my $this_perl = $Config{'perlpath'} || $EXECUTABLE_NAME;
|
||||||
|
|
||||||
my @files = find( {wanted=>\&test_syntax, no_chdir=>1}, 'plugins', 'lib', 't' );
|
my @files =
|
||||||
|
find({wanted => \&test_syntax, no_chdir => 1}, 'plugins', 'lib', 't');
|
||||||
|
|
||||||
sub test_syntax {
|
sub test_syntax {
|
||||||
my $f = $File::Find::name;
|
my $f = $File::Find::name;
|
||||||
chomp $f;
|
chomp $f;
|
||||||
return if ! -f $f;
|
return if !-f $f;
|
||||||
return if $f =~ m/(~|\.(bak|orig|rej))/;
|
return if $f =~ m/(~|\.(bak|orig|rej))/;
|
||||||
my $r;
|
my $r;
|
||||||
eval { $r = `$this_perl -Ilib -MQpsmtpd::Constants -c $f 2>&1`; };
|
eval { $r = `$this_perl -Ilib -MQpsmtpd::Constants -c $f 2>&1`; };
|
||||||
my $exit_code = sprintf ("%d", $CHILD_ERROR >> 8);
|
my $exit_code = sprintf("%d", $CHILD_ERROR >> 8);
|
||||||
if ( $exit_code == 0 ) {
|
if ($exit_code == 0) {
|
||||||
ok( $exit_code == 0, "syntax $f");
|
ok($exit_code == 0, "syntax $f");
|
||||||
return;
|
|
||||||
};
|
|
||||||
if ( $r =~ /^Can't locate (.*?) in / ) {
|
|
||||||
ok( 0 == 0, "skipping $f, I couldn't load w/o $1");
|
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
if ( $r =~ /^Base class package "Danga::Socket" is empty/ ) {
|
if ($r =~ /^Can't locate (.*?) in /) {
|
||||||
ok( 0 == 0, "skipping $f, Danga::Socket not available.");
|
ok(0 == 0, "skipping $f, I couldn't load w/o $1");
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
if ($r =~ /^Base class package "Danga::Socket" is empty/) {
|
||||||
|
ok(0 == 0, "skipping $f, Danga::Socket not available.");
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
print "ec: $exit_code, r: $r\n";
|
print "ec: $exit_code, r: $r\n";
|
||||||
};
|
}
|
||||||
|
|
||||||
done_testing();
|
done_testing();
|
||||||
|
|
||||||
|
@ -2,17 +2,17 @@
|
|||||||
|
|
||||||
use Test::More;
|
use Test::More;
|
||||||
|
|
||||||
if ( ! $ENV{'QPSMTPD_DEVELOPER'} ) {
|
if (!$ENV{'QPSMTPD_DEVELOPER'}) {
|
||||||
plan skip_all => "not a developer, skipping POD tests";
|
plan skip_all => "not a developer, skipping POD tests";
|
||||||
exit;
|
exit;
|
||||||
}
|
}
|
||||||
|
|
||||||
eval "use Test::Pod 1.14";
|
eval "use Test::Pod 1.14";
|
||||||
if ( $@ ) {
|
if ($@) {
|
||||||
plan skip_all => "Test::Pod 1.14 required for testing POD";
|
plan skip_all => "Test::Pod 1.14 required for testing POD";
|
||||||
exit;
|
exit;
|
||||||
};
|
}
|
||||||
|
|
||||||
my @poddirs = qw( lib plugins );
|
my @poddirs = qw( lib plugins );
|
||||||
all_pod_files_ok( all_pod_files( @poddirs ) );
|
all_pod_files_ok(all_pod_files(@poddirs));
|
||||||
done_testing();
|
done_testing();
|
||||||
|
Loading…
Reference in New Issue
Block a user