extracted config*() from Qpsmtpd.pm -> Config.pm
* includes full test converage for Qpsmtpd::Config
* folded t/config.t into t/qpsmtpd-config.t
* includes additional tests for Qpsmtpd
* folded t/tempstuff into t/qpsmtpd.t
* PBP adjustments here and there
* other tweaks to handle test warnings
This commit is contained in:
Matt Simerson
parent
79d2b99211
commit
ebdb25a4bd
6
MANIFEST
6
MANIFEST
@ -41,6 +41,7 @@ lib/Qpsmtpd/Address.pm
|
||||
lib/Qpsmtpd/Auth.pm
|
||||
lib/Qpsmtpd/Base.pm
|
||||
lib/Qpsmtpd/Command.pm
|
||||
lib/Qpsmtpd/Config.pm
|
||||
lib/Qpsmtpd/ConfigServer.pm
|
||||
lib/Qpsmtpd/Connection.pm
|
||||
lib/Qpsmtpd/Constants.pm
|
||||
@ -166,7 +167,6 @@ run.tcpserver
|
||||
STATUS
|
||||
t/addresses.t
|
||||
t/auth.t
|
||||
t/config.t
|
||||
t/config/badhelo
|
||||
t/config/badrcptto
|
||||
t/config/dnsbl_allow
|
||||
@ -178,6 +178,8 @@ t/config/plugins
|
||||
t/config/public_suffix_list
|
||||
t/config/rcpthosts
|
||||
t/config/relayclients
|
||||
t/config/size_threshold
|
||||
t/config/test_config_file
|
||||
t/helo.t
|
||||
t/misc.t
|
||||
t/plugin_tests.t
|
||||
@ -210,10 +212,10 @@ t/plugin_tests/user_config
|
||||
t/plugin_tests/virus/clamdscan
|
||||
t/qpsmtpd-address.t
|
||||
t/qpsmtpd-base.t
|
||||
t/qpsmtpd-config.t
|
||||
t/qpsmtpd-smtp.t
|
||||
t/qpsmtpd.t
|
||||
t/rset.t
|
||||
t/tempstuff.t
|
||||
t/Test/Qpsmtpd.pm
|
||||
t/Test/Qpsmtpd/Plugin.pm
|
||||
UPGRADING.pod
|
||||
|
||||
209
lib/Qpsmtpd.pm
209
lib/Qpsmtpd.pm
@ -5,11 +5,10 @@ use strict;
|
||||
our $VERSION = "0.95";
|
||||
use vars qw($TraceLevel $Spool_dir $Size_threshold);
|
||||
|
||||
use Sys::Hostname;
|
||||
|
||||
use lib 'lib';
|
||||
use base 'Qpsmtpd::Base';
|
||||
use Qpsmtpd::Address;
|
||||
use Qpsmtpd::Config;
|
||||
use Qpsmtpd::Constants;
|
||||
|
||||
my $git;
|
||||
@ -21,12 +20,6 @@ if (-e ".git") {
|
||||
}
|
||||
|
||||
our $hooks = {};
|
||||
my %defaults = (
|
||||
me => hostname,
|
||||
timeout => 1200,
|
||||
);
|
||||
my $_config_cache = {};
|
||||
our %config_dir_memo;
|
||||
|
||||
our $LOGGING_LOADED = 0;
|
||||
|
||||
@ -36,10 +29,9 @@ sub _restart {
|
||||
if ($args{restart}) {
|
||||
|
||||
# reset all global vars to defaults
|
||||
$self->clear_config_cache;
|
||||
$self->conf->clear_cache();
|
||||
$hooks = {};
|
||||
$LOGGING_LOADED = 0;
|
||||
%config_dir_memo = ();
|
||||
$TraceLevel = LOGWARN;
|
||||
$Spool_dir = undef;
|
||||
$Size_threshold = undef;
|
||||
@ -60,11 +52,11 @@ sub load_logging {
|
||||
|
||||
my $configdir = $self->config_dir("logging");
|
||||
my $configfile = "$configdir/logging";
|
||||
my @loggers = $self->_config_from_file($configfile, 'logging');
|
||||
my @loggers = $self->conf->from_file($configfile, 'logging');
|
||||
|
||||
$configdir = $self->config_dir('plugin_dirs');
|
||||
$configfile = "$configdir/plugin_dirs";
|
||||
my @plugin_dirs = $self->_config_from_file($configfile, 'plugin_dirs');
|
||||
my @plugin_dirs = $self->conf->from_file($configfile, 'plugin_dirs');
|
||||
unless (@plugin_dirs) {
|
||||
my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
|
||||
@plugin_dirs = ("$name/plugins");
|
||||
@ -81,7 +73,7 @@ sub load_logging {
|
||||
|
||||
$configdir = $self->config_dir("loglevel");
|
||||
$configfile = "$configdir/loglevel";
|
||||
$TraceLevel = $self->_config_from_file($configfile, 'loglevel');
|
||||
$TraceLevel = $self->conf->from_file($configfile, 'loglevel');
|
||||
|
||||
unless (defined($TraceLevel) and $TraceLevel =~ /^\d+$/) {
|
||||
$TraceLevel = LOGWARN; # Default if no loglevel file found.
|
||||
@ -94,7 +86,7 @@ sub load_logging {
|
||||
|
||||
sub trace_level { return $TraceLevel; }
|
||||
|
||||
sub init_logger { # needed for compatibility purposes
|
||||
sub init_logger { # needed for compatibility
|
||||
shift->trace_level();
|
||||
}
|
||||
|
||||
@ -106,17 +98,11 @@ sub log {
|
||||
sub varlog {
|
||||
my ($self, $trace) = (shift, shift);
|
||||
my ($hook, $plugin, @log);
|
||||
if ($#_ == 0) { # log itself
|
||||
(@log) = @_;
|
||||
}
|
||||
elsif ($#_ == 1) { # plus the hook
|
||||
($hook, @log) = @_;
|
||||
}
|
||||
else { # called from plugin
|
||||
($hook, $plugin, @log) = @_;
|
||||
}
|
||||
if ($#_ == 0) { (@log) = @_; } # log itself
|
||||
elsif ($#_ == 1) { ($hook, @log) = @_; } # plus the hook
|
||||
else { ($hook, $plugin, @log) = @_; } # from a plugin
|
||||
|
||||
$self->load_logging; # in case we don't have this loaded yet
|
||||
$self->load_logging;
|
||||
|
||||
my ($rc) =
|
||||
$self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log)
|
||||
@ -135,15 +121,14 @@ sub varlog {
|
||||
warn join(' ', $$ . $prefix, @log), "\n";
|
||||
}
|
||||
|
||||
sub clear_config_cache {
|
||||
$_config_cache = {};
|
||||
sub conf {
|
||||
my $self = shift;
|
||||
if (!$self->{_config}) {
|
||||
$self->{_config} = Qpsmtpd::Config->new();
|
||||
};
|
||||
return $self->{_config};
|
||||
}
|
||||
|
||||
#
|
||||
# method to get the configuration. It just calls get_qmail_config by
|
||||
# default, but it could be overwritten to look configuration up in a
|
||||
# database or whatever.
|
||||
#
|
||||
sub config {
|
||||
my ($self, $c, $type) = @_;
|
||||
|
||||
@ -169,30 +154,17 @@ sub config {
|
||||
return wantarray ? @config : $config[0];
|
||||
};
|
||||
|
||||
# then get_qmail_config
|
||||
@config = $self->get_qmail_config($c, $type);
|
||||
# then qmail
|
||||
@config = $self->conf->get_qmail($c, $type);
|
||||
return wantarray ? @config : $config[0] if @config;
|
||||
|
||||
# then the default, if any
|
||||
if (exists $defaults{$c}) {
|
||||
return wantarray ? ($defaults{$c}) : $defaults{$c};
|
||||
};
|
||||
return;
|
||||
# then the default, which may be undefined
|
||||
return $self->conf->default($c);
|
||||
}
|
||||
|
||||
sub config_dir {
|
||||
my ($self, $config) = @_;
|
||||
if (exists $config_dir_memo{$config}) {
|
||||
return $config_dir_memo{$config};
|
||||
}
|
||||
my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control';
|
||||
my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!;
|
||||
$configdir = "$path/config" if -e "$path/config/$config";
|
||||
if (exists $ENV{QPSMTPD_CONFIG}) {
|
||||
$ENV{QPSMTPD_CONFIG} =~ /^(.*)$/; # detaint
|
||||
$configdir = $1 if -e "$1/$config";
|
||||
}
|
||||
return $config_dir_memo{$config} = $configdir;
|
||||
my $self = shift;
|
||||
return $self->conf->config_dir(@_);
|
||||
}
|
||||
|
||||
sub plugin_dirs {
|
||||
@ -206,143 +178,6 @@ sub plugin_dirs {
|
||||
return @plugin_dirs;
|
||||
}
|
||||
|
||||
sub get_qmail_config {
|
||||
my ($self, $config, $type) = @_;
|
||||
$self->log(LOGDEBUG, "trying to get config for $config");
|
||||
my $configdir = $self->config_dir($config);
|
||||
|
||||
my $configfile = "$configdir/$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);
|
||||
}
|
||||
|
||||
sub get_qmail_config_map {
|
||||
my ($self, $config, $configfile) = @_;
|
||||
|
||||
unless (-e $configfile . ".cdb") {
|
||||
$_config_cache->{$config} ||= [];
|
||||
return +{};
|
||||
}
|
||||
eval { require CDB_File };
|
||||
|
||||
if ($@) {
|
||||
$self->log(LOGERROR,
|
||||
"No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@"
|
||||
);
|
||||
return +{};
|
||||
}
|
||||
|
||||
my %h;
|
||||
unless (tie(%h, 'CDB_File', "$configfile.cdb")) {
|
||||
$self->log(LOGERROR, "tie of $configfile.cdb failed: $!");
|
||||
return +{};
|
||||
}
|
||||
|
||||
# We explicitly don't cache cdb entries. The assumption is that
|
||||
# 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) = @_;
|
||||
unless (-e $configfile) {
|
||||
$_config_cache->{$config} ||= [];
|
||||
return;
|
||||
}
|
||||
|
||||
$visited ||= [];
|
||||
push @$visited, $configfile;
|
||||
|
||||
open my $CF, '<', $configfile or do {
|
||||
warn "$$ could not open configfile $configfile: $!";
|
||||
return;
|
||||
};
|
||||
my @config = <$CF>;
|
||||
close $CF;
|
||||
|
||||
chomp @config;
|
||||
@config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/ } @config;
|
||||
for (@config) { s/^\s+//; s/\s+$//; } # trim leading/trailing whitespace
|
||||
|
||||
my $pos = 0;
|
||||
while ($pos < @config) {
|
||||
|
||||
# recursively pursue an $include reference, if found. An inclusion which
|
||||
# begins with a leading slash is interpreted as a path to a file and will
|
||||
# supercede the usual config path resolution. Otherwise, the normal
|
||||
# config_dir() lookup is employed (the location in which the inclusion
|
||||
# appeared receives no special precedence; possibly it should, but it'd
|
||||
# be complicated beyond justifiability for so simple a config system.
|
||||
if ($config[$pos] =~ /^\s*\$include\s+(\S+)\s*$/) {
|
||||
my ($includedir, $inclusion) = ('', $1);
|
||||
|
||||
splice @config, $pos, 1; # remove the $include line
|
||||
if ($inclusion !~ /^\//) {
|
||||
$includedir = $self->config_dir($inclusion);
|
||||
$inclusion = "$includedir/$inclusion";
|
||||
}
|
||||
|
||||
if (grep($_ eq $inclusion, @{$visited})) {
|
||||
$self->log(LOGERROR,
|
||||
"Circular \$include reference in config $config:");
|
||||
$self->log(LOGERROR, "From $visited->[0]:");
|
||||
$self->log(LOGERROR, " includes $_")
|
||||
for (@{$visited}[1 .. $#{$visited}], $inclusion);
|
||||
return wantarray ? () : undef;
|
||||
}
|
||||
push @{$visited}, $inclusion;
|
||||
|
||||
for my $inc ($self->expand_inclusion_($inclusion, $configfile)) {
|
||||
my @insertion =
|
||||
$self->_config_from_file($inc, $config, $visited);
|
||||
splice @config, $pos, 0, @insertion; # insert the inclusion
|
||||
$pos += @insertion;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$pos++;
|
||||
}
|
||||
}
|
||||
|
||||
$_config_cache->{$config} = \@config;
|
||||
|
||||
return wantarray ? @config : $config[0];
|
||||
}
|
||||
|
||||
sub expand_inclusion_ {
|
||||
my $self = shift;
|
||||
my $inclusion = shift;
|
||||
my $context = shift;
|
||||
my @includes;
|
||||
|
||||
if (-d $inclusion) {
|
||||
$self->log(LOGDEBUG, "inclusion of directory $inclusion from $context");
|
||||
|
||||
if (opendir(INCD, $inclusion)) {
|
||||
@includes = map { "$inclusion/$_" }
|
||||
(grep { -f "$inclusion/$_" and !/^\./ } sort readdir INCD);
|
||||
closedir INCD;
|
||||
}
|
||||
else {
|
||||
$self->log(LOGERROR,
|
||||
"Couldn't open directory $inclusion,"
|
||||
. " referenced from $context ($!)"
|
||||
);
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->log(LOGDEBUG, "inclusion of file $inclusion from $context");
|
||||
@includes = ($inclusion);
|
||||
}
|
||||
return @includes;
|
||||
}
|
||||
|
||||
sub load_plugins {
|
||||
my $self = shift;
|
||||
|
||||
|
||||
@ -3,6 +3,10 @@ use strict;
|
||||
|
||||
use Net::IP;
|
||||
|
||||
sub new {
|
||||
return bless {}, shift;
|
||||
};
|
||||
|
||||
sub tildeexp {
|
||||
my ($self, $path) = @_;
|
||||
$path =~ s{^~([^/]*)} {
|
||||
|
||||
192
lib/Qpsmtpd/Config.pm
Normal file
192
lib/Qpsmtpd/Config.pm
Normal file
@ -0,0 +1,192 @@
|
||||
package Qpsmtpd::Config;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Sys::Hostname;
|
||||
|
||||
use lib 'lib';
|
||||
use parent 'Qpsmtpd::Base';
|
||||
use Qpsmtpd::Constants;
|
||||
|
||||
our $_config_cache = {};
|
||||
our %dir_memo;
|
||||
our %defaults = (
|
||||
me => hostname,
|
||||
timeout => 1200,
|
||||
);
|
||||
|
||||
sub log {
|
||||
my ($self, $trace, @log) = @_;
|
||||
# logging methods attempt to read config files, this log() prevents that
|
||||
# until after logging has fully loaded
|
||||
return if $trace > LOGWARN;
|
||||
no warnings 'once';
|
||||
if ($Qpsmtpd::LOGGING_LOADED) {
|
||||
return Qpsmtpd->log($trace, @log);
|
||||
}
|
||||
warn join(' ', $$, @log) . "\n";
|
||||
}
|
||||
|
||||
sub config_dir {
|
||||
my ($self, $config) = @_;
|
||||
if (exists $dir_memo{$config}) {
|
||||
return $dir_memo{$config};
|
||||
}
|
||||
my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control';
|
||||
my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!;
|
||||
$configdir = "$path/config" if -e "$path/config/$config";
|
||||
if (exists $ENV{QPSMTPD_CONFIG}) {
|
||||
$ENV{QPSMTPD_CONFIG} =~ /^(.*)$/; # detaint
|
||||
$configdir = $1 if -e "$1/$config";
|
||||
}
|
||||
return $dir_memo{$config} = $configdir;
|
||||
}
|
||||
|
||||
sub clear_cache {
|
||||
$_config_cache = {};
|
||||
%dir_memo = ();
|
||||
}
|
||||
|
||||
sub default {
|
||||
my ($self, $def) = @_;
|
||||
return if ! $defaults{$def};
|
||||
return wantarray ? ($defaults{$def}) : $defaults{$def};
|
||||
}
|
||||
|
||||
sub get_qmail {
|
||||
my ($self, $config, $type) = @_;
|
||||
$self->log(LOGDEBUG, "trying to get config for $config");
|
||||
my $configdir = $self->config_dir($config);
|
||||
|
||||
my $configfile = "$configdir/$config";
|
||||
|
||||
# CDB config support really should be moved to a plugin
|
||||
if ($type and $type eq "map") {
|
||||
return $self->get_qmail_map($config, $configfile);
|
||||
}
|
||||
|
||||
return $self->from_file($configfile, $config);
|
||||
}
|
||||
|
||||
sub get_qmail_map {
|
||||
my ($self, $config, $configfile) = @_;
|
||||
|
||||
if (!-e $configfile . ".cdb") {
|
||||
$_config_cache->{$config} ||= [];
|
||||
return +{};
|
||||
}
|
||||
eval { require CDB_File };
|
||||
|
||||
if ($@) {
|
||||
$self->log(LOGERROR,
|
||||
"No CDB Support! Did NOT read $configfile.cdb, could not load CDB_File module: $@"
|
||||
);
|
||||
return +{};
|
||||
}
|
||||
|
||||
my %h;
|
||||
unless (tie(%h, 'CDB_File', "$configfile.cdb")) {
|
||||
$self->log(LOGERROR, "tie of $configfile.cdb failed: $!");
|
||||
return +{};
|
||||
}
|
||||
|
||||
# We explicitly don't cache cdb entries. The assumption is that
|
||||
# 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 from_file {
|
||||
my ($self, $configfile, $config, $visited) = @_;
|
||||
if (!-e $configfile) {
|
||||
$_config_cache->{$config} ||= [];
|
||||
return;
|
||||
}
|
||||
|
||||
$visited ||= [];
|
||||
push @$visited, $configfile;
|
||||
|
||||
open my $CF, '<', $configfile or do {
|
||||
warn "$$ could not open configfile $configfile: $!";
|
||||
return;
|
||||
};
|
||||
my @config = <$CF>;
|
||||
close $CF;
|
||||
|
||||
chomp @config;
|
||||
@config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/ } @config;
|
||||
for (@config) { s/^\s+//; s/\s+$//; } # trim leading/trailing whitespace
|
||||
|
||||
my $pos = 0;
|
||||
while ($pos < @config) {
|
||||
|
||||
# recursively pursue an $include reference, if found. An inclusion which
|
||||
# begins with a leading slash is interpreted as a path to a file and will
|
||||
# supercede the usual config path resolution. Otherwise, the normal
|
||||
# config_dir() lookup is employed (the location in which the inclusion
|
||||
# appeared receives no special precedence; possibly it should, but it'd
|
||||
# be complicated beyond justifiability for so simple a config system.
|
||||
if ($config[$pos] =~ /^\s*\$include\s+(\S+)\s*$/) {
|
||||
my ($includedir, $inclusion) = ('', $1);
|
||||
|
||||
splice @config, $pos, 1; # remove the $include line
|
||||
if ($inclusion !~ /^\//) {
|
||||
$includedir = $self->config_dir($inclusion);
|
||||
$inclusion = "$includedir/$inclusion";
|
||||
}
|
||||
|
||||
if (grep($_ eq $inclusion, @{$visited})) {
|
||||
$self->log(LOGERROR,
|
||||
"Circular \$include reference in config $config:");
|
||||
$self->log(LOGERROR, "From $visited->[0]:");
|
||||
$self->log(LOGERROR, " includes $_")
|
||||
for (@{$visited}[1 .. $#{$visited}], $inclusion);
|
||||
return wantarray ? () : undef;
|
||||
}
|
||||
push @{$visited}, $inclusion;
|
||||
|
||||
for my $inc ($self->expand_inclusion_($inclusion, $configfile)) {
|
||||
my @insertion = $self->from_file($inc, $config, $visited);
|
||||
splice @config, $pos, 0, @insertion; # insert the inclusion
|
||||
$pos += @insertion;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$pos++;
|
||||
}
|
||||
}
|
||||
|
||||
$_config_cache->{$config} = \@config;
|
||||
|
||||
return wantarray ? @config : $config[0];
|
||||
}
|
||||
|
||||
sub expand_inclusion_ {
|
||||
my $self = shift;
|
||||
my $inclusion = shift;
|
||||
my $context = shift;
|
||||
my @includes;
|
||||
|
||||
if (-d $inclusion) {
|
||||
$self->log(LOGDEBUG, "inclusion of directory $inclusion from $context");
|
||||
|
||||
if (opendir(INCD, $inclusion)) {
|
||||
@includes = map { "$inclusion/$_" }
|
||||
(grep { -f "$inclusion/$_" and !/^\./ } sort readdir INCD);
|
||||
closedir INCD;
|
||||
}
|
||||
else {
|
||||
$self->log(LOGERROR,
|
||||
"Couldn't open directory $inclusion,"
|
||||
. " referenced from $context ($!)"
|
||||
);
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->log(LOGDEBUG, "inclusion of file $inclusion from $context");
|
||||
@includes = ($inclusion);
|
||||
}
|
||||
return @includes;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -142,9 +142,9 @@ sub reset_transaction {
|
||||
|
||||
sub connection {
|
||||
my $self = shift;
|
||||
@_ and $self->{_connection} = shift;
|
||||
return $self->{_connection}
|
||||
|| ($self->{_connection} = Qpsmtpd::Connection->new());
|
||||
if (@_) { $self->{_connection} = shift; }
|
||||
return $self->{_connection} if $self->{_connection};
|
||||
return $self->{_connection} = Qpsmtpd::Connection->new();
|
||||
}
|
||||
|
||||
sub helo {
|
||||
|
||||
@ -30,8 +30,9 @@ sub hook_mail {
|
||||
my $from = lc($sender->user) . '@' . $host;
|
||||
|
||||
for my $bad (@badmailfromto) {
|
||||
next if !$bad;
|
||||
$bad =~ s/^\s*(\S+).*/$1/;
|
||||
next unless $bad;
|
||||
next if !$bad;
|
||||
$bad = lc $bad;
|
||||
if ($bad !~ m/\@/) {
|
||||
$self->log(LOGWARN, 'bad config, no @ sign in ' . $bad);
|
||||
|
||||
@ -157,24 +157,26 @@ Adjust the quantity of logging for this plugin. See docs/logging.pod
|
||||
|
||||
Written by Gavin Carr <gavin@openfusion.com.au>.
|
||||
|
||||
nfslock feature by JT Moree <jtmoree@kahalacorp.com> - 2007-01-22
|
||||
2007-01-22 - nfslock feature by JT Moree <jtmoree@kahalacorp.com>
|
||||
|
||||
p0f feature by Matt Simerson <msimerson@cpan.org> - 2010-05-03
|
||||
2010-05-03 - p0f feature by Matt Simerson <msimerson@cpan.org>
|
||||
|
||||
geoip, loglevel, reject added. Refactored into subs - Matt Simerson - 2012-05
|
||||
2012-05 - geoip, loglevel, reject added. Refactored into subs by Matt Simerson
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Net::IP;
|
||||
|
||||
use Qpsmtpd::Constants;
|
||||
|
||||
my $VERSION = '0.11';
|
||||
my $VERSION = '0.12';
|
||||
|
||||
BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
|
||||
use AnyDBM_File;
|
||||
use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
|
||||
use Net::IP;
|
||||
|
||||
my $DENYMSG = "This mail is temporarily denied";
|
||||
my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!);
|
||||
@ -197,9 +199,10 @@ my %DEFAULTS = (
|
||||
|
||||
sub register {
|
||||
my ($self, $qp, %arg) = @_;
|
||||
my $c = $self->qp->config('denysoft_greylist');
|
||||
my $config = {
|
||||
%DEFAULTS,
|
||||
map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist'),
|
||||
($c ? map { split /\s+/, $_, 2 } $c : ()),
|
||||
%arg
|
||||
};
|
||||
if (my @bad = grep { !exists $PERMITTED_ARGS{$_} } sort keys %$config) {
|
||||
@ -265,9 +268,8 @@ sub hook_data {
|
||||
return DECLINED unless $transaction->notes('greylist');
|
||||
|
||||
# Decline if ALL recipients are whitelisted
|
||||
if (($transaction->notes('whitelistrcpt') || 0) ==
|
||||
scalar($transaction->recipients))
|
||||
{
|
||||
my $recips = scalar $transaction->recipients || 0;
|
||||
if (($transaction->notes('whitelistrcpt') || 0) == $recips) {
|
||||
$self->log(LOGWARN, "skip: all recipients whitelisted");
|
||||
return DECLINED;
|
||||
}
|
||||
@ -370,7 +372,7 @@ sub get_db_key {
|
||||
sub get_db_tie {
|
||||
my ($self, $db, $lock) = @_;
|
||||
|
||||
tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do {
|
||||
tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, oct('0600')) or do {
|
||||
$self->log(LOGCRIT, "tie to database $db failed: $!");
|
||||
close $lock;
|
||||
return;
|
||||
@ -419,7 +421,7 @@ sub get_db_lock {
|
||||
return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock};
|
||||
|
||||
# Check denysoft db
|
||||
open(my $lock, ">$db.lock") or do {
|
||||
open(my $lock, '>', "$db.lock") or do {
|
||||
$self->log(LOGCRIT, "opening lockfile failed: $!");
|
||||
return;
|
||||
};
|
||||
@ -450,7 +452,7 @@ sub get_db_lock_nfs {
|
||||
return;
|
||||
};
|
||||
|
||||
open(my $lock, "+<$db.lock") or do {
|
||||
open(my $lock, '+<', "$db.lock") or do {
|
||||
$self->log(LOGCRIT, "opening nfs lockfile failed: $!");
|
||||
return;
|
||||
};
|
||||
|
||||
@ -129,17 +129,16 @@ sub register {
|
||||
$self->log(LOGERROR, "Bad parameters for the clamdscan plugin") if @_ % 2;
|
||||
$self->{'_args'} = {@_};
|
||||
|
||||
eval 'use ClamAV::Client';
|
||||
eval 'use ClamAV::Client'; ## no critic (Stringy)
|
||||
if ($@) {
|
||||
warn "unable to load ClamAV::Client\n";
|
||||
$self->log(LOGERROR, "unable to load ClamAV::Client");
|
||||
return;
|
||||
}
|
||||
|
||||
# Set some sensible defaults
|
||||
$self->{'_args'}{'deny_viruses'} ||= 'yes';
|
||||
$self->{'_args'}{'max_size'} ||= 1024;
|
||||
$self->{'_args'}{'scan_all'} ||= 1;
|
||||
# Set sensible defaults
|
||||
$self->{_args}{deny_viruses} ||= 'yes';
|
||||
$self->{_args}{max_size} ||= 1024;
|
||||
$self->{_args}{scan_all} ||= 1;
|
||||
for my $setting ('deny_viruses', 'defer_on_error') {
|
||||
next unless $self->{'_args'}{$setting};
|
||||
if (lc $self->{'_args'}{$setting} eq 'no') {
|
||||
@ -241,9 +240,11 @@ sub get_filename {
|
||||
}
|
||||
|
||||
if (!-f $filename) {
|
||||
if ($transaction->data_size) {
|
||||
$self->log(LOGERROR, "spool file missing! Attempting to respool");
|
||||
$transaction->body_spool;
|
||||
$filename = $transaction->body_filename;
|
||||
};
|
||||
if (!-f $filename) {
|
||||
$self->log(LOGERROR, "skip: failed spool to $filename! Giving up");
|
||||
return;
|
||||
@ -264,14 +265,14 @@ sub set_permission {
|
||||
my $dir_mode = (stat($self->spool_dir()))[2];
|
||||
$self->log(LOGDEBUG, "spool dir mode: $dir_mode");
|
||||
|
||||
if ($dir_mode & 0010 || $dir_mode & 0001) {
|
||||
if ($dir_mode & oct('0010') || $dir_mode & oct('0001')) {
|
||||
|
||||
# match the spool file mode with the mode of the directory -- add
|
||||
# the read bit for group, world, or both, depending on what the
|
||||
# spool dir had, and strip all other bits, especially the sticky bit
|
||||
my $fmode =
|
||||
($dir_mode & 0044) | ($dir_mode & 0010 ? 0040 : 0) |
|
||||
($dir_mode & 0001 ? 0004 : 0);
|
||||
($dir_mode & oct('0044')) | ($dir_mode & oct('0010') ? oct('0040') : 0) |
|
||||
($dir_mode & oct('0001') ? oct('0004') : 0);
|
||||
|
||||
unless (chmod $fmode, $filename) {
|
||||
$self->log(LOGERROR, "chmod: $filename: $!");
|
||||
|
||||
@ -396,7 +396,7 @@ sub cmd_hup {
|
||||
|
||||
# clear cache
|
||||
print "Clearing cache\n";
|
||||
Qpsmtpd::clear_config_cache();
|
||||
Qpsmtpd::Config::clear_cache();
|
||||
|
||||
# should also reload modules... but can't do that yet.
|
||||
}
|
||||
|
||||
@ -1,10 +1,13 @@
|
||||
package Test::Qpsmtpd;
|
||||
use strict;
|
||||
|
||||
use Carp qw(croak);
|
||||
use Test::More;
|
||||
|
||||
use lib 't';
|
||||
use lib 'lib';
|
||||
use Carp qw(croak);
|
||||
use base qw(Qpsmtpd::SMTP);
|
||||
use Test::More;
|
||||
use parent 'Qpsmtpd::SMTP';
|
||||
|
||||
use Qpsmtpd::Constants;
|
||||
use Test::Qpsmtpd::Plugin;
|
||||
|
||||
@ -78,7 +81,7 @@ sub input {
|
||||
|
||||
sub config_dir {
|
||||
return './t/config' if $ENV{QPSMTPD_DEVELOPER};
|
||||
'./config.sample';
|
||||
return './config.sample';
|
||||
}
|
||||
|
||||
sub plugin_dirs {
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
package Test::Qpsmtpd::Plugin;
|
||||
use strict;
|
||||
1;
|
||||
|
||||
# Additional plugin methods used during testing
|
||||
|
||||
37
t/config.t
37
t/config.t
@ -1,37 +0,0 @@
|
||||
#!/usr/bin/perl -w
|
||||
use Test::More qw(no_plan);
|
||||
use File::Path;
|
||||
use strict;
|
||||
use lib 't';
|
||||
use_ok('Test::Qpsmtpd');
|
||||
|
||||
my @mes;
|
||||
|
||||
BEGIN { # need this to happen before anything else
|
||||
my $cwd = `pwd`;
|
||||
chomp($cwd);
|
||||
@mes = qw{ ./config.sample/me ./t/config/me };
|
||||
foreach my $f (@mes) {
|
||||
open my $me_config, '>', $f;
|
||||
print $me_config "some.host.example.org";
|
||||
close $me_config;
|
||||
}
|
||||
}
|
||||
|
||||
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
||||
|
||||
is($smtpd->config('me'), 'some.host.example.org', 'config("me")');
|
||||
|
||||
# test for ignoring leading/trailing whitespace (relayclients has a
|
||||
# line with both)
|
||||
my $relayclients = join ",", sort $smtpd->config('relayclients');
|
||||
is(
|
||||
$relayclients,
|
||||
'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) {
|
||||
unlink $f if -f $f;
|
||||
}
|
||||
|
||||
@ -46,10 +46,10 @@ helo
|
||||
sender_permitted_from
|
||||
greylisting p0f genre,windows
|
||||
|
||||
auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /usr/bin/true
|
||||
auth/auth_vpopmail
|
||||
#auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /usr/bin/true
|
||||
#auth/auth_vpopmail
|
||||
auth/auth_vpopmaild
|
||||
auth/auth_vpopmail_sql
|
||||
#auth/auth_vpopmail_sql
|
||||
auth/auth_flat_file
|
||||
auth/authdeny
|
||||
|
||||
@ -57,7 +57,7 @@ auth/authdeny
|
||||
rcpt_ok
|
||||
|
||||
headers days 5 reject_type temp require From,Date
|
||||
domainkeys
|
||||
#domainkeys
|
||||
dkim
|
||||
dmarc
|
||||
|
||||
|
||||
3
t/config/size_threshold
Normal file
3
t/config/size_threshold
Normal file
@ -0,0 +1,3 @@
|
||||
# Messages below the size below will be stored in memory and not spooled.
|
||||
# Without this file, the default is 0 bytes, i.e. all messages will be spooled.
|
||||
10000
|
||||
@ -8,7 +8,7 @@ use Qpsmtpd::Constants;
|
||||
sub register_tests {
|
||||
my $self = shift;
|
||||
|
||||
eval 'use ClamAV::Client';
|
||||
eval 'use ClamAV::Client'; ## no critic (Stringy)
|
||||
if ( ! $@ ) {
|
||||
$self->register_test('test_register', 3);
|
||||
$self->register_test('test_get_clamd', 1);
|
||||
@ -42,6 +42,9 @@ sub test_err_and_return {
|
||||
|
||||
sub test_get_filename {
|
||||
my $self = shift;
|
||||
my $tran = $self->qp->transaction();
|
||||
$tran->{_body_array} = ['line','two'];
|
||||
|
||||
my $filename = $self->get_filename();
|
||||
ok( $filename, "get_filename ($filename)" );
|
||||
}
|
||||
|
||||
@ -6,9 +6,12 @@ use Test::More;
|
||||
|
||||
use lib 'lib'; # test lib/Qpsmtpd/Base (vs site_perl)
|
||||
|
||||
BEGIN { use_ok('Qpsmtpd::Base'); }
|
||||
BEGIN {
|
||||
use_ok('Qpsmtpd::Base');
|
||||
use_ok('Qpsmtpd::Constants');
|
||||
}
|
||||
|
||||
my $base = bless {}, 'Qpsmtpd::Base';
|
||||
my $base = Qpsmtpd::Base->new();
|
||||
|
||||
__tildeexp();
|
||||
__is_localhost();
|
||||
|
||||
89
t/qpsmtpd-config.t
Normal file
89
t/qpsmtpd-config.t
Normal file
@ -0,0 +1,89 @@
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Data::Dumper;
|
||||
use File::Path;
|
||||
use Test::More;
|
||||
|
||||
use lib 'lib'; # test lib/Qpsmtpd (vs site_perl)
|
||||
use lib 't';
|
||||
|
||||
my @mes;
|
||||
|
||||
BEGIN {
|
||||
use_ok('Qpsmtpd::Config'); # call classes directly
|
||||
use_ok('Qpsmtpd::Constants');
|
||||
|
||||
use_ok('Test::Qpsmtpd'); # call via a connection object
|
||||
|
||||
@mes = qw{ ./config.sample/me ./t/config/me };
|
||||
foreach my $f (@mes) {
|
||||
open my $me_config, '>', $f;
|
||||
print $me_config "host.example.org";
|
||||
close $me_config;
|
||||
}
|
||||
}
|
||||
|
||||
my $config = Qpsmtpd::Config->new();
|
||||
|
||||
isa_ok($config, 'Qpsmtpd::Config');
|
||||
|
||||
__log();
|
||||
__config_dir();
|
||||
__from_file();
|
||||
__get_qmail();
|
||||
__config_via_smtpd();
|
||||
|
||||
foreach my $f (@mes) { unlink $f; }
|
||||
|
||||
done_testing();
|
||||
|
||||
sub __log {
|
||||
my $warned = '';
|
||||
local $SIG{__WARN__} = sub {
|
||||
if ($_[0] eq "$$ test log message\n") {
|
||||
$warned = join ' ', @_;
|
||||
}
|
||||
else {
|
||||
warn @_;
|
||||
}
|
||||
};
|
||||
ok($config->log(LOGWARN, "test log message"), 'log');
|
||||
is($warned, "$$ test log message\n", 'LOGWARN emitted correct warning');
|
||||
}
|
||||
|
||||
sub __get_qmail {
|
||||
is($config->get_qmail('me'), 'host.example.org', 'get_qmail("me")');
|
||||
ok(!$config->get_qmail('not-me'), 'get_qmail("not-me")');
|
||||
}
|
||||
|
||||
sub __from_file {
|
||||
my $test_file = 't/config/test_config_file';
|
||||
my @r = $config->from_file($test_file, 'test_config_file');
|
||||
ok( @r, "from_file, $test_file");
|
||||
cmp_ok('1st line with content', 'eq', $r[0], "from_file string compare");
|
||||
ok( !$r[1], "from_file");
|
||||
};
|
||||
|
||||
sub __config_dir {
|
||||
my $dir = $config->config_dir('logging');
|
||||
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)");
|
||||
}
|
||||
|
||||
sub __config_via_smtpd {
|
||||
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
||||
|
||||
is($smtpd->config('me'), 'host.example.org', 'config("me")');
|
||||
|
||||
# test for ignoring leading/trailing whitespace (relayclients has a
|
||||
# line with both)
|
||||
my $relayclients = join ',', sort $smtpd->config('relayclients');
|
||||
is($relayclients,
|
||||
'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'
|
||||
);
|
||||
};
|
||||
69
t/qpsmtpd.t
69
t/qpsmtpd.t
@ -7,20 +7,23 @@ use File::Path;
|
||||
use Test::More;
|
||||
|
||||
use lib 'lib'; # test lib/Qpsmtpd (vs site_perl)
|
||||
use lib 't';
|
||||
|
||||
BEGIN {
|
||||
use_ok('Qpsmtpd');
|
||||
use_ok('Qpsmtpd::Constants');
|
||||
}
|
||||
use_ok('Test::Qpsmtpd');
|
||||
|
||||
use lib 't';
|
||||
use_ok('Test::Qpsmtpd');
|
||||
}
|
||||
|
||||
my $qp = bless {}, 'Qpsmtpd';
|
||||
|
||||
ok($qp->version(), "version, " . $qp->version());
|
||||
is_deeply(Qpsmtpd::hooks(), {}, 'hooks, empty');
|
||||
|
||||
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
||||
ok(Qpsmtpd::hooks(), "hooks, populated");
|
||||
|
||||
__temp_file();
|
||||
__temp_dir();
|
||||
__size_threshold();
|
||||
@ -33,26 +36,10 @@ __log();
|
||||
__load_logging();
|
||||
|
||||
__config_dir();
|
||||
__config_from_file();
|
||||
__get_qmail_config();
|
||||
__config();
|
||||
|
||||
done_testing();
|
||||
|
||||
sub __get_qmail_config {
|
||||
ok(!$qp->get_qmail_config('me'), "get_qmail_config, me");
|
||||
|
||||
# TODO: add positive tests.
|
||||
}
|
||||
|
||||
sub __config_from_file {
|
||||
my $test_file = 't/config/test_config_file';
|
||||
my @r = $qp->_config_from_file($test_file);
|
||||
ok( @r, "_config_from_file, $test_file");
|
||||
cmp_ok('1st line with content', 'eq', $r[0], "_config_from_file string compare");
|
||||
ok( !$r[1], "_config_from_file");
|
||||
};
|
||||
|
||||
sub __log {
|
||||
my $warned = '';
|
||||
local $SIG{__WARN__} = sub {
|
||||
@ -67,15 +54,6 @@ sub __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");
|
||||
|
||||
#warn Data::Dumper::Dumper($Qpsmtpd::config_dir_memo{logging});
|
||||
$dir = $Qpsmtpd::config_dir_memo{logging};
|
||||
ok($dir, "config_dir, $dir (memo)");
|
||||
}
|
||||
|
||||
sub __load_logging {
|
||||
$Qpsmtpd::LOGGING_LOADED = 1;
|
||||
ok(!$qp->load_logging(), "load_logging, loaded");
|
||||
@ -90,6 +68,25 @@ sub __load_logging {
|
||||
sub __spool_dir {
|
||||
my $dir = $qp->spool_dir();
|
||||
ok( $dir, "spool_dir is at $dir");
|
||||
|
||||
my $cwd = `pwd`;
|
||||
chomp($cwd);
|
||||
open my $spooldir, '>', "./config.sample/spool_dir";
|
||||
print $spooldir "$cwd/t/tmp";
|
||||
close $spooldir;
|
||||
|
||||
my $spool_dir = $smtpd->spool_dir();
|
||||
ok($spool_dir =~ m!t/tmp/$!, "Located the spool directory");
|
||||
|
||||
my $tempfile = $smtpd->temp_file();
|
||||
my $tempdir = $smtpd->temp_dir();
|
||||
|
||||
ok($tempfile =~ /^$spool_dir/, "Temporary filename");
|
||||
ok($tempdir =~ /^$spool_dir/, "Temporary directory");
|
||||
ok(-d $tempdir, "And that directory exists");
|
||||
|
||||
unlink "./config.sample/spool_dir";
|
||||
rmtree($spool_dir);
|
||||
}
|
||||
|
||||
sub __temp_file {
|
||||
@ -112,7 +109,7 @@ sub __temp_dir {
|
||||
}
|
||||
|
||||
sub __size_threshold {
|
||||
ok( ! $qp->size_threshold(), "size_threshold is undefined")
|
||||
is( $qp->size_threshold(), 10000, "size_threshold from t/config is 1000")
|
||||
or warn "size_threshold: " . $qp->size_threshold;
|
||||
|
||||
$Qpsmtpd::Size_threshold = 5;
|
||||
@ -149,9 +146,19 @@ sub __auth_mechanism {
|
||||
$qp->{_auth_mechanism} = undef;
|
||||
}
|
||||
|
||||
sub __config_dir {
|
||||
my $dir = $qp->config_dir('logging');
|
||||
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)");
|
||||
}
|
||||
|
||||
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");
|
||||
my @test_data = (
|
||||
@ -250,6 +257,8 @@ sub __config {
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
package FakeAddress;
|
||||
|
||||
sub new {
|
||||
@ -258,3 +267,5 @@ sub new {
|
||||
}
|
||||
|
||||
sub address { } # pass the can('address') conditional
|
||||
|
||||
1;
|
||||
|
||||
@ -1,27 +0,0 @@
|
||||
#!/usr/bin/perl -w
|
||||
use Test::More qw(no_plan);
|
||||
use File::Path;
|
||||
use strict;
|
||||
use lib 't';
|
||||
use_ok('Test::Qpsmtpd');
|
||||
|
||||
BEGIN { # need this to happen before anything else
|
||||
my $cwd = `pwd`;
|
||||
chomp($cwd);
|
||||
open my $spooldir, '>', "./config.sample/spool_dir";
|
||||
print $spooldir "$cwd/t/tmp";
|
||||
close $spooldir;
|
||||
}
|
||||
|
||||
ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
|
||||
|
||||
my ($spool_dir, $tempfile, $tempdir) =
|
||||
($smtpd->spool_dir, $smtpd->temp_file(), $smtpd->temp_dir());
|
||||
|
||||
ok($spool_dir =~ m!t/tmp/$!, "Located the spool directory");
|
||||
ok($tempfile =~ /^$spool_dir/, "Temporary filename");
|
||||
ok($tempdir =~ /^$spool_dir/, "Temporary directory");
|
||||
ok(-d $tempdir, "And that directory exists");
|
||||
|
||||
unlink "./config.sample/spool_dir";
|
||||
rmtree($spool_dir);
|
||||
Loading…
Reference in New Issue
Block a user