byterazor/qpsmtpd
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge pull request #101 from msimerson/tidy

Browse Source 
META updates, tidy, PBP tweaks
This commit is contained in:
Jared Johnson 2014-09-15 20:48:05 -05:00
commit 2a303538e5
9 changed files with 291 additions and 247 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
MANIFEST
View File

@ -143,6 +143,7 @@ plugins/stunnel
plugins/tls
plugins/tls_cert
plugins/uribl
plugins/user_config
plugins/virus/aveclient
plugins/virus/bitdefender
plugins/virus/clamav
@ -205,6 +206,7 @@ t/plugin_tests/relay
t/plugin_tests/resolvable_fromhost
t/plugin_tests/sender_permitted_from
t/plugin_tests/spamassassin
t/plugin_tests/user_config
t/plugin_tests/virus/clamdscan
t/qpsmtpd-address.t
t/qpsmtpd-smtp.t

97
lib/Qpsmtpd.pm
View File

@ -1,5 +1,6 @@
package Qpsmtpd;
use strict;
#use warnings;
use vars qw($TraceLevel $Spool_dir $Size_threshold);
@ -7,7 +8,7 @@ use Sys::Hostname;
use Qpsmtpd::Constants;
use Qpsmtpd::Address;
our $VERSION = "0.94";
our $VERSION = "0.95";
my $git;
@ -91,7 +92,7 @@ sub load_logging {
sub trace_level { return $TraceLevel; }
sub init_logger { # needed for compatibility purposes
sub init_logger { # needed for compatibility purposes
shift->trace_level();
}
@ -103,17 +104,17 @@ sub log {
sub varlog {
my ($self, $trace) = (shift, shift);
my ($hook, $plugin, @log);
if ($#_ == 0) { # log itself
if ($#_ == 0) { # log itself
(@log) = @_;
}
elsif ($#_ == 1) { # plus the hook
elsif ($#_ == 1) { # plus the hook
($hook, @log) = @_;
}
else { # called from plugin
else { # called from plugin
($hook, $plugin, @log) = @_;
}
$self->load_logging; # in case we don't have this loaded yet
$self->load_logging; # in case we don't have this loaded yet
my ($rc) =
$self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log)
@ -146,26 +147,34 @@ sub config {
$self->log(LOGDEBUG, "in config($c)");
# first run the hooks
# first run the user_config hooks
my ($rc, @config);
($rc, @config) = $self->run_hooks_no_respond('user_config',$type,$c)
if ref $type and $type->can('address');
return wantarray ? @config : $config[0]
if defined $rc and $rc == OK;
($rc, @config) = $self->run_hooks_no_respond('config',$c);
$self->log(LOGDEBUG, "config($c): hook returned ("
. join( ',', map { defined $_ ? $_ : 'undef' } ($rc,@config) ) . ")");
return wantarray ? @config : $config[0]
if defined $rc and $rc == OK;
if (ref $type && $type->can('address')) {
($rc, @config) = $self->run_hooks_no_respond('user_config', $type, $c);
if (defined $rc && $rc == OK) {
return wantarray ? @config : $config[0];
};
};
# and then get_qmail_config
# then run the config hooks
($rc, @config) = $self->run_hooks_no_respond('config', $c);
$self->log(LOGDEBUG,
"config($c): hook returned ("
. join(',', map { defined $_ ? $_ : 'undef' } ($rc, @config))
. ")"
);
if (defined $rc && $rc == OK) {
return wantarray ? @config : $config[0];
};
# then get_qmail_config
@config = $self->get_qmail_config($c, $type);
return wantarray ? @config : $config[0]
if @config;
return wantarray ? @config : $config[0] if @config;
# finally we use the default if there is any:
return wantarray ? ($defaults{$c}) : $defaults{$c}
if exists $defaults{$c};
# then the default, if any
if (exists $defaults{$c}) {
return wantarray ? ($defaults{$c}) : $defaults{$c};
};
return;
}
@ -205,7 +214,7 @@ sub get_qmail_config {
# CDB config support really should be moved to a plugin
if ($type and $type eq "map") {
return $self->get_qmail_config_map($config, $configfile);
};
}
return $self->_config_from_file($configfile, $config);
}
@ -236,7 +245,7 @@ sub get_qmail_config_map {
# the data is in a CDB file in the first place because there's
# lots of data and the cache hit ratio would be low.
return \%h;
};
}
sub _config_from_file {
my ($self, $configfile, $config, $visited) = @_;
@ -357,13 +366,13 @@ sub _load_plugin {
my ($plugin_line, @plugin_dirs) = @_;
# untaint the config data before passing it to plugins
my ($safe_line) = $plugin_line =~ /^([ -~]+)$/ # all ascii printable
or die "unsafe characters in config line: $plugin_line\n";
my ($safe_line) = $plugin_line =~ /^([ -~]+)$/ # all ascii printable
or die "unsafe characters in config line: $plugin_line\n";
my ($plugin, @args) = split /\s+/, $safe_line;
if ($plugin =~ m/::/) {
return $self->_load_package_plugin($plugin, $safe_line, \@args);
};
}
# regular plugins/$plugin plugin
my $plugin_name = $plugin;
@ -383,19 +392,19 @@ sub _load_plugin {
my $package = "Qpsmtpd::Plugin::$plugin_name";
# don't reload plugins if they are already loaded
unless (defined &{"${package}::plugin_name"}) {
if (!defined &{"${package}::plugin_name"}) {
PLUGIN_DIR: for my $dir (@plugin_dirs) {
if (-e "$dir/$plugin") {
Qpsmtpd::Plugin->compile($plugin_name, $package,
"$dir/$plugin", $self->{_test_mode}, $plugin);
$self->log(LOGDEBUG, "Loading $safe_line from $dir/$plugin")
unless $safe_line =~ /logging/;
last PLUGIN_DIR;
}
next if !-e "$dir/$plugin";
Qpsmtpd::Plugin->compile($plugin_name, $package,
"$dir/$plugin", $self->{_test_mode}, $plugin);
if ($safe_line !~ /logging/) {
$self->log(LOGDEBUG, "Loading $safe_line from $dir/$plugin");
};
last PLUGIN_DIR;
}
die "Plugin $plugin_name not found in our plugin dirs (",
join(", ", @plugin_dirs), ")"
unless defined &{"${package}::plugin_name"};
if (! defined &{"${package}::plugin_name"}) {
die "Plugin $plugin_name not found in our plugin dirs (", join(', ', @plugin_dirs), ")";
};
}
my $plug = $package->new();
@ -406,23 +415,25 @@ sub _load_plugin {
sub _load_package_plugin {
my ($self, $plugin, $plugin_line, $args) = @_;
# "full" package plugin (My::Plugin)
my $package = $plugin;
$package =~ s/[^_a-z0-9:]+//gi;
my $eval = qq[require $package;\n]
. qq[sub ${plugin}::plugin_name { '$plugin' }];
my $eval =
qq[require $package;\n] . qq[sub ${plugin}::plugin_name { '$plugin' }];
$eval =~ m/(.*)/s;
$eval = $1;
eval $eval;
die "Failed loading $package - eval $@" if $@;
$self->log(LOGDEBUG, "Loading $package ($plugin_line)")
unless $plugin_line =~ /logging/;
if ($plugin_line !~ /logging/) {
$self->log(LOGDEBUG, "Loading $package ($plugin_line)");
};
my $plug = $package->new();
$plug->_register($self, @$args);
return $plug;
};
}
sub transaction { return {}; } # base class implements empty transaction

4
lib/Qpsmtpd/Address.pm
View File

@ -352,9 +352,9 @@ sub qp {
}
sub config {
my ($self,$key) = @_;
my ($self, $key) = @_;
my $qp = $self->qp or return;
return $qp->config($key,$self);
return $qp->config($key, $self);
}
sub _addr_cmp {

75
lib/Qpsmtpd/SMTP.pm
View File

@ -4,6 +4,7 @@ use strict;
use base 'Qpsmtpd';
use Carp;
#use Data::Dumper;
use POSIX qw(strftime);
use Mail::Header;
@ -30,10 +31,9 @@ sub new {
my $self = bless({args => \%args}, $class);
# this list of valid commands should probably be a method or a set of methods
$self->{_commands} = {
map { $_ => '' } qw(ehlo helo rset mail rcpt data help vrfy noop quit)
};
# this list of valid commands should probably be a method or a set of methods
$self->{_commands} =
{map { $_ => '' } qw(ehlo helo rset mail rcpt data help vrfy noop quit)};
$self->SUPER::_restart(%args) if $args{restart}; # calls Qpsmtpd::_restart()
$self;
@ -87,7 +87,7 @@ sub fault {
my ($name) = split /\s+/, $0, 2;
print STDERR $name, "[$$]: $msg\n";
print STDERR $name, "[$$]: Last system error: $!"
." (Likely irelevant--debug the crashed plugin to ensure it handles \$! properly)";
. " (Likely irelevant--debug the crashed plugin to ensure it handles \$! properly)";
return $self->respond(451, "Internal error - try again later - " . $msg);
}
@ -260,11 +260,12 @@ sub ehlo_respond {
}
# Check if we should only offer AUTH after TLS is completed
my $tls_before_auth =
($self->config('tls_before_auth')
? ($self->config('tls_before_auth'))[0]
&& $self->transaction->notes('tls_enabled')
: 0);
my $tls_before_auth = (
$self->config('tls_before_auth')
? ($self->config('tls_before_auth'))[0]
&& $self->transaction->notes('tls_enabled')
: 0
);
if (%auth_mechanisms && !$tls_before_auth) {
push @capabilities, 'AUTH ' . join(" ", keys(%auth_mechanisms));
$self->{_commands}->{'auth'} = "";
@ -789,53 +790,57 @@ sub authentication_results {
my ($self) = @_;
my @auth_list = $self->config('me');
# $self->clean_authentication_results();
if ( ! defined $self->{_auth} ) {
# $self->clean_authentication_results();
if (!defined $self->{_auth}) {
push @auth_list, 'auth=none';
}
else {
my $mechanism = "(" . $self->{_auth_mechanism} . ")";
my $user = "smtp.auth=" . $self->{_auth_user};
if ( $self->{_auth} == OK) {
my $user = "smtp.auth=" . $self->{_auth_user};
if ($self->{_auth} == OK) {
push @auth_list, "auth=pass $mechanism $user";
}
else {
push @auth_list, "auth=fail $mechanism $user";
};
};
}
}
# RFC 5451: used in AUTH, DKIM, DOMAINKEYS, SENDERID, SPF
if ( $self->connection->notes('authentication_results') ) {
if ($self->connection->notes('authentication_results')) {
push @auth_list, $self->connection->notes('authentication_results');
};
}
$self->log(LOGDEBUG, "adding auth results header" );
$self->transaction->header->add('Authentication-Results', join('; ', @auth_list), 0);
};
$self->log(LOGDEBUG, "adding auth results header");
$self->transaction->header->add('Authentication-Results',
join('; ', @auth_list), 0);
}
sub clean_authentication_results {
my $self = shift;
# http://tools.ietf.org/html/draft-kucherawy-original-authres-00.html
# http://tools.ietf.org/html/draft-kucherawy-original-authres-00.html
# On messages received from the internet, move Authentication-Results headers
# to Original-AR, so our downstream can trust the A-R header we insert.
# On messages received from the internet, move Authentication-Results headers
# to Original-AR, so our downstream can trust the A-R header we insert.
# TODO: Do not invalidate DKIM signatures.
# if $self->transaction->header->get('DKIM-Signature')
# Parse the DKIM signature(s)
# return if A-R header is signed;
# }
# TODO: Do not invalidate DKIM signatures.
# if $self->transaction->header->get('DKIM-Signature')
# Parse the DKIM signature(s)
# return if A-R header is signed;
# }
my @ar_headers = $self->transaction->header->get('Authentication-Results');
for ( my $i = 0; $i < scalar @ar_headers; $i++ ) {
for (my $i = 0 ; $i < scalar @ar_headers ; $i++) {
$self->transaction->header->delete('Authentication-Results', $i);
$self->transaction->header->add('Original-Authentication-Results', $ar_headers[$i]);
$self->transaction->header->add('Original-Authentication-Results',
$ar_headers[$i]);
}
$self->log(LOGDEBUG, "Authentication-Results moved to Original-Authentication-Results" );
};
$self->log(LOGDEBUG,
"Authentication-Results moved to Original-Authentication-Results");
}
sub received_line {
my ($self) = @_;
@ -870,7 +875,7 @@ sub received_line {
return join("\n", @received);
}
else { # assume $rc == DECLINED
$header_str =
$header_str =
"from "
. $self->connection->remote_info
. " (HELO "
@ -883,7 +888,7 @@ sub received_line {
. ") with $sslheader$smtp; "
. (strftime('%a, %d %b %Y %H:%M:%S %z', localtime));
}
$self->transaction->header->add('Received', $header_str, 0 );
$self->transaction->header->add('Received', $header_str, 0);
}
sub data_post_respond {

2
packaging/rpm/VERSION
View File

@ -1 +1 @@
0.94
0.95

16
plugins/user_config
View File

@ -28,24 +28,26 @@ in separate directories similar to the global qpsmtpd config directory.
=cut
sub init {
my ( $self, $qp, $pattern ) = @_;
my ($self, $qp, $pattern) = @_;
$self->{pattern} = $pattern || '/home/%u/.qpsmtpd';
}
sub hook_user_config {
my ($self,$txn,$addr,$conf) = @_;
my ($self, $txn, $addr, $conf) = @_;
my $path = $self->{pattern} or return DECLINED;
my ( $user, $host, $address ) = ( $addr->user, $addr->host, $addr->address );
my ($user, $host, $address) = ($addr->user, $addr->host, $addr->address);
$path =~ s/%u/$user/g;
$path =~ s/%h/$host/g;
$path =~ s/%a/$address/g;
my $filename = "$path/$conf";
return DECLINED unless -f $filename;
my $fh;
unless (open $fh,$filename) {
$self->log(LOGNOTICE,"Couldn't open $filename:$!");
unless (open $fh, $filename) {
$self->log(LOGNOTICE, "Couldn't open $filename:$!");
return DECLINED;
}
map {chomp} (my @return = (<$fh>));
return OK,@return;
my @return = <$fh>;
chomp @return;
return OK, @return;
}

36
t/plugin_tests/user_config
View File

@ -19,32 +19,40 @@ sub register_tests {
}
sub test_hook_user_config {
my ( $self ) = @_;
my ($self) = @_;
my $dirname = $self->qp->temp_dir;
$self->{pattern} = $dirname . '/%u_%h_%a';
$dirname .= '/testuser_testhost_testaddress';
-d $dirname
or mkdir($dirname, 0700)
or die "Could not create $dirname: $!";
or mkdir($dirname, 0700)
or die "Could not create $dirname: $!";
open my $fh, '>', "$dirname/testfield";
print $fh "testdata";
close $fh;
my $a = FakeAddress->new( user => 'testuser', host => 'testhost', address => 'testaddress' );
my ( $r, $value ) = $self->hook_user_config( $self->qp->transaction, $a, 'testfield' );
is( $r, OK, 'hook_user_config returned OK when config file present' );
is( $value, 'testdata', 'hook_user_config returned the correct value' );
( $r, $value ) = $self->hook_user_config( $self->qp->transaction, $a, 'noconfig' );
is( $r, DECLINED, 'hook_user_config returned DECLINED when no config file present' );
is( $value, undef, 'hook_user_config returned no value when no config file present' );
my $a = FakeAddress->new(
user => 'testuser',
host => 'testhost',
address => 'testaddress'
);
my ($r, $value) =
$self->hook_user_config($self->qp->transaction, $a, 'testfield');
is($r, OK, 'hook_user_config returned OK when config file present');
is($value, 'testdata', 'hook_user_config returned the correct value');
($r, $value) =
$self->hook_user_config($self->qp->transaction, $a, 'noconfig');
is($r, DECLINED,
'hook_user_config returned DECLINED when no config file present');
is($value, undef,
'hook_user_config returned no value when no config file present');
rmtree($dirname);
}
package FakeAddress;
sub new {
shift;
return bless {@_};
shift;
return bless {@_};
}
sub address { return shift->{address} }
sub user { return shift->{user} }
sub host { return shift->{host} }
sub user { return shift->{user} }
sub host { return shift->{host} }

112
t/qpsmtpd-address.t
View File

@ -22,29 +22,29 @@ sub __new {
my ($as, $ao);
my @unsorted_list = map { Qpsmtpd::Address->new($_) } qw(
"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at
foo@example.com
ask@perl.org
foo@foo.x.example.com
jpeacock@cpan.org
test@example.com
);
"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at
foo@example.com
ask@perl.org
foo@foo.x.example.com
jpeacock@cpan.org
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($_) } qw(
jpeacock@cpan.org
foo@example.com
test@example.com
foo@foo.x.example.com
ask@perl.org
"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at
);
jpeacock@cpan.org
foo@example.com
test@example.com
foo@foo.x.example.com
ask@perl.org
"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at
);
my @test_list = sort @unsorted_list;
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#>';
$ao = Qpsmtpd::Address->new($as);
@ -72,16 +72,16 @@ sub __parse {
is($ao->user, 'foo', 'user');
is($ao->host, 'example.com', 'host');
# the \ before the @ in the local part is not required, but
# allowed. For simplicity we add a backslash before all characters
# which are not allowed in a dot-string.
# the \ before the @ in the local part is not required, but
# allowed. For simplicity we add a backslash before all characters
# which are not allowed in a dot-string.
$as = '<"musa_ibrah@caramail.comandrea.luger"@wifo.ac.at>';
$ao = Qpsmtpd::Address->parse($as);
ok($ao, "parse $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>';
$ao = Qpsmtpd::Address->parse($as);
ok($ao, "parse $as");
@ -106,7 +106,7 @@ sub __parse {
ok($ao = Qpsmtpd::Address->parse('<' . $as . '>'), "parse $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)');
@ -120,44 +120,48 @@ sub __parse {
ok($ao = Qpsmtpd::Address->parse("<$as>"), "parse <$as>");
is($ao && $ao->address, $as, "address $as");
ok($ao eq $as, "overloaded 'cmp' operator");
};
}
sub __config {
ok( my ($qp,$cxn) = Test::Qpsmtpd->new_conn(), "get new connection" );
ok( $qp->command('HELO test') );
ok( $qp->command('MAIL FROM:<test@example.com>') );
ok(my ($qp, $cxn) = Test::Qpsmtpd->new_conn(), "get new connection");
ok($qp->command('HELO test'));
ok($qp->command('MAIL FROM:<test@example.com>'));
my $sender = $qp->transaction->sender;
my @test_data = (
{
pref => 'size_threshold',
result => [],
expected => 10000,
descr => 'fall back to global config when user_config is absent',
},
{
pref => 'test_config',
result => [],
expected => undef,
descr => 'return nothing when no user_config plugins exist',
},
{
pref => 'test_config',
result => [DECLINED],
expected => undef,
descr => 'return nothing when user_config plugins return DECLINED',
},
{
pref => 'test_config',
result => [OK,'test value'],
expected => 'test value',
descr => 'return results when user_config plugin returns a value',
},
{
pref => 'size_threshold',
result => [],
expected => 10000,
descr => 'fall back to global config when user_config is absent',
},
{
pref => 'test_config',
result => [],
expected => undef,
descr => 'return nothing when no user_config plugins exist',
},
{
pref => 'test_config',
result => [DECLINED],
expected => undef,
descr => 'return nothing when user_config plugins return DECLINED',
},
{
pref => 'test_config',
result => [OK, 'test value'],
expected => 'test value',
descr => 'return results when user_config plugin returns a value',
},
);
for (@test_data) {
$qp->hooks->{user_config}
= @{ $_->{result} }
? [{ name => 'test hook', code => sub { return @{ $_->{result} }} }]
: undef;
is( $sender->config($_->{pref}), $_->{expected}, $_->{descr} );
$qp->hooks->{user_config} = @{$_->{result}}
? [
{
name => 'test hook',
code => sub { return @{$_->{result}} }
}
]
: undef;
is($sender->config($_->{pref}), $_->{expected}, $_->{descr});
}
}

194
t/qpsmtpd.t
View File

@ -5,7 +5,8 @@ use warnings;
use Data::Dumper;
use Test::More;
use lib 'lib'; # test lib/Qpsmtpd (vs site_perl)
use lib 'lib'; # test lib/Qpsmtpd (vs site_perl)
BEGIN {
use_ok('Qpsmtpd');
use_ok('Qpsmtpd::Constants');
@ -16,8 +17,8 @@ use_ok('Test::Qpsmtpd');
my $qp = bless {}, 'Qpsmtpd';
ok( $qp->version(), "version, " . $qp->version());
is_deeply( Qpsmtpd::hooks(), {}, 'hooks, empty');
ok($qp->version(), "version, " . $qp->version());
is_deeply(Qpsmtpd::hooks(), {}, 'hooks, empty');
__authenticated();
__config_dir();
@ -29,157 +30,168 @@ __load_logging();
done_testing();
sub __get_qmail_config {
ok( !$qp->get_qmail_config('me'), "get_qmail_config, me");
ok(!$qp->get_qmail_config('me'), "get_qmail_config, me");
# TODO: add positive tests.
};
}
sub __config_from_file {
# $configfile, $config, $visited
};
}
sub __log {
my $warned = '';
local $SIG{__WARN__} = sub {
if ( $_[0] eq "$$ test log message\n" ) {
if ($_[0] eq "$$ test log message\n") {
$warned = join ' ', @_;
}
else {
warn @_;
}
};
ok( $qp->log(LOGWARN, "test log message"), 'log');
is( $warned, "$$ test log message\n", 'LOGWARN emitted correct warning' );
ok($qp->log(LOGWARN, "test log message"), 'log');
is($warned, "$$ test log message\n", 'LOGWARN emitted correct warning');
}
sub __config_dir {
my $dir = $qp->config_dir('logging');
ok( $dir, "config_dir, $dir");
ok($dir, "config_dir, $dir");
#warn Data::Dumper::Dumper($Qpsmtpd::config_dir_memo{logging});
$dir = $Qpsmtpd::config_dir_memo{logging};
ok( $dir, "config_dir, $dir (memo)");
};
ok($dir, "config_dir, $dir (memo)");
}
sub __load_logging {
$Qpsmtpd::LOGGING_LOADED = 1;
ok( !$qp->load_logging(), "load_logging, loaded");
ok(!$qp->load_logging(), "load_logging, loaded");
$Qpsmtpd::LOGGING_LOADED = 0;
$Qpsmtpd::hooks->{logging} = 1;
ok( !$qp->load_logging(), "load_logging, logging hook");
ok(!$qp->load_logging(), "load_logging, logging hook");
$Qpsmtpd::hooks->{logging} = undef; # restore
$Qpsmtpd::hooks->{logging} = undef; # restore
}
sub __authenticated {
ok( ! $qp->authenticated(), "authenticated, undef");
ok(!$qp->authenticated(), "authenticated, undef");
$qp->{_auth} = 1;
ok( $qp->authenticated(), "authenticated, true");
ok($qp->authenticated(), "authenticated, true");
$qp->{_auth} = 0;
ok( !$qp->authenticated(), "authenticated, false");
};
ok(!$qp->authenticated(), "authenticated, false");
}
sub __config {
my @r = $qp->config('badhelo');
ok( $r[0], "config, badhelo, @r");
my $a = FakeAddress->new( test => 'test value' );
ok( my ($qp,$cxn) = Test::Qpsmtpd->new_conn(), "get new connection" );
ok($r[0], "config, badhelo, @r");
my $a = FakeAddress->new(test => 'test value');
ok(my ($qp, $cxn) = Test::Qpsmtpd->new_conn(), "get new connection");
my @test_data = (
{
pref => 'size_threshold',
hooks => {
user_config => [],
config => [],
},
expected => {
user => 10000,
global => 10000,
},
descr => 'no user or global config hooks, fall back to config file',
pref => 'size_threshold',
hooks => {
user_config => [],
config => [],
},
expected => {
user => 10000,
global => 10000,
},
descr => 'no user or global config hooks, fall back to config file',
},
{
pref => 'timeout',
hooks => {
user_config => [],
config => [],
},
expected => {
user => 1200,
global => 1200,
},
descr => 'no user or global config hooks, fall back to defaults',
pref => 'timeout',
hooks => {
user_config => [],
config => [],
},
expected => {
user => 1200,
global => 1200,
},
descr => 'no user or global config hooks, fall back to defaults',
},
{
pref => 'timeout',
hooks => {
user_config => [DECLINED],
config => [DECLINED],
},
expected => {
user => 1200,
global => 1200,
},
descr => 'user and global config hooks decline, fall back to defaults',
pref => 'timeout',
hooks => {
user_config => [DECLINED],
config => [DECLINED],
},
expected => {
user => 1200,
global => 1200,
},
descr => 'user and global config hooks decline, fall back to defaults',
},
{
pref => 'timeout',
hooks => {
user_config => [DECLINED],
config => [OK,1000],
},
expected => {
user => 1000,
global => 1000,
},
descr => 'user hook declines, global hook returns',
pref => 'timeout',
hooks => {
user_config => [DECLINED],
config => [OK, 1000],
},
expected => {
user => 1000,
global => 1000,
},
descr => 'user hook declines, global hook returns',
},
{
pref => 'timeout',
hooks => {
user_config => [OK,500],
config => [OK,undef],
},
expected => {
user => 500,
global => undef,
},
descr => 'user hook returns int, global hook returns undef',
pref => 'timeout',
hooks => {
user_config => [OK, 500],
config => [OK, undef],
},
expected => {
user => 500,
global => undef,
},
descr => 'user hook returns int, global hook returns undef',
},
{
pref => 'timeout',
hooks => {
user_config => [OK,undef],
config => [OK,1000],
},
expected => {
user => undef,
global => 1000,
},
descr => 'user hook returns undef, global hook returns int',
pref => 'timeout',
hooks => {
user_config => [OK, undef],
config => [OK, 1000],
},
expected => {
user => undef,
global => 1000,
},
descr => 'user hook returns undef, global hook returns int',
},
);
for my $t (@test_data) {
for my $hook (qw( config user_config )) {
$qp->hooks->{$hook}
= @{ $t->{hooks}{$hook} }
? [{ name => 'test hook', code => sub { return @{ $t->{hooks}{$hook} }} }]
: undef;
$qp->hooks->{$hook} = @{$t->{hooks}{$hook}}
? [
{
name => 'test hook',
code => sub { return @{$t->{hooks}{$hook}} }
}
]
: undef;
}
is( $qp->config($t->{pref},$a), $t->{expected}{user}, "User config: $t->{descr}");
is( $qp->config($t->{pref}), $t->{expected}{global}, "Global config: $t->{descr}");
is(
$qp->config($t->{pref}, $a),
$t->{expected}{user},
"User config: $t->{descr}"
);
is($qp->config($t->{pref}),
$t->{expected}{global},
"Global config: $t->{descr}");
}
}
package FakeAddress;
sub new {
shift;
return bless {@_};
shift;
return bless {@_};
}
sub address { } # pass the can('address') conditional
sub address { } # pass the can('address') conditional