META updates, tidy, PBP tweaks
* update manifest * perltidy * replace postfix if/unless with brackets * reduce useless indention by exiting sooner
This commit is contained in:
Matt Simerson
parent
41a7b24275
commit
851e1b54ee
2
MANIFEST
2
MANIFEST
@ -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
|
||||
|
||||
@ -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)
|
||||
@ -148,24 +149,30 @@ sub config {
|
||||
|
||||
# first run the 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];
|
||||
};
|
||||
($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];
|
||||
};
|
||||
|
||||
# and then get_qmail_config
|
||||
# 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 +212,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 +243,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 +364,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 +390,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 +413,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
|
||||
|
||||
|
||||
@ -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 {
|
||||
|
||||
@ -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) = @_;
|
||||
@ -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 {
|
||||
|
||||
@ -1 +1 @@
|
||||
0.94
|
||||
0.95
|
||||
|
||||
@ -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;
|
||||
}
|
||||
|
||||
@ -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} }
|
||||
|
||||
@ -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
194
t/qpsmtpd.t
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user