diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index be1cea4..9ef1056 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -221,34 +221,40 @@ sub get_qmail_config { # CDB config support really should be moved to a plugin if ($type and $type eq "map") { - 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; - } + 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) { @@ -257,10 +263,12 @@ sub _config_from_file { } $visited ||= []; - push @{$visited}, $configfile; + push @$visited, $configfile; - open my $CF, '<', $configfile - or warn "$$ could not open configfile $configfile: $!" and return; + 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/ } diff --git a/t/qpsmtpd-address.t b/t/qpsmtpd-address.t index 0e5f88a..56c9ecf 100644 --- a/t/qpsmtpd-address.t +++ b/t/qpsmtpd-address.t @@ -1,108 +1,120 @@ #!/usr/bin/perl use strict; -$^W = 1; +use warnings; -use Test::More qw/no_plan/; +use Test::More; + +use lib 'lib'; BEGIN { use_ok('Qpsmtpd::Address'); } -my $as; -my $ao; +__new(); +__parse(); -$as = '<>'; -$ao = Qpsmtpd::Address->parse($as); -ok($ao, "parse $as"); -is($ao->format, $as, "format $as"); +done_testing(); -$as = ''; -$ao = Qpsmtpd::Address->parse($as); -ok($ao, "parse $as"); -is($ao->format, $as, "format $as"); +sub __new { + my ($as, $ao); -$as = ''; -$ao = Qpsmtpd::Address->parse($as); -ok($ao, "parse $as"); -is($ao->format, $as, "format $as"); + 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 + ); -is($ao->user, 'foo', 'user'); -is($ao->host, 'example.com', 'host'); +# 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 + ); + + 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 + + $as = ''; + $ao = Qpsmtpd::Address->new($as); + is($ao, undef, "illegal $as"); +} + +sub __parse { + my ($as, $ao); + + $as = '<>'; + $ao = Qpsmtpd::Address->parse($as); + ok($ao, "parse $as"); + is($ao->format, $as, "format $as"); + + $as = ''; + $ao = Qpsmtpd::Address->parse($as); + ok($ao, "parse $as"); + is($ao->format, $as, "format $as"); + + $as = ''; + $ao = Qpsmtpd::Address->parse($as); + ok($ao, "parse $as"); + is($ao->format, $as, "format $as"); + + 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. -$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"); + $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 -$as = ''; -$ao = Qpsmtpd::Address->parse($as); -ok($ao, "parse $as"); -is($ao->format, '<"foo\ bar"@example.com>', "format $as"); + $as = ''; + $ao = Qpsmtpd::Address->parse($as); + ok($ao, "parse $as"); + is($ao->format, '<"foo\ bar"@example.com>', "format $as"); -$as = 'foo@example.com'; -$ao = Qpsmtpd::Address->new($as); -ok($ao, "new $as"); -is($ao->address, $as, "address $as"); + $as = 'foo@example.com'; + $ao = Qpsmtpd::Address->new($as); + ok($ao, "new $as"); + is($ao->address, $as, "address $as"); -$as = ''; -$ao = Qpsmtpd::Address->new($as); -ok($ao, "new $as"); -is($ao->address, 'foo@example.com', "address $as"); + $as = ''; + $ao = Qpsmtpd::Address->new($as); + ok($ao, "new $as"); + is($ao->address, 'foo@example.com', "address $as"); -$as = ''; -$ao = Qpsmtpd::Address->new($as); -ok($ao, "new $as"); -is($ao->format, $as, "format $as"); + $as = ''; + $ao = Qpsmtpd::Address->new($as); + ok($ao, "new $as"); + is($ao->format, $as, "format $as"); -$as = 'foo@foo.x.example.com'; -ok($ao = Qpsmtpd::Address->parse('<' . $as . '>'), "parse $as"); -is($ao && $ao->address, $as, "address $as"); + $as = 'foo@foo.x.example.com'; + 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 ... -is($ao && $ao->address('test@example.com'), - 'test@example.com', 'address(test@example.com)'); + is($ao && $ao->address('test@example.com'), + 'test@example.com', 'address(test@example.com)'); -$as = ''; -$ao = Qpsmtpd::Address->new($as); -ok($ao, "new $as"); -is($ao->format, $as, "format $as"); -is("$ao", $as, "overloaded stringify $as"); + $as = ''; + $ao = Qpsmtpd::Address->new($as); + ok($ao, "new $as"); + is($ao->format, $as, "format $as"); + is("$ao", $as, "overloaded stringify $as"); -$as = 'foo@foo.x.example.com'; -ok($ao = Qpsmtpd::Address->parse("<$as>"), "parse <$as>"); -is($ao && $ao->address, $as, "address $as"); -ok($ao eq $as, "overloaded 'cmp' operator"); - -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 - ); - -# 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 - ); - -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 - -$as = ''; -$ao = Qpsmtpd::Address->new($as); -is($ao, undef, "illegal $as"); + $as = 'foo@foo.x.example.com'; + ok($ao = Qpsmtpd::Address->parse("<$as>"), "parse <$as>"); + is($ao && $ao->address, $as, "address $as"); + ok($ao eq $as, "overloaded 'cmp' operator"); +}; diff --git a/t/qpsmtpd.t b/t/qpsmtpd.t index fecee7f..f02ce6c 100644 --- a/t/qpsmtpd.t +++ b/t/qpsmtpd.t @@ -9,18 +9,36 @@ use lib 'lib'; # test lib/Qpsmtpd (vs site_perl) BEGIN { use_ok('Qpsmtpd'); } BEGIN { use_ok('Qpsmtpd::Constants'); } -my $package = 'Qpsmtpd'; -my $qp = bless {}, $package; +my $qp = bless {}, 'Qpsmtpd'; ok( $qp->version(), "version, " . $qp->version()); is_deeply( Qpsmtpd::hooks(), {}, 'hooks, empty'); +__authenticated(); __config_dir(); +__get_qmail_config(); +__config(); __log(); __load_logging(); done_testing(); +sub __config { + my @r = $qp->config('badhelo'); + ok( $r[0], "config, badhelo, @r"); +}; + +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 { @@ -54,3 +72,14 @@ sub __load_logging { $Qpsmtpd::hooks->{logging} = undef; # restore } + +sub __authenticated { + + ok( ! $qp->authenticated(), "authenticated, undef"); + + $qp->{_auth} = 1; + ok( $qp->authenticated(), "authenticated, true"); + + $qp->{_auth} = 0; + ok( !$qp->authenticated(), "authenticated, false"); +};