.perltidyrc config.sample/invalid_resolvable_fromhost config.sample/size_threshold plugins/queue/exim-bsmtp @@ -1,10 +1,20 @@ 0.40 - Make the clamdscan plugin temporarily deny mail if if can't talk to clamd - (Filippo Carletti) +0.31.1 - 2005/11/18 + Add missing files to the distribution, oops... (Thanks Budi Ang!) + (exim plugin, tls plugin, various sample configuration files) -0.31 - + +0.31 - 2005/11/16 + + STARTTLS support (see plugins/tls) + + Added queue/exim-bsmtp plugin to spool accepted mail into an Exim + backend via BSMTP. (Devin Carraway) + + New plugin inheritance system, see the bottom of README.plugins for + more information qpsmtpd-forkserver: --listen-address may now be given more than once, to request listening on multiple local addresses (Devin Carraway) @@ -17,14 +27,41 @@ postfix backend, which expects to have write permission to a fifo which usually belongs to group postdrop). (pjh) + qpsmtpd-forkserver: if -d or --detach is given on the commandline, + forkserver will detach from the controlling terminal and daemonize + itself (Devin Carraway) + + replace some fun smtp comments with boring ones. + + example patterns for badrcptto plugin - Gordon Rowell + + Extend require_resolvable_fromhost to include a configurable list of + "impossible" addresses to combat spammer forging. (Hanno Hecker) + + Use qmail/control/smtpdgreeting if it exists, otherwise + show the original qpsmtpd greeting (with version information). + + Apply slight variation on patch from Peter Holzer to allow specification of + an explicit $QPSMTPD_CONFIG variable to specify where the config lives, + overriding $QMAIL/control and /var/qmail/control if set. The usual + "last location with the file wins" rule still applies. + + Refactor Qpsmtpd::Address + when disconncting with a temporary failure, return 421 rather than 450 or 451. (Peter J. Holzer) The unrecognized_command hook now uses DENY_DISCONNECT return for disconnecting the user. + If the environment variable $QPSMTPD_CONFIG is set, qpsmtpd will look + for its config files in the directory given therein, in addition to (and + in preference to) other locations. (Peter J. Holzer) + Updated documentation + Various minor cleanups + 0.30 - 2005/07/05 Changes @@ -1,6 +1,8 @@ Changes config.sample/badhelo +config.sample/badrcptto_patterns config.sample/dnsbl_zones +config.sample/invalid_resolvable_fromhost config.sample/IP config.sample/logging config.sample/loglevel @@ -8,6 +10,7 @@ config.sample/plugins config.sample/relayclients config.sample/require_resolvable_fromhost config.sample/rhsbl_zones +config.sample/size_threshold CREDITS lib/Apache/Qpsmtpd.pm lib/Qpsmtpd.pm @@ -55,6 +58,7 @@ plugins/logging/adaptive plugins/logging/devnull plugins/logging/warn plugins/milter +plugins/queue/exim-bsmtp plugins/queue/maildir plugins/queue/postfix-queue plugins/queue/qmail-queue @@ -65,6 +69,7 @@ plugins/require_resolvable_fromhost plugins/rhsbl plugins/sender_permitted_from plugins/spamassassin +plugins/tls plugins/virus/aveclient plugins/virus/bitdefender plugins/virus/check_for_hi_virus MANIFEST @@ -57,13 +57,9 @@ run the following command in the /home/smtpd/ directory. svn co http://svn.perl.org/qpsmtpd/trunk . -Or if you want a specific release, use for example +Beware that the trunk might be unstable and unsuitable for anything but development, so you might want to get a specific release, for example: - svn co http://svn.perl.org/qpsmtpd/tags/0.30 . - -In the branch L<http://svn.perl.org/qpsmtpd/branches/high_perf/> we -have an experimental event based version of qpsmtpd that can handle -thousands of simultaneous connections with very little overhead. + svn co http://svn.perl.org/qpsmtpd/tags/0.31.1 . chmod o+t ~smtpd/qpsmtpd/ (or whatever directory you installed qpsmtpd in) to make supervise start the log process. README @@ -10,13 +10,15 @@ pez (or pezmail) Near term roadmap ================= -0.31: +0.32: - Bugfixes - add module requirements to the META.yml file 0.40: - Add user configuration plugin - Add plugin API for checking if a local email address is valid + - use keyword "ESMTPA" in Received header in case of authentication to comply with RFC 3848. + 0.50: Include the popular check_delivery[1] functionality via the 0.30 API STATUS @@ -1,13 +1,13 @@ package Qpsmtpd; use strict; -use vars qw($VERSION $Logger $TraceLevel $Spool_dir); +use vars qw($VERSION $Logger $TraceLevel $Spool_dir $Size_threshold); use Sys::Hostname; use Qpsmtpd::Constants; use Qpsmtpd::Transaction; use Qpsmtpd::Connection; -$VERSION = "0.31-dev"; +$VERSION = "0.40-dev"; sub version { $VERSION }; @@ -242,8 +242,6 @@ sub expand_inclusion_ { } -#our $HOOKS; - sub load_plugins { my $self = shift; @@ -480,6 +478,29 @@ sub temp_dir { return $dirname; } +sub size_threshold { + my $self = shift; + unless ( defined $Size_threshold ) { + $Size_threshold = $self->config('size_threshold') || 0; + $self->log(LOGNOTICE, "size_threshold set to $Size_threshold"); + } + return $Size_threshold; +} + +sub auth_user { + my ($self, $user) = @_; + $user =~ s/[\r\n].*//s; + $self->{_auth_user} = $user if $user; + return (defined $self->{_auth_user} ? $self->{_auth_user} : "" ); +} + +sub auth_mechanism { + my ($self, $mechanism) = @_; + $mechanism =~ s/[\r\n].*//s; + $self->{_auth_mechanism} = $mechanism if $mechanism; + return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" ); +} + 1; __END__ lib/Qpsmtpd.pm @@ -1,16 +1,74 @@ +#!/usr/bin/perl -w package Qpsmtpd::Address; use strict; +=head1 NAME + +Qpsmtpd::Address - Lightweight E-Mail address objects + +=head1 DESCRIPTION + +Based originally on cut and paste from Mail::Address and including +every jot and tittle from RFC-2821/2822 on what is a legal e-mail +address for use during the SMTP transaction. + +=head1 USAGE + + my $rcpt = Qpsmtpd::Address->new('<email.address@example.com>'); + +The objects created can be used as is, since they automatically +stringify to a standard form, and they have an overloaded comparison +for easy testing of values. + +=head1 METHODS + +=cut + +use overload ( + '""' => \&format, + 'cmp' => \&_addr_cmp, +); + +=head2 new() + +Can be called two ways: + +=over 4 + +=item * Qpsmtpd::Address->new('<full_address@example.com>') + +The normal mode of operation is to pass the entire contents of the +RCPT TO: command from the SMTP transaction. The value will be fully +parsed via the L<canonify> method, using the full RFC 2821 rules. + +=item * Qpsmtpd::Address->new("user", "host") + +If the caller has already split the address from the domain/host, +this mode will not L<canonify> the input values. This is not +recommended in cases of user-generated input for that reason. This +can be used to generate Qpsmtpd::Address objects for accounts like +"<postmaster>" or indeed for the bounce address "<>". + +=back + +The resulting objects can be stored in arrays or used in plugins to +test for equality (like in badmailfrom). + +=cut + sub new { - my ($class, $address) = @_; - my $self = [ ]; - if ($address =~ /^<(.*)>$/) { - $self->[0] = $1; - } else { - $self->[0] = $address; + my ($class, $user, $host) = @_; + my $self = {}; + if ($user =~ /^<(.*)>$/ ) { + ($user, $host) = $class->canonify($user) } - bless ($self, $class); - return $self; + elsif ( not defined $host ) { + my $address = $user; + ($user, $host) = $address =~ m/(.*)(?:\@(.*))/; + } + $self->{_user} = $user; + $self->{_host} = $host; + return bless $self, $class; } # Definition of an address ("path") from RFC 2821: @@ -110,6 +168,15 @@ sub new { # # (We ignore all obs forms) +=head2 canonify() + +Primarily an internal method, it is used only on the path portion of +an e-mail message, as defined in RFC-2821 (this is the part inside the +angle brackets and does not include the "human readable" portion of an +address). It returns a list of (local-part, domain). + +=cut + sub canonify { my ($dummy, $path) = @_; my $atom = '[a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~]+'; @@ -131,60 +198,131 @@ sub canonify { # empty path is ok return "" if $path eq ""; - # + # bare postmaster is permissible, perl RFC-2821 (4.5.1) + return ("postmaster", undef) if $path eq "postmaster"; + my ($localpart, $domainpart) = ($path =~ /^(.*)\@($domain)$/); - return undef unless defined $localpart; + return (undef) unless defined $localpart; if ($localpart =~ /^$atom(\.$atom)*/) { # simple case, we are done - return $path; + return ($localpart, $domainpart); } if ($localpart =~ /^"(($qtext|\\$text)*)"$/) { $localpart = $1; $localpart =~ s/\\($text)/$1/g; - return "$localpart\@$domainpart"; + return ($localpart, $domainpart); } - return undef; + return (undef); } +=head2 parse() + +Retained as a compatibility method, it is completely equivalent +to new() called with a single parameter. +=cut -sub parse { - my ($class, $line) = @_; - my $a = $class->canonify($line); - return ($class->new($a)) if (defined $a); - return undef; +sub parse { # retain for compatibility only + return shift->new(shift); } +=head2 address() + +Can be used to reset the value of an existing Q::A object, in which +case it takes a parameter with or without the angle brackets. + +Returns the stringified representation of the address. NOTE: does +not escape any of the characters that need escaping, nor does it +include the surrounding angle brackets. For that purpose, see +L<format>. + +=cut + sub address { my ($self, $val) = @_; - my $oldval = $self->[0]; - return $self->[0] = $val if (defined($val)); - return $oldval; + if ( defined($val) ) { + $val = "<$val>" unless $val =~ /^<.+>$/; + my ($user, $host) = $self->canonify($val); + $self->{_user} = $user; + $self->{_host} = $host; + } + return ( defined $self->{_user} ? $self->{_user} : '' ) + . ( defined $self->{_host} ? '@'.$self->{_host} : '' ); } +=head2 format() + +Returns the canonical stringified representation of the address. It +does escape any characters requiring it (per RFC-2821/2822) and it +does include the surrounding angle brackets. It is also the default +stringification operator, so the following are equivalent: + + print $rcpt->format(); + print $rcpt; + +=cut + sub format { my ($self) = @_; my $qchar = '[^a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~.]'; - my $s = $self->[0]; - return '<>' unless $s; - my ($user, $host) = $s =~ m/(.*)\@(.*)/; - if ($user =~ s/($qchar)/\\$1/g) { - return qq{<"$user"\@$host>}; + return '<>' unless defined $self->{_user}; + if ( ( my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) { + return qq(<"$user") + . ( defined $self->{_host} ? '@'.$self->{_host} : '' ). ">"; } - return "<$s>"; + return "<".$self->address().">"; } +=head2 user() + +Returns the "localpart" of the address, per RFC-2821, or the portion +before the '@' sign. + +=cut + sub user { my ($self) = @_; - my ($user, $host) = $self->[0] =~ m/(.*)\@(.*)/; - return $user; + return $self->{_user}; } +=head2 host() + +Returns the "domain" part of the address, per RFC-2821, or the portion +after the '@' sign. + +=cut + sub host { my ($self) = @_; - my ($user, $host) = $self->[0] =~ m/(.*)\@(.*)/; - return $host; + return $self->{_host}; +} + +sub _addr_cmp { + require UNIVERSAL; + my ($left, $right, $swap) = @_; + my $class = ref($left); + + unless ( UNIVERSAL::isa($right, $class) ) { + $right = $class->new($right); + } + + #invert the address so we can sort by domain then user + $left = lc($left->host.'='.$left->user); + $right = lc($right->host.'='.$right->user); + + if ( $swap ) { + ($right, $left) = ($left, $right); + } + + return ($left cmp $right); } +=head1 COPYRIGHT + +Copyright 2004-2005 Peter J. Holzer. See the LICENSE file for more +information. + +=cut + 1; lib/Qpsmtpd/Address.pm @@ -226,19 +226,6 @@ sub e64 return($res); } -sub Qpsmtpd::SMTP::auth { - my ( $self, $arg, @stuff ) = @_; - - #they AUTH'd once already - return $self->respond( 503, "but you already said AUTH ..." ) - if ( defined $self->{_auth} - and $self->{_auth} == OK ); - return $self->respond( 503, "AUTH not defined for HELO" ) - if ( $self->connection->hello eq "helo" ); - - return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $arg, @stuff ); -} - sub SASL { # $DB::single = 1; @@ -326,9 +313,8 @@ sub SASL { $session->connection->relay_client(1); $session->log( LOGINFO, $msg ); - $session->{_auth_user} = $user; - $session->{_auth_mechanism} = $mechanism; - s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_mechanism}); + $session->auth_user($user); + $session->auth_mechanism($mechanism); return OK; } lib/Qpsmtpd/Auth.pm @@ -37,9 +37,9 @@ sub _register { my $self = shift; my $qp = shift; local $self->{_qp} = $qp; - $self->init($qp, @_); + $self->init($qp, @_) if $self->can('init'); $self->_register_standard_hooks($qp, @_); - $self->register($qp, @_); + $self->register($qp, @_) if $self->can('register'); } # Designed to be overloaded @@ -73,6 +73,14 @@ sub spool_dir { shift->qp->spool_dir; } +sub auth_user { + shift->qp->auth_user(@_); +} + +sub auth_mechanism { + shift->qp->auth_mechanism(@_); +} + sub temp_file { my $self = shift; my $tempfile = $self->qp->temp_file; lib/Qpsmtpd/Plugin.pm @@ -15,6 +15,8 @@ use fields qw( hooks start_time _auth + _auth_user + _auth_mechanism _commands _config_cache _connection lib/Qpsmtpd/PollServer.pm @@ -196,7 +196,9 @@ sub ehlo_respond { $conn->hello_host($hello_host); $self->transaction; - my @capabilities = @{ $self->transaction->notes('capabilities') }; + my @capabilities = $self->transaction->notes('capabilities') + ? @{ $self->transaction->notes('capabilities') } + : (); # Check for possible AUTH mechanisms my %auth_mechanisms; @@ -227,6 +229,19 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) { } } +sub auth { + my ( $self, $arg, @stuff ) = @_; + + #they AUTH'd once already + return $self->respond( 503, "but you already said AUTH ..." ) + if ( defined $self->{_auth} + and $self->{_auth} == OK ); + return $self->respond( 503, "AUTH not defined for HELO" ) + if ( $self->connection->hello eq "helo" ); + + return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $arg, @stuff ); +} + sub mail { my $self = shift; return $self->respond(501, "syntax error in parameters") if !$_[0] or $_[0] !~ m/^from:/i; @@ -365,7 +380,6 @@ sub rcpt_respond { return 0; } - sub help { my $self = shift; $self->respond(214, lib/Qpsmtpd/SMTP.pm @@ -39,7 +39,7 @@ sub run { my $self = shift; # should be somewhere in Qpsmtpd.pm and not here... - $self->load_plugins; + $self->load_plugins unless $self->{hooks}; my $rc = $self->start_conversation; return if $rc != DONE; lib/Qpsmtpd/TcpServer.pm @@ -15,9 +15,6 @@ sub start { my %args = @_; my $self = { _notes => { capabilities => [] }, _rcpt => [], started => time }; bless ($self, $class); - my $sz = $self->config('memory_threshold'); - $sz = 10_000 unless defined($sz); - $self->{_size_threshold} = $sz; return $self; } @@ -91,13 +88,28 @@ sub body_current_pos { return $self->{_body_current_pos} || 0; } -# TODO - should we create the file here if we're storing as an array? sub body_filename { my $self = shift; - return unless $self->{_body_file}; + $self->body_spool() unless $self->{_filename}; + $self->{_body_file}->flush(); # so contents won't be cached return $self->{_filename}; } +sub body_spool { + my $self = shift; + $self->log(LOGINFO, "spooling message to disk"); + $self->{_filename} = $self->temp_file(); + $self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600) + or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error; + if ($self->{_body_array}) { + foreach my $line (@{ $self->{_body_array} }) { + $self->{_body_file}->print($line) or die "Cannot print to temp file: $!"; + } + $self->{_body_start} = $self->{_header_size}; + } + $self->{_body_array} = undef; +} + sub body_write { my $self = shift; my $data = shift; @@ -125,19 +137,7 @@ sub body_write { $self->{_body_size} += length($1); ++$self->{_body_current_pos}; } - if ($self->{_body_size} >= $self->{_size_threshold}) { - #warn("spooling to disk\n"); - $self->{_filename} = $self->temp_file(); - $self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600) - or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error; - if ($self->{_body_array}) { - foreach my $line (@{ $self->{_body_array} }) { - $self->{_body_file}->print($line) or die "Cannot print to temp file: $!"; - } - $self->{_body_start} = $self->{_header_size}; - } - $self->{_body_array} = undef; - } + $self->body_spool if ( $self->{_body_size} >= $self->size_threshold() ); } } lib/Qpsmtpd/Transaction.pm @@ -2,13 +2,18 @@ use Danga::DNS; -sub register { - my ($self) = @_; - $self->register_hook("connect", "connect_handler"); - $self->register_hook("connect", "pickup_handler"); +sub init { + my ($self, $qp, $denial ) = @_; + if ( defined $denial and $denial =~ /^disconnect$/i ) { + $self->{_dnsbl}->{DENY} = DENY_DISCONNECT; + } + else { + $self->{_dnsbl}->{DENY} = DENY; + } + } -sub connect_handler { +sub hook_connect { my ($self, $transaction) = @_; my $remote_ip = $self->connection->remote_ip; @@ -99,8 +104,9 @@ sub process_txt_result { # $qp->finish_continuation if $qp->input_sock->readable; } -sub pickup_handler { - my ($self, $transaction) = @_; +sub hook_rcpt { + my ($self, $transaction, $rcpt) = @_; + my $connection = $self->qp->connection; # RBLSMTPD being non-empty means it contains the failure message to return if (defined ($ENV{'RBLSMTPD'}) && $ENV{'RBLSMTPD'} ne '') { @@ -115,6 +121,14 @@ sub pickup_handler { return DECLINED; } +sub hook_disconnect { + my ($self, $transaction) = @_; + + $self->qp->connection->notes('dnsbl_sockets', undef); + + return DECLINED; +} + 1; =head1 NAME plugins/dnsbl @@ -1,22 +1,29 @@ #!/usr/bin/perl - use Danga::DNS; -sub register { - my ($self) = @_; - $self->register_hook("mail", "mail_handler"); - $self->register_hook("rcpt", "rcpt_handler"); +my %invalid = (); + +sub init { + my ($self, $qp) = @_; + foreach my $i ($qp->config("invalid_resolvable_fromhost")) { + $i =~ s/^\s*//; + $i =~ s/\s*$//; + if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) { + $invalid{$1} = $3; + } + } } -sub mail_handler { +sub hook_mail { my ($self, $transaction, $sender) = @_; + return DECLINED + if ($self->qp->connection->notes('whitelistclient')); $self->transaction->notes('resolvable', 1); return DECLINED if $sender->format eq "<>"; return $self->check_dns($sender->host); } - sub check_dns { my ($self, $host) = @_; @@ -66,7 +73,7 @@ sub dns_result { } -sub rcpt_handler { +sub hook_rcpt { my ($self, $transaction) = @_; if (!$transaction->notes('resolvable')) { plugins/require_resolvable_fromhost @@ -2,14 +2,7 @@ use Danga::DNS; -sub register { - my ($self) = @_; - - $self->register_hook('mail', 'mail_handler'); - $self->register_hook('rcpt', 'rcpt_handler'); -} - -sub mail_handler { +sub hook_mail { my ($self, $transaction, $sender) = @_; my %rhsbl_zones_map = (); @@ -59,7 +52,7 @@ sub process_result { } } -sub rcpt_handler { +sub hook_rcpt { my ($self, $transaction, $rcpt) = @_; my $result = $transaction->notes('rhsbl'); plugins/rhsbl @@ -39,6 +39,7 @@ sub init { SSL_server => 1 ) or die "Could not create SSL context: $!"; + # now extract the password... $self->ssl_context($ssl_ctx); # Check for possible AUTH mechanisms @@ -104,10 +105,18 @@ sub hook_unrecognized_command { my $conn = $self->connection; # Create a new connection object with subset of information collected thus far - my $newconn = Qpsmtpd::Connection->new(); - for (qw(local_ip local_port remote_ip remote_port remote_host remote_info relay_client)) { - $newconn->$_($conn->$_()); - } + my $newconn = Qpsmtpd::Connection->new( + map { $_ => $conn->$_ } + qw( + local_ip + local_port + remote_ip + remote_port + remote_host + remote_info + relay_client + ), + ); $self->qp->connection($newconn); $self->qp->reset_transaction; if ($self->qp->isa('Danga::Socket')) { plugins/tls @@ -118,7 +118,7 @@ sub hook_data_post { unless ( $content_type && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i ) { - $self->log( LOGERROR, "non-multipart mail - skipping" ); + $self->log( LOGNOTICE, "non-multipart mail - skipping" ); return DECLINED; } @@ -153,7 +153,10 @@ sub hook_data_post { $clamd = Clamd->new(); # default unix domain socket } - return (DENYSOFT) unless $clamd->ping(); + unless ( $clamd->ping() ) { + $self->log( LOGERROR, "Cannot ping clamd server - did you provide the correct clamd port or socket?" ); + return DECLINED; + } if ( my %found = $clamd->scan($filename) ) { my $viruses = join( ",", values(%found) ); plugins/virus/clamdscan @@ -24,9 +24,6 @@ use Getopt::Long; $|++; -# For debugging -# $SIG{USR1} = sub { Carp::confess("USR1") }; - use Socket qw(SOMAXCONN IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET); $SIG{'PIPE'} = "IGNORE"; # handled manually qpsmtpd @@ -39,7 +39,7 @@ usage: qpsmtpd-forkserver [ options ] -u, --user U : run as a particular user (default 'smtpd') -m, --max-from-ip M : limit connections from a single IP; default 5 --pid-file P : print main servers PID to file P - --detach : detach from controlling terminal (daemonize) + -d, --detach : detach from controlling terminal (daemonize) EOT exit 0; } @@ -51,8 +51,8 @@ GetOptions('h|help' => \&usage, 'p|port=i' => \$PORT, 'u|user=s' => \$USER, 'pid-file=s' => \$PID_FILE, - 'd|debug+' => \$DEBUG, - 'detach' => \$DETACH, + 'debug+' => \$DEBUG, + 'd|detach' => \$DETACH, ) || &usage; # detaint the commandline @@ -172,6 +172,10 @@ if ($PID_FILE) { close PID; } +# Populate class cached variables +$qpsmtpd->spool_dir; +$qpsmtpd->size_threshold; + while (1) { REAPER(); my $running = scalar keys %childstatus; @@ -189,7 +193,6 @@ while (1) { # possible something condition... next; } - # Make this client blocking while we figure out if we actually want to # do something with it. IO::Handle::blocking($client, 1); @@ -233,7 +236,17 @@ while (1) { ::log(LOGINFO, "Connection Timed Out"); exit; }; - ::log(LOGINFO, "Accepted connection $running/$MAXCONN"); + my $localsockaddr = getsockname($client); + my ($lport, $laddr) = sockaddr_in($localsockaddr); + $ENV{TCPLOCALIP} = inet_ntoa($laddr); + # my ($port, $iaddr) = sockaddr_in($hisaddr); + $ENV{TCPREMOTEIP} = inet_ntoa($iaddr); + $ENV{TCPREMOTEHOST} = gethostbyaddr($iaddr, AF_INET) || "Unknown"; + + # don't do this! + #$0 = "qpsmtpd-forkserver: $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}"; + + ::log(LOGINFO, "Accepted connection $running/$MAXCONN from $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}"); $::LineMode = 1; @@ -245,11 +258,11 @@ while (1) { $qp->push_back_read("Connect\n"); Qpsmtpd::PollServer->AddTimer(0.1, sub { }); while (1) { - $qp->enable_read; - my $line = $qp->get_line; - last if !defined($line); - my $output = $qp->process_line($line); - $qp->write($output) if $output; + $qp->enable_read; + my $line = $qp->get_line; + last if !defined($line); + my $output = $qp->process_line($line); + $qp->write($output) if $output; } exit; # child leaves qpsmtpd-forkserver @@ -2,7 +2,7 @@ use strict; $^W = 1; -use Test::More tests => 28; +use Test::More tests => 29; BEGIN { use_ok('Qpsmtpd::Address'); @@ -16,6 +16,11 @@ $ao = Qpsmtpd::Address->parse($as); ok ($ao, "parse $as"); is ($ao->format, $as, "format $as"); +$as = '<postmaster>'; +$ao = Qpsmtpd::Address->parse($as); +ok ($ao, "parse $as"); +is ($ao->format, $as, "format $as"); + $as = '<foo@example.com>'; $ao = Qpsmtpd::Address->parse($as); ok ($ao, "parse $as"); @@ -38,21 +43,6 @@ $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->parse($as); -is ($ao, undef, "can't parse $as"); - -$as = '<@example.com>'; -is (Qpsmtpd::Address->parse($as), undef, "can't parse $as"); - -$as = '<@123>'; -is (Qpsmtpd::Address->parse($as), undef, "can't parse $as"); - -$as = '<user>'; -is (Qpsmtpd::Address->parse($as), undef, "can't parse $as"); - - $as = 'foo@example.com'; $ao = Qpsmtpd::Address->new($as); ok ($ao, "new $as"); @@ -79,10 +69,35 @@ $as = '<foo@foo.x.example.com>'; $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"); t/qpsmtpd-address.t 8ac6157ee8303042e1c2fd15aeb22f93c7d0730d John Peacock jpeacock@cpan.org http://github.com/abh/qpsmtpd/commit/2535e772939f9f5f88aba016168d76e0e3abeac5 2535e772939f9f5f88aba016168d76e0e3abeac5 2005-12-22T13:30:53-08:00 2005-12-22T13:30:53-08:00 Merge branches/0.3x back to trunk. Too many individual changes to document. Trust me... ;-) Lightly tested (i.e. it accepts and delivers mail with minimal plugins). NOTES/LIMITATIONS: logging/adaptive currently eats some log messages. auth_vpopmail_sql is currently broken (needs continuations?). 'make test' fails in dnsbl (no Test::Qpsmtpd::input_sock() method). git-svn-id: https://svn.perl.org/qpsmtpd/trunk@588 958fd67b-6ff1-0310-b445-bb7760255be9 fc533d1024fdb216711ee1f7f162731d0b151d42 John Peacock jpeacock@cpan.org