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

Merge pull request #102 from msimerson/Base.pm

Browse Source 
Base.pm
This commit is contained in:
flimzy 2014-09-16 12:07:55 -05:00
commit d36b9240f9
26 changed files with 646 additions and 444 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
MANIFEST
View File

@ -39,7 +39,9 @@ lib/Danga/TimeoutSocket.pm
lib/Qpsmtpd.pm
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
@ -55,7 +57,6 @@ lib/Qpsmtpd/SMTP/Prefork.pm
lib/Qpsmtpd/TcpServer.pm
lib/Qpsmtpd/TcpServer/Prefork.pm
lib/Qpsmtpd/Transaction.pm
lib/Qpsmtpd/Utils.pm
LICENSE
log/log2sql
log/log2sql.sql
@ -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
@ -209,11 +211,11 @@ t/plugin_tests/spamassassin
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-utils.t
t/qpsmtpd.t
t/rset.t
t/tempstuff.t
t/Test/Qpsmtpd.pm
t/Test/Qpsmtpd/Plugin.pm
UPGRADING.pod

21
Makefile.PL
View File

@ -7,18 +7,19 @@ WriteMakefile(
NAME => 'qpsmtpd',
VERSION_FROM => 'lib/Qpsmtpd.pm',
PREREQ_PM => {
'Data::Dumper' => 0,
'Date::Parse' => 0,
'File::Temp' => 0,
'Mail::Header' => 0,
'MIME::Base64' => 0,
'Net::DNS' => 0.39,
'Net::IP' => 0,
'Time::HiRes' => 0,
'CDB_File' => 0,
'Data::Dumper' => 0,
'Date::Parse' => 0,
'File::Temp' => 0,
'Mail::Header' => 0,
'MIME::Base64' => 0,
'Net::DNS' => 0.39,
'Net::IP' => 0,
'Time::HiRes' => 0,
'IO::Socket::SSL' => 0,
# Dev/Test modules
'Test::More' => 0,
'Test::Output' => 0,
'Test::More' => 0,
'Test::Output' => 0,
# modules for specific features
'Mail::DKIM' => 0,
'File::Tail' => 0, # log/summarize, log/watch

355
lib/Qpsmtpd.pm
View File

@ -2,13 +2,15 @@ package Qpsmtpd;
use strict;
#use warnings;
use vars qw($TraceLevel $Spool_dir $Size_threshold);
use Sys::Hostname;
use Qpsmtpd::Constants;
use Qpsmtpd::Address;
our $VERSION = "0.95";
use vars qw($TraceLevel $Spool_dir $Size_threshold);
use lib 'lib';
use base 'Qpsmtpd::Base';
use Qpsmtpd::Address;
use Qpsmtpd::Config;
use Qpsmtpd::Constants;
my $git;
@ -19,12 +21,6 @@ if (-e ".git") {
}
our $hooks = {};
my %defaults = (
me => hostname,
timeout => 1200,
);
my $_config_cache = {};
our %config_dir_memo;
our $LOGGING_LOADED = 0;
@ -34,13 +30,12 @@ sub _restart {
if ($args{restart}) {
# reset all global vars to defaults
$self->clear_config_cache;
$hooks = {};
$LOGGING_LOADED = 0;
%config_dir_memo = ();
$TraceLevel = LOGWARN;
$Spool_dir = undef;
$Size_threshold = undef;
$self->conf->clear_cache();
$hooks = {};
$LOGGING_LOADED = 0;
$TraceLevel = LOGWARN;
$Spool_dir = undef;
$Size_threshold = undef;
}
}
@ -58,11 +53,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");
@ -79,7 +74,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.
@ -92,7 +87,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();
}
@ -104,23 +99,17 @@ 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)
or return;
return if $rc == DECLINED || $rc == OK; # plugin success
return if $rc == DECLINED || $rc == OK; # plugin success
return if $trace > $TraceLevel;
# no logging plugins registered, fall back to STDERR
@ -133,64 +122,22 @@ 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) = @_;
$self->log(LOGDEBUG, "in config($c)");
# first run the user_config hooks
my ($rc, @config);
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];
};
};
# 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;
# then the default, if any
if (exists $defaults{$c}) {
return wantarray ? ($defaults{$c}) : $defaults{$c};
};
return;
my $self = shift;
return $self->conf->config($self, @_);
}
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 {
@ -204,143 +151,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>;
chomp @config;
@config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/ }
map { s/^\s+//; s/\s+$//; $_; } # trim leading/trailing whitespace
@config;
close $CF;
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;
@ -393,18 +203,20 @@ sub _load_plugin {
# don't reload plugins if they are already loaded
if (!defined &{"${package}::plugin_name"}) {
PLUGIN_DIR: for my $dir (@plugin_dirs) {
for my $dir (@plugin_dirs) {
next if !-e "$dir/$plugin";
Qpsmtpd::Plugin->compile($plugin_name, $package,
"$dir/$plugin", $self->{_test_mode}, $plugin);
"$dir/$plugin", $self->{_test_mode},
$plugin);
if ($safe_line !~ /logging/) {
$self->log(LOGDEBUG, "Loading $safe_line from $dir/$plugin");
};
last PLUGIN_DIR;
}
last;
}
if (!defined &{"${package}::plugin_name"}) {
die "Plugin $plugin_name not found in our plugin dirs (",
join(', ', @plugin_dirs), ")";
}
if (! defined &{"${package}::plugin_name"}) {
die "Plugin $plugin_name not found in our plugin dirs (", join(', ', @plugin_dirs), ")";
};
}
my $plug = $package->new();
@ -423,11 +235,12 @@ sub _load_package_plugin {
qq[require $package;\n] . qq[sub ${plugin}::plugin_name { '$plugin' }];
$eval =~ m/(.*)/s;
$eval = $1;
eval $eval;
eval $eval; ## no critic (Eval)
die "Failed loading $package - eval $@" if $@;
if ($plugin_line !~ /logging/) {
$self->log(LOGDEBUG, "Loading $package ($plugin_line)");
};
}
my $plug = $package->new();
$plug->_register($self, @$args);
@ -454,9 +267,10 @@ sub run_hooks_no_respond {
my @r;
for my $code (@{$hooks->{$hook}}) {
eval { (@r) = $code->{code}->($self, $self->transaction, @_); };
$@
and warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@)
and next;
if ($@) {
warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@);
next;
}
if ($r[0] == YIELD) {
die "YIELD not valid from $hook hook";
}
@ -474,7 +288,6 @@ sub pause_read { die "Continuations only work in qpsmtpd-async" }
sub run_continuation {
my $self = shift;
#my $t1 = $SAMPLER->("run_hooks", undef, 1);
die "No continuation in progress" unless $self->{_continuation};
$self->continue_read();
my $todo = $self->{_continuation};
@ -486,16 +299,14 @@ sub run_continuation {
while (@$todo) {
my $code = shift @$todo;
#my $t2 = $SAMPLER->($hook . "_" . $code->{name}, undef, 1);
#warn("Got sampler called: ${hook}_$code->{name}\n");
$self->varlog(LOGDEBUG, $hook, $code->{name});
my $tran = $self->transaction;
eval { (@r) = $code->{code}->($self, $tran, @$args); };
$@
and
$self->log(LOGCRIT, "FATAL PLUGIN ERROR [" . $code->{name} . "]: ",
$@)
and next;
if ($@) {
$self->log(LOGCRIT, "FATAL PLUGIN ERROR [" . $code->{name} . "]: ",
$@);
next;
}
!defined $r[0]
and $self->log(LOGERROR,
@ -565,7 +376,6 @@ sub run_continuation {
sub hook_responder {
my ($self, $hook, $msg, $args) = @_;
#my $t1 = $SAMPLER->("hook_responder", undef, 1);
my $code = shift @$msg;
my $responder = $hook . '_respond';
@ -576,40 +386,40 @@ sub hook_responder {
}
sub _register_hook {
my $self = shift;
my ($hook, $code, $unshift) = @_;
my ($self, $hook, $code, $unshift) = @_;
if ($unshift) {
unshift @{$hooks->{$hook}}, $code;
return;
}
else {
push @{$hooks->{$hook}}, $code;
}
push @{$hooks->{$hook}}, $code;
}
sub spool_dir {
my $self = shift;
unless ($Spool_dir) { # first time through
$self->log(LOGDEBUG, "Initializing spool_dir");
$Spool_dir = $self->config('spool_dir')
|| Qpsmtpd::Utils->tildeexp('~/tmp/');
return $Spool_dir if $Spool_dir; # already set
$Spool_dir .= "/" unless ($Spool_dir =~ m!/$!);
$self->log(LOGDEBUG, "Initializing spool_dir");
$Spool_dir = $self->config('spool_dir') || $self->tildeexp('~/tmp/');
$Spool_dir =~ /^(.+)$/ or die "spool_dir not configured properly";
$Spool_dir = $1; # cleanse the taint
my $Spool_perms = $self->config('spool_perms') || '0700';
$Spool_dir .= "/" if $Spool_dir !~ m!/$!;
if (!-d $Spool_dir) { # create it if it doesn't exist
mkdir($Spool_dir, oct($Spool_perms))
or die "Could not create spool_dir $Spool_dir: $!";
}
$Spool_dir =~ /^(.+)$/ or die "spool_dir not configured properly";
$Spool_dir = $1; # cleanse the taint
# Make sure the spool dir has appropriate rights
my $Spool_perms = $self->config('spool_perms') || '0700';
if (!-d $Spool_dir) { # create if it doesn't exist
mkdir($Spool_dir, oct($Spool_perms))
or die "Could not create spool_dir $Spool_dir: $!";
}
# Make sure the spool dir has appropriate rights
if (((stat $Spool_dir)[2] & oct('07777')) != oct($Spool_perms)) {
$self->log(LOGWARN,
"Permissions on spool_dir $Spool_dir are not $Spool_perms")
unless ((stat $Spool_dir)[2] & 07777) == oct($Spool_perms);
"Permissions on spool_dir $Spool_dir are not $Spool_perms");
}
return $Spool_dir;
@ -627,21 +437,22 @@ sub temp_file {
}
sub temp_dir {
my $self = shift;
my $mask = shift || 0700;
my ($self, $mask) = @_;
$mask ||= '0700';
my $dirname = $self->temp_file();
-d $dirname
or mkdir($dirname, $mask)
or die "Could not create temporary directory $dirname: $!";
if (!-d $dirname) {
mkdir($dirname, $mask)
or die "Could not create temporary directory $dirname: $!";
}
return $dirname;
}
sub size_threshold {
my $self = shift;
unless (defined $Size_threshold) {
$Size_threshold = $self->config('size_threshold') || 0;
$self->log(LOGDEBUG, "size_threshold set to $Size_threshold");
}
return $Size_threshold if defined $Size_threshold;
$Size_threshold = $self->config('size_threshold') || 0;
$self->log(LOGDEBUG, "size_threshold set to $Size_threshold");
return $Size_threshold;
}

13
lib/Qpsmtpd/Utils.pm → lib/Qpsmtpd/Base.pm
View File

@ -1,15 +1,18 @@
package Qpsmtpd::Utils;
package Qpsmtpd::Base;
use strict;
use Net::IP;
sub new {
return bless {}, shift;
};
sub tildeexp {
my ($self, $path) = @_;
$path =~ s{^~([^/]*)} {
$1
? (getpwnam($1))[7]
: ( $ENV{HOME} || $ENV{LOGDIR} || (getpwuid($>))[7])
}ex;
$1 ? (getpwnam($1))[7]
: ( $ENV{HOME} || $ENV{LOGDIR} || (getpwuid($>))[7])
}ex;
return $path;
}

227
lib/Qpsmtpd/Config.pm Normal file
View File

@ -0,0 +1,227 @@
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 {
my ($self, $qp, $c, $type) = @_;
$qp->log(LOGDEBUG, "in config($c)");
# first run the user_config hooks
my ($rc, @config);
if (ref $type && $type->can('address')) {
($rc, @config) = $qp->run_hooks_no_respond('user_config', $type, $c);
if (defined $rc && $rc == OK) {
return wantarray ? @config : $config[0];
}
}
# then run the config hooks
($rc, @config) = $qp->run_hooks_no_respond('config', $c);
$qp->log(LOGDEBUG,
"config($c): hook returned ("
. join(',', map { defined $_ ? $_ : 'undef' } ($rc, @config))
. ")"
);
if (defined $rc && $rc == OK) {
return wantarray ? @config : $config[0];
}
# then qmail
@config = $self->get_qmail($c, $type);
return wantarray ? @config : $config[0] if @config;
# then the default, which may be undefined
return $self->default($c);
}
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 !exists $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") {
$self->log(LOGERROR, "File $configfile.cdb does not exist");
$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;

1
lib/Qpsmtpd/Plugin.pm
View File

@ -1,5 +1,4 @@
package Qpsmtpd::Plugin;
use strict;
use warnings;

6
lib/Qpsmtpd/SMTP.pm
View File

@ -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 {

2
lib/Qpsmtpd/Transaction.pm
View File

@ -4,7 +4,7 @@ use Qpsmtpd;
use strict;
use warnings;
use Qpsmtpd::Utils;
use Qpsmtpd::Base;
use Qpsmtpd::Constants;
use IO::File qw(O_RDWR O_CREAT);

3
plugins/badmailfromto
View File

@ -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);

2
plugins/fcrdns
View File

@ -166,7 +166,7 @@ sub connect_handler {
sub is_valid_localhost {
my ($self) = @_;
if (Qpsmtpd::Utils->is_localhost($self->qp->connection->remote_ip)) {
if (Qpsmtpd::Base->is_localhost($self->qp->connection->remote_ip)) {
$self->adjust_karma(1);
$self->log(LOGDEBUG, "pass, is localhost");
return 1;

26
plugins/greylisting
View File

@ -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;
};

10
plugins/helo
View File

@ -229,8 +229,8 @@ use warnings;
use Net::IP;
use Qpsmtpd::Base;
use Qpsmtpd::Constants;
use Qpsmtpd::Utils;
sub register {
my ($self, $qp) = (shift, shift);
@ -342,7 +342,7 @@ sub is_regex_match {
sub invalid_localhost {
my ($self, $host) = @_;
if (Qpsmtpd::Utils->is_localhost($self->qp->connection->remote_ip)) {
if (Qpsmtpd::Base->is_localhost($self->qp->connection->remote_ip)) {
$self->log(LOGDEBUG, "pass, is localhost");
return;
}
@ -357,7 +357,7 @@ sub invalid_localhost {
sub is_plain_ip {
my ($self, $host) = @_;
return if !Qpsmtpd::Utils->is_valid_ip($host);
return if !Qpsmtpd::Base->is_valid_ip($host);
$self->log(LOGDEBUG, "fail, plain IP");
return ("Plain IP is invalid HELO hostname (RFC 2821)", "plain IP");
@ -369,7 +369,7 @@ sub is_address_literal {
my ($ip) = $host =~ /^\[(.*)\]/; # strip off any brackets
return if !$ip; # no brackets, not a literal
return if !Qpsmtpd::Utils->is_valid_ip($ip);
return if !Qpsmtpd::Base->is_valid_ip($ip);
$self->log(LOGDEBUG, "fail, bracketed IP");
return ("RFC 2821 allows an address literal, but we do not",
@ -378,7 +378,7 @@ sub is_address_literal {
sub is_forged_literal {
my ($self, $host) = @_;
return if !Qpsmtpd::Utils->is_valid_ip($host);
return if !Qpsmtpd::Base->is_valid_ip($host);
# should we add exceptions for reserved internal IP space? (192.168,10., etc)
$host = substr $host, 1, -1;

25
plugins/virus/clamdscan
View File

@ -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) {
$self->log(LOGERROR, "spool file missing! Attempting to respool");
$transaction->body_spool;
$filename = $transaction->body_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: $!");

2
qpsmtpd-async
View File

@ -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.
}

11
t/Test/Qpsmtpd.pm
View File

@ -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
t/Test/Qpsmtpd/Plugin.pm
View File

@ -1,4 +1,5 @@
package Test::Qpsmtpd::Plugin;
use strict;
1;
# Additional plugin methods used during testing

37
t/config.t
View File

@ -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;
}

8
t/config/plugins
View File

@ -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
View 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

4
t/config/test_config_file Normal file
View File

@ -0,0 +1,4 @@
# a comment line that should get stripped
# another comment line that should get stripped
1st line with content

BIN
t/config/users.cdb Normal file
View File

Binary file not shown.

5
t/plugin_tests/virus/clamdscan
View File

@ -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)" );
}

21
t/qpsmtpd-utils.t → t/qpsmtpd-base.t
View File

@ -4,11 +4,14 @@ use warnings;
use Test::More;
use lib 'lib'; # test lib/Qpsmtpd/Utils (vs site_perl)
use lib 'lib'; # test lib/Qpsmtpd/Base (vs site_perl)
BEGIN { use_ok('Qpsmtpd::Utils'); }
BEGIN {
use_ok('Qpsmtpd::Base');
use_ok('Qpsmtpd::Constants');
}
my $utils = bless {}, 'Qpsmtpd::Utils';
my $base = Qpsmtpd::Base->new();
__tildeexp();
__is_localhost();
@ -19,30 +22,30 @@ done_testing();
sub __is_valid_ip {
my @good = qw/ 1.2.3.4 1.0.0.0 254.254.254.254 2001:db8:ffff:ffff:ffff:ffff:ffff:ffff /;
foreach my $ip ( @good ) {
ok( $utils->is_valid_ip($ip), "is_valid_ip: $ip");
ok( $base->is_valid_ip($ip), "is_valid_ip: $ip");
}
my @bad = qw/ 1.2.3.256 256.1.1.1 2001:db8:ffff:ffff:ffff:ffff:ffff:fffj /;
foreach my $ip ( @bad ) {
ok( !$utils->is_valid_ip($ip), "is_valid_ip, neg: $ip");
ok( !$base->is_valid_ip($ip), "is_valid_ip, neg: $ip");
}
};
sub __is_localhost {
for my $local_ip (qw/ 127.0.0.1 ::1 2607:f060:b008:feed::127.0.0.1 127.0.0.2 /) {
ok( $utils->is_localhost($local_ip), "is_localhost, $local_ip");
ok( $base->is_localhost($local_ip), "is_localhost, $local_ip");
}
for my $rem_ip (qw/ 128.0.0.1 ::2 2607:f060:b008:feed::128.0.0.1 /) {
ok( !$utils->is_localhost($rem_ip), "!is_localhost, $rem_ip");
ok( !$base->is_localhost($rem_ip), "!is_localhost, $rem_ip");
}
};
sub __tildeexp {
my $path = $utils->tildeexp('~root/foo.txt');
my $path = $base->tildeexp('~root/foo.txt');
ok( $path, "tildeexp, $path");
$path = $utils->tildeexp('no/tilde/in/path');
$path = $base->tildeexp('no/tilde/in/path');
cmp_ok( $path, 'eq', 'no/tilde/in/path', 'tildeexp, no expansion');
};

127
t/qpsmtpd-config.t Normal file
View File

@ -0,0 +1,127 @@
use strict;
use warnings;
use Data::Dumper;
use File::Path;
use Test::More;
use Sys::Hostname;
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();
__clear_cache();
__default();
__from_file();
__get_qmail();
__get_qmail_map();
__expand_inclusion();
__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 __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 __clear_cache {
$Qpsmtpd::Config::config_cache{foo} = 2;
$Qpsmtpd::Config::dir_memo{dir1} = 'some/path';
$config->clear_cache();
ok(! $Qpsmtpd::Config::config_cache{foo}, "clear_cache, config_cache")
or diag Data::Dumper::Dumper($Qpsmtpd::Config::config_cache{foo});
ok(! $Qpsmtpd::Config::dir_memo{dir1}, "clear_cache, dir_memo")
};
sub __default {
is($config->default('me'), hostname, "default, my hostname");
is($config->default('timeout'), 1200, "default timeout is 1200");
is($config->default('undefined-test'), undef, "default, undefined");
$Qpsmtpd::Config::defaults{'zero-test'} = 0;
is($config->default('zero-test'), 0, "default, zero");
}
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 __get_qmail_map {
eval "require CDB_File"; ## no critic (StringyEval)
if (!$@) {
my $r = $config->get_qmail_map('users', 't/config/users');
ok(keys %$r, 'get_qmail_map("users.cdb")');
ok($r->{'!example.com-'}, "get_qmail_map, known entry");
};
}
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 __expand_inclusion {
# TODO
}
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'
);
};

141
t/qpsmtpd.t
View File

@ -2,45 +2,44 @@
use strict;
use warnings;
use Cwd;
use Data::Dumper;
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();
__authenticated();
__config_dir();
__get_qmail_config();
__config();
__auth_user();
__auth_mechanism();
__spool_dir();
__log();
__load_logging();
__config_dir();
__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 {
# $configfile, $config, $visited
}
sub __log {
my $warned = '';
local $SIG{__WARN__} = sub {
@ -55,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");
@ -75,20 +65,101 @@ sub __load_logging {
$Qpsmtpd::hooks->{logging} = undef; # restore
}
sub __authenticated {
sub __spool_dir {
my $dir = $qp->spool_dir();
ok($dir, "spool_dir is at $dir");
ok(!$qp->authenticated(), "authenticated, undef");
my $cwd = getcwd;
chomp $cwd;
open my $SD, '>', "./config.sample/spool_dir";
print $SD "$cwd/t/tmp";
close $SD;
my $spool_dir = $smtpd->spool_dir();
ok($spool_dir =~ m!/tmp/$!, "Located the spool directory")
or diag ("spool_dir: $spool_dir instead of tmp");
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 {
my $r = $qp->temp_file();
ok( $r, "temp_file at $r");
if ($r && -f $r) {
unlink $r;
ok( unlink $r, "cleaned up temp file $r");
}
}
sub __temp_dir {
my $r = $qp->temp_dir();
ok( $r, "temp_dir at $r");
if ($r && -d $r) { File::Path::rmtree($r); }
$r = $qp->temp_dir('0775');
ok( $r, "temp_dir with mask, $r");
if ($r && -d $r) { File::Path::rmtree($r); }
}
sub __size_threshold {
is( $qp->size_threshold(), 10000, "size_threshold from t/config is 1000")
or warn "size_threshold: " . $qp->size_threshold;
$Qpsmtpd::Size_threshold = 5;
cmp_ok( 5, '==', $qp->size_threshold(), "size_threshold equals 5");
$Qpsmtpd::Size_threshold = undef;
}
sub __authenticated {
ok( ! $qp->authenticated(), "authenticated is undefined");
$qp->{_auth} = 1;
ok($qp->authenticated(), "authenticated, true");
ok($qp->authenticated(), "authenticated is true");
$qp->{_auth} = 0;
ok(!$qp->authenticated(), "authenticated, false");
ok(! $qp->authenticated(), "authenticated is false");
}
sub __auth_user {
ok( ! $qp->auth_user(), "auth_user is undefined");
$qp->{_auth_user} = 'matt';
cmp_ok('matt', 'eq', $qp->auth_user(), "auth_user set");
$qp->{_auth_user} = undef;
}
sub __auth_mechanism {
ok( ! $qp->auth_mechanism(), "auth_mechanism is undefined");
$qp->{_auth_mechanism} = 'MD5';
cmp_ok('MD5', 'eq', $qp->auth_mechanism(), "auth_mechanism set");
$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 = (
@ -187,11 +258,15 @@ sub __config {
}
}
1;
package FakeAddress;
sub new {
shift;
return bless {@_};
my $class = shift;
return bless {@_}, $class;
}
sub address { } # pass the can('address') conditional
1;

27
t/tempstuff.t
View File

@ -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);