initial import - based on my qpsmtpd fork

which will merge into the main branch fairly easily

.gitignore

@@ -1,15 +1,27 @@
-blib/
-.build/
-_build/
-cover_db/
-inc/
-Build
-Build.bat
+/config
+/config/
+/pm_to_blib
+/blib/
+
+# only ignore top-level Makefile; we need the one in packaging/rpm!
+/Makefile
+Makefile.[a-z]*
+
+# ignore file produced by rpm build process
+/packaging/rpm/qpsmtpd.spec
+packaging/rpm/build/
+
+*~
+*.bak
+denysoft_greylist.dbm
+denysoft_greylist.dbm.lock
+greylist.dbm
+greylist.dbm.lock
+
+/cover_db/
 .last_cover_stats
-Makefile
-Makefile.old
+
+*.tar.gz
+
 MANIFEST.bak
-META.yml
-MYMETA.yml
 nytprof.out
-pm_to_blib

.perltidyrc

@@ -0,0 +1,16 @@
+
+-i=4    # 4 space indentation (we used to use 2; in the future we'll use 4)
+-ci=2   # continuation indention
+
+-pt=2   # tight parens
+-sbt=2  # tight square parens
+-bt=2   # tight curly braces
+-bbt=0  # open code block curly braces
+
+-lp     # line up with parentheses
+-cti=1  # align closing parens with opening parens ("closing token placement")
+
+# -nolq # don't outdent long quotes (not sure if we should enable this)
+
+
+

.travis.yml

@@ -0,0 +1,5 @@
+language: perl
+perl:
+  - "5.14"
+  - "5.12"
+  - "5.10"

CREDITS

@@ -0,0 +1,36 @@
+Jim Winstead <jimw@trainedmonkey.com>: the core "command dispatch"
+system in qpsmtpd is taken from his colobus nntp server.  The
+check_badmailfrom and check_mailrcptto plugins.
+
+John Peacock <jpeacock@cpan.org>: More changes, fixes and vast
+improvements for me to ever catch up on here.
+
+Matt Sergeant <matt@sergeant.org>: Clamav plugin.  Patch for the dnsbl
+plugin to give us all the dns results.  Resident SpamAssassin guru.
+PPerl. smtp-forward plugin. Documentation (yay!).  Lots of fixes and
+tweaks.  Apache module.  Event based high performance experiment.
+
+Devin Carraway <qpsmtpd@devin.com>: Patch to not accept half mails if
+the connection gets dropped at the wrong moment.  Support and enable
+taint checking. MAIL FROM host dns check configurable.  HELO hook.
+initial earlytalker plugin.
+
+Andrew Pam <xanni@glasswings.com.au>: fixing the maximum message size
+(databytes) stuff.
+
+Marius Kjeldahl <marius@kjeldahl.net>, Zukka Zitting
+<jukka.zitting@iki.fi>: Patches for supporting $ENV{RELAYCLIENT}
+
+Robert Spier <robert@perl.org>: Klez filter.
+
+Rasjid Wilcox <rasjidw@openminddev.net>: Lots of patches as per the
+Changes file.
+
+Kee Hinckley <nazgul@somewhere.com>: Sent me the correct strftime
+format for the dates in the "Received" headers.
+
+Gergely Risko <risko@risko.hu>: Fixed timeout bug when the client sent
+DATA and then stopped before sending the next line.
+
+... and many many others per the Changes file and version control logs and
+    mailing list archives.  Thanks everyone!

LICENSE

@@ -0,0 +1,19 @@
+Copyright (C) 2001-2010 Ask Bjoern Hansen, Develooper LLC
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is furnished to do
+so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

MANIFEST

@@ -0,0 +1,160 @@
+.gitignore
+Changes
+config.sample/badhelo
+config.sample/badmailfrom
+config.sample/badrcptto_patterns
+config.sample/dnsbl_zones
+config.sample/flat_auth_pw
+config.sample/invalid_resolvable_fromhost
+config.sample/IP
+config.sample/logging
+config.sample/loglevel
+config.sample/plugins
+config.sample/rcpthosts
+config.sample/relayclients
+config.sample/require_resolvable_fromhost
+config.sample/rhsbl_zones
+config.sample/size_threshold
+config.sample/tls_before_auth
+config.sample/tls_ciphers
+CREDITS
+docs/advanced.pod
+docs/authentication.pod
+docs/config.pod
+docs/development.pod
+docs/hooks.pod
+docs/logging.pod
+docs/plugins.pod
+docs/writing.pod
+lib/Apache/Qpsmtpd.pm
+lib/Danga/Client.pm
+lib/Danga/TimeoutSocket.pm
+lib/Qpsmtpd.pm
+lib/Qpsmtpd/Address.pm
+lib/Qpsmtpd/Auth.pm
+lib/Qpsmtpd/Command.pm
+lib/Qpsmtpd/ConfigServer.pm
+lib/Qpsmtpd/Connection.pm
+lib/Qpsmtpd/Constants.pm
+lib/Qpsmtpd/DSN.pm
+lib/Qpsmtpd/Plugin.pm
+lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm
+lib/Qpsmtpd/PollServer.pm
+lib/Qpsmtpd/Postfix.pm
+lib/Qpsmtpd/Postfix/Constants.pm
+lib/Qpsmtpd/Postfix/pf2qp.pl
+lib/Qpsmtpd/SMTP.pm
+lib/Qpsmtpd/SMTP/Prefork.pm
+lib/Qpsmtpd/TcpServer.pm
+lib/Qpsmtpd/TcpServer/Prefork.pm
+lib/Qpsmtpd/Transaction.pm
+lib/Qpsmtpd/Utils.pm
+LICENSE
+log/run
+Makefile.PL
+MANIFEST			This list of files
+MANIFEST.SKIP
+META.yml			Module meta-data (added by MakeMaker)
+plugins/async/check_earlytalker
+plugins/async/dns_whitelist_soft
+plugins/async/dnsbl
+plugins/async/queue/smtp-forward
+plugins/async/require_resolvable_fromhost
+plugins/async/rhsbl
+plugins/async/uribl
+plugins/auth/auth_checkpassword
+plugins/auth/auth_cvm_unix_local
+plugins/auth/auth_flat_file
+plugins/auth/auth_ldap_bind
+plugins/auth/auth_vpopmail
+plugins/auth/auth_vpopmail_sql
+plugins/auth/auth_vpopmaild
+plugins/auth/authdeny
+plugins/check_badmailfrom
+plugins/check_badmailfromto
+plugins/check_badrcptto
+plugins/check_badrcptto_patterns
+plugins/check_bogus_bounce
+plugins/check_basicheaders
+plugins/check_earlytalker
+plugins/check_loop
+plugins/relay
+plugins/check_spamhelo
+plugins/connection_time
+plugins/content_log
+plugins/count_unrecognized_commands
+plugins/dns_whitelist_soft
+plugins/dnsbl
+plugins/domainkeys
+plugins/dont_require_anglebrackets
+plugins/greylisting
+plugins/help
+plugins/hosts_allow
+plugins/http_config
+plugins/ident/geoip
+plugins/ident/p0f
+plugins/logging/adaptive
+plugins/logging/apache
+plugins/logging/connection_id
+plugins/logging/devnull
+plugins/logging/file
+plugins/logging/syslog
+plugins/logging/transaction_id
+plugins/logging/warn
+plugins/milter
+plugins/noop_counter
+plugins/parse_addr_withhelo
+plugins/queue/exim-bsmtp
+plugins/queue/maildir
+plugins/queue/postfix-queue
+plugins/queue/qmail-queue
+plugins/queue/smtp-forward
+plugins/quit_fortune
+plugins/random_error
+plugins/rcpt_ok
+plugins/rcpt_regexp
+plugins/require_resolvable_fromhost
+plugins/rhsbl
+plugins/sender_permitted_from
+plugins/spamassassin
+plugins/tls
+plugins/tls_cert
+plugins/uribl
+plugins/virus/aveclient
+plugins/virus/bitdefender
+plugins/virus/clamav
+plugins/virus/clamdscan
+plugins/virus/hbedv
+plugins/virus/kavscanner
+plugins/virus/klez_filter
+plugins/virus/sophie
+plugins/virus/uvscan
+qpsmtpd
+qpsmtpd-async
+qpsmtpd-forkserver
+qpsmtpd-prefork
+README
+README.plugins
+run
+STATUS
+t/addresses.t
+t/config.t
+t/helo.t
+t/misc.t
+t/plugin_tests.t
+t/plugin_tests/auth/auth_flat_file
+t/plugin_tests/auth/auth_vpopmail
+t/plugin_tests/auth/auth_vpopmail_sql
+t/plugin_tests/auth/auth_vpopmaild
+t/plugin_tests/auth/authdeny
+t/plugin_tests/auth/authnull
+t/plugin_tests/check_badrcptto
+t/plugin_tests/greylisting
+t/plugin_tests/dnsbl
+t/plugin_tests/ident/geoip
+t/plugin_tests/rcpt_ok
+t/qpsmtpd-address.t
+t/rset.t
+t/tempstuff.t
+t/Test/Qpsmtpd.pm
+t/Test/Qpsmtpd/Plugin.pm

MANIFEST.SKIP

@@ -0,0 +1,32 @@
+CVS/.*
+\.cvsignore$
+\.bak$
+\.sw[a-z]$
+\.tar$
+\.tgz$
+\.tar\.gz$
+\.o$
+\.xsi$
+\.bs$
+output/.*
+\.#
+^mess/
+^sqlite/
+^output/
+^tmp/
+^blib/
+^blibdirs$
+^Makefile$
+^Makefile\.[a-z]+$
+^pm_to_blib$
+~$
+^MANIFEST\.bak
+^tv\.log$
+^MakeMaker-\d
+\#$
+\B\.svn\b
+^\.perltidyrc$
+^\.git/.*
+^cover_db/
+\.(orig|rej)$
+packaging

Makefile.PL

@@ -0,0 +1,38 @@
+#!/usr/bin/perl -w
+
+use strict;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    NAME           => 'qpsmtpd',
+    VERSION_FROM   => 'lib/Qpsmtpd.pm',
+    PREREQ_PM      => {
+        'Mail::Header' => 0,
+        'MIME::Base64' => 0,
+        'Net::DNS'     => 0.39,
+        'Data::Dumper' => 0,
+        'File::Temp'   => 0,
+        'Time::HiRes'  => 0,
+        'Net::IP'      => 0,
+        'Date::Parse'  => 0,
+    },
+    ABSTRACT       => 'Flexible smtpd daemon written in Perl',
+    AUTHOR         => 'Ask Bjoern Hansen <ask@develooper.com>',
+    EXE_FILES      => [qw(qpsmtpd qpsmtpd-forkserver qpsmtpd-prefork qpsmtpd-async)],
+);
+
+sub MY::libscan {
+    my $path = $_[1];
+    return '' if $path =~ /\B\.svn\b/;
+    return $path;
+}
+
+sub MY::postamble {
+  qq[
+testcover :
+\t cover -delete && \\
+   HARNESS_PERL_SWITCHES=-MDevel::Cover \$(MAKE) test && \\
+   cover
+]
+
+}

README

@@ -0,0 +1,205 @@
+#
+#  this file is best read with `perldoc README`
+#
+
+=head1 NAME
+
+Qpsmtpd - qmail perl simple mail transfer protocol daemon
+
+web:
+  http://smtpd.develooper.com/
+
+mailinglist:
+  qpsmtpd-subscribe@perl.org
+
+
+=head1 DESCRIPTION
+
+What is Qpsmtpd?
+
+Qpsmtpd is an extensible SMTP engine written in Perl.  No, make that
+easily extensible!  See plugins/quit_fortune for a very useful, er,
+cute example.
+
+=head2 License
+
+Qpsmtpd is licensed under the MIT License; see the LICENSE file for
+more information.
+
+=head2 What's new in this release?
+
+See the Changes file! :-)
+
+
+=head1 Installation
+
+=head2 Required Perl Modules
+
+The following Perl modules are required:
+   Net::DNS
+   MIME::Base64
+   Mail::Header (part of the MailTools distribution)
+
+If you use a version of Perl older than 5.8.0 you will also need
+   Data::Dumper
+   File::Temp
+   Time::HiRes
+
+The easiest way to install modules from CPAN is with the CPAN shell.
+Run it with
+
+  perl -MCPAN -e shell
+
+=head2 qpsmtpd installation
+
+Make a new user and a directory where you'll install qpsmtpd.  I
+usually use "smtpd" for the user and /home/smtpd/qpsmtpd/ for the
+directory.
+
+Put the files there.  If you install from git you can just do
+run the following command in the /home/smtpd/ directory.
+
+   git clone git://github.com/smtpd/qpsmtpd.git
+
+Beware that the master branch might be unstable and unsuitable for anything
+but development, so you might want to get a specific release, for
+example (after running git clone):
+
+   git checkout -b local_branch v0.84
+
+chmod o+t ~smtpd/qpsmtpd/ (or whatever directory you installed qpsmtpd
+in) to make supervise start the log process.
+
+Edit the file config/IP and put the ip address you want to use for
+qpsmtpd on the first line (or use 0 to bind to all interfaces).
+
+If you use the supervise tools, then you are practically done!
+Just symlink /home/smtpd/qpsmtpd into your /services (or /var/services
+or /var/svscan or whatever) directory.  Remember to shutdown
+qmail-smtpd if you are replacing it with qpsmtpd.
+
+If you don't use supervise, then you need to run the ./run script in
+some other way.
+
+The smtpd user needs write access to ~smtpd/qpsmtpd/tmp/ but should
+not need to write anywhere else.  This directory can be configured
+with the "spool_dir" configuration and permissions can be set with
+"spool_perms".
+
+As per version 0.25 the distributed ./run script runs tcpserver with
+the -R flag to disable identd lookups.  Remove the -R flag if that's
+not what you want.
+
+
+=head2 Configuration
+
+Configuration files can go into either /var/qmail/control or into the
+config subdirectory of the qpsmtpd installation.  Configuration should
+be compatible with qmail-smtpd making qpsmtpd a drop-in replacement.
+
+If qmail is installed in a nonstandard location you should set the
+$QMAIL environment variable to that location in your "./run" file.
+
+If there is anything missing, then please send a patch (or just
+information about what's missing) to the mailinglist or to
+ask@develooper.com.
+
+
+=head1 Better Performance
+
+For better performance we recommend using "qpsmtpd-forkserver" or
+running qpsmtpd under Apache 2.x.  If you need extremely high
+concurrency and all your plugins are compatible, you might want to try
+the "qpsmtpd-async" model.
+
+=head1 Plugins
+
+The qpsmtpd core only implements the SMTP protocol.  No useful
+function can be done by qpsmtpd without loading plugins.
+
+Plugins are loaded on startup where each of them register their
+interest in various "hooks" provided by the qpsmtpd core engine.
+
+At least one plugin MUST allow or deny the RCPT command to enable
+receiving mail.  The "rcpt_ok" is one basic plugin that does
+this.  Other plugins provide extra functionality related to this; for
+example the require_resolvable_fromhost plugin described above.
+
+
+=head1 Configuration files
+
+All the files used by qmail-smtpd should be supported; so see the man
+page for qmail-smtpd.  Extra files used by qpsmtpd include:
+
+=over 4
+
+=item plugins
+
+List of plugins, one per line, to be loaded in the order they
+appear in the file.  Plugins are in the plugins directory (or in
+a subdirectory of there).
+
+
+=item rhsbl_zones
+
+Right hand side blocking lists, one per line. For example:
+
+    dsn.rfc-ignorant.org does not accept bounces - http://www.rfc-ignorant.org/
+
+See http://www.rfc-ignorant.org/ for more examples.
+
+
+=item dnsbl_zones
+
+Normal ip based DNS blocking lists ("RBLs"). For example:
+
+  relays.ordb.org
+  spamsources.fabel.dk
+
+
+=item require_resolvable_fromhost
+
+If this file contains anything but a 0 on the first line, envelope
+senders will be checked against DNS. If an A or a MX record can't be
+found the mail command will return a soft rejection (450).
+
+=item spool_dir
+
+If this file contains a directory, it will be the spool directory
+smtpd uses during the data transactions. If this file doesn't exist, it
+will default to use $ENV{HOME}/tmp/. This directory should be set with
+a mode of 700 and owned by the smtpd user.
+
+=item spool_perms
+
+The default spool permissions are 0700. If you need some other value,
+chmod the directory and set it's octal value in config/spool_perms.
+
+=item tls_before_auth
+
+If this file contains anything except a 0 on the first noncomment line, then
+AUTH will not be offered unless TLS/SSL are in place, either with STARTTLS,
+or SMTP-SSL on port 465.
+
+=item everything (?) that qmail-smtpd supports.
+
+In my test qpsmtpd installation I have a "config/me" file containing
+the hostname I use for testing qpsmtpd (so it doesn't introduce itself
+with the normal name of the server).
+
+=back
+
+
+=head1 Problems
+
+In case of problems, always check the logfile first.
+
+By default, qpsmtpd logs to log/main/current.  Qpsmtpd can log a lot of
+debug information. You can get more or less by adjusting the number in
+config/loglevel. Between 1 and 3 should give you a little. Setting it
+to 10 or higher will get lots of information in the logs.
+
+If the logfile doesn't give away the problem, then post to the
+mailinglist (subscription instructions above).  If possible, put
+the logfile on a webserver and include a reference to it in the mail.
+

README.plugins

@@ -0,0 +1,13 @@
+#
+# read this with 'perldoc README.plugins'  ...
+#
+
+=head1 qpsmtpd plugin system; developer documentation
+
+Plugin documentation is now in F<docs/plugins.pod>.
+
+See the examples in plugins/ and ask questions on the qpsmtpd
+mailinglist; subscribe by sending mail to qpsmtpd-subscribe@perl.org.
+
+=cut
+

STATUS

@@ -0,0 +1,77 @@
+
+New Name Suggestions
+====================
+ignite
+flare(mta)
+quench
+pez (or pezmail)
+
+
+Roadmap
+=======
+
+ - http://code.google.com/p/smtpd/issues
+
+ - Bugfixes - qpsmtpd is extremely stable (in production since 2001), but
+   there are always more things to fix.
+
+ - Add user configuration plugin infrastructure
+   - Add plugin API for checking if a local email address is valid
+
+ - Add API to reject individual recipients after the RCPT has been
+   accepted and generate individual bounce messages.
+
+Issues
+======
+
+See http://code.google.com/p/smtpd/issues/list
+
+------ The rest of the list here might be outdated. ------
+------ Patches to remove things are welcome.        ------
+
+
+add whitelist support to the dnsbl plugin (and maybe to the rhsbl
+plugin too).  Preferably both supporting DNS based whitelists and
+filebased (CDB) ones.
+
+
+plugin support;
+
+  allow plugins to return multiple response lines (does it have to
+  join them to one for SMTP?)
+
+  support plugins for the rest of the commands.
+
+  specify a priority in register_hook. ("LAST", "FIRST", "MIDDLE", or
+  maybe a number)
+
+  plugin access to the data line by line during the DATA phase
+  (instead of just after)
+
+  if qmail-queue can't be loaded we still return 250 ?!
+
+Make a system for configuring the plugins per user/domain/...
+
+  support databytes per user / domain
+
+localiphost - support foo@[a.b.c.d] addresses 
+
+Move dispatch() etc from SMTP.pm to Qpsmtpd.pm to allow other similar
+protocols to use the qpsmtpd framework. 
+
+
+
+Future Ideas
+============
+
+Methods to create a bounce message easily; partly so we can accept a
+mail for one user but bounce it right away for another RCPT'er.
+
+The data_post hook should be able to put in the notes what addresses
+should go through, bounce and get rejected respectively, and qpsmtpd
+should just do the right thing.  See also
+http://nntp.perl.org/group/perl.qpsmtpd/170
+
+David Carraway has some thoughts for "user filters"
+http://nntp.perl.org/group/perl.qpsmtpd/2
+

UPGRADING

@@ -0,0 +1,26 @@
+
+When upgrading from:
+
+v 0.84 or below
+
+CHECK_RELAY, CHECK_NORELAY, RELAY_ONLY
+
+    All 3 plugins are deprecated and replaced with a new 'relay' plugin. The new plugin reads the same config files (see 'perldoc plugins/relay') as the previous plugins. To get the equivalent functionality of enabling 'relay_only', use the 'only' argument to the relay plugin as documented in the RELAY ONLY section of plugins/relay.
+
+GREYLISTING plugin:
+
+    'mode' config argument is deprecated. Use reject and reject_type instead.
+
+    The greylisting DB format has changed to accommodate IPv6 addresses. (The DB key has colon ':' seperated fields, and IPv6 addresses are colon delimited). The new format converts the IPs into integers. There is a new config option named 'upgrade' that when enabled, updates all the records in your DB to the new format. Simply add 'upgrade 1' to the plugin entry in config/plugins, start up qpsmtpd once, make one connection. A log entry will be made, telling how many records were upgraded. Remove the upgrade option from your config.
+
+SPF plugin:
+
+    spf_deny setting deprecated. Use reject N setting instead, which provides administrators with more granular control over SPF. For backward compatibility, a spf_deny setting of 1 is mapped to 'reject 3' and a 'spf_deny 2' is mapped to 'reject 4'.
+
+
+P0F plugin:
+    defaults to p0f v3 (was v2).
+
+    Upgrade p0f to version 3 or add 'version 2' to your p0f line in config/plugins. perldoc plugins/ident/p0f for more details.
+
+

config.sample/IP

@@ -0,0 +1,4 @@
+0
+# the first line of this file is being used as the IP 
+# address tcpserver will bind to.  Use 0 to bind to all
+# interfaces.

config.sample/badhelo

@@ -0,0 +1,4 @@
+# these domains never uses their domain when greeting us, so reject transactions
+aol.com
+yahoo.com
+

config.sample/badmailfrom

@@ -0,0 +1,5 @@
+# This is a sample config file for badmailfrom
+# - single email address
+badmailexample@microsoft.com
+# - block and entire host, and provide a custom reason
+@www.yahoo.com  yahoo never sends from www

config.sample/badrcptto

@@ -0,0 +1,9 @@
+######## entries used for testing ###
+bad@example.com
+@bad.example.com
+########    Example patterns   #######
+# Format is pattern\s+Response
+# Don't forget to anchor the pattern if required
+!       Sorry, bang paths not accepted here
+@.*@    Sorry, multiple at signs not accepted here
+%       Sorry, percent hack not accepted here 

config.sample/badrcptto_patterns

@@ -0,0 +1,5 @@
+# Format is pattern\s+Response
+# Don't forget to anchor the pattern if required
+!       Sorry, bang paths not accepted here
+@.*@    Sorry, multiple at signs not accepted here
+%       Sorry, percent hack not accepted here 

config.sample/dnsbl_allow

@@ -0,0 +1,2 @@
+# test entry for dnsbl plugin
+192.168.99.5

config.sample/dnsbl_zones

@@ -0,0 +1,2 @@
+spamsources.fabel.dk
+zen.spamhaus.org

config.sample/flat_auth_pw

@@ -0,0 +1,4 @@
+# used by plugins/auth/auth_flat_file
+# example entries
+good@example.com:good_pass
+bad@example.com:bad_pass

config.sample/invalid_resolvable_fromhost

@@ -0,0 +1,6 @@
+# include full network block including mask
+127.0.0.0/8 
+0.0.0.0/8 
+224.0.0.0/4
+169.254.0.0/16 
+10.0.0.0/8 

config.sample/logging

@@ -0,0 +1,23 @@
+# by default, qpsmtpd logs to STDERR at the level set in config/loglevel.
+#
+# In addition, qpsmtpd will log through any plugins enabled in this file.
+# You can enable as many plugins as you wish. Example plugin invocations
+# are included below. Just remove the # symbol to enable them.
+
+# default logging plugin
+logging/warn 9
+
+#logging/adaptive [accept minlevel] [reject maxlevel] [prefix char]
+#logging/adaptive 4 6
+
+# send logs to apache (useful if running qpsmtpd under apache)
+#logging/apache
+
+# send logs to the great bit bucket
+#logging/devnull
+
+# log to a file
+#logging/file loglevel LOGINFO /var/log/qpsmtpd.log
+
+# log to syslog
+#logging/syslog loglevel LOGWARN priority LOG_NOTICE

config.sample/loglevel

@@ -0,0 +1,12 @@
+# Log levels
+# LOGDEBUG   = 7
+# LOGINFO    = 6
+# LOGNOTICE  = 5
+# LOGWARN    = 4
+# LOGERROR   = 3
+# LOGCRIT    = 2
+# LOGALERT   = 1
+# LOGEMERG   = 0
+#
+# This setting controls the built-in qpsmtpd logging.
+4

config.sample/norelayclients

@@ -0,0 +1,6 @@
+# used by plugins/relay
+# test entries - http://tools.ietf.org/html/rfc5737
+192.0.99.5
+192.0.99.6
+192.0.98.
+# add your own entries below...

config.sample/plugins

@@ -0,0 +1,94 @@
+#
+#  Example configuration file for plugins
+#
+
+# enable this to get configuration via http; see perldoc
+# plugins/http_config for details.
+#   http_config http://localhost/~smtpd/config/  http://www.example.com/smtp.pl?config=
+
+# hosts_allow does not work with the tcpserver deployment model!
+#   perldoc plugins/hosts_allow for an alternative.
+#
+# The hosts_allow module must be loaded if you want the -m / --max-from-ip /
+# my $MAXCONNIP = 5; # max simultaneous connections from one IP
+# settings... without this it will NOT refuse more than $MAXCONNIP connections
+# from one IP!
+hosts_allow
+
+# information plugins
+ident/geoip
+#ident/p0f /tmp/.p0f_socket version 3
+#connection_time
+
+# enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <>
+dont_require_anglebrackets
+
+# enable to reject MAIL FROM:/RCPT TO: parameters if client helo was HELO
+# (strict RFC 821)... this is not used in EHLO ...
+# parse_addr_withhelo
+
+quit_fortune
+# tls should load before count_unrecognized_commands
+#tls
+check_earlytalker
+count_unrecognized_commands 4
+relay
+
+require_resolvable_fromhost
+
+rhsbl
+dnsbl
+check_badmailfrom
+check_badrcptto
+check_spamhelo
+
+# 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_vpopmaild
+#auth/auth_vpopmail_sql
+auth/auth_flat_file
+auth/authdeny
+
+# this plugin needs to run after all other "rcpt" plugins
+rcpt_ok
+
+check_basicheaders days 5 reject_type temp
+domainkeys
+
+# content filters
+virus/klez_filter
+
+
+# You can run the spamassassin plugin with options.  See perldoc
+# plugins/spamassassin for details.
+#
+spamassassin
+
+# rejects mails with a SA score higher than 20 and munges the subject
+# of the score is higher than 10.
+#
+#   spamassassin reject_threshold 20 munge_subject_threshold 10
+
+# dspam must run after spamassassin for the learn_from_sa feature to work
+dspam learn_from_sa 7 reject 1
+
+# run the clamav virus checking plugin
+# virus/clamav
+
+# You must enable a queue plugin - see the options in plugins/queue/ - for example:
+
+# queue to a maildir
+# queue/maildir /home/spamtrap/mail
+
+# queue the mail with qmail-queue
+# queue/qmail-queue
+
+
+# If you need to run the same plugin multiple times, you can do
+# something like the following
+#    relay
+#    relay:0 somearg
+#    relay:1 someotherarg

config.sample/rcpthosts

@@ -0,0 +1 @@
+localhost

config.sample/relayclients

@@ -0,0 +1,6 @@
+# used by plugins/relay
+# Format is IP, or IP part with trailing dot
+# e.g. "127.0.0.1", or "192.168."
+127.0.0.1 
+# leading/trailing whitespace is ignored
+ 192.0. 

config.sample/require_resolvable_fromhost

@@ -0,0 +1,3 @@
+1
+
+# use 0 to disable; anything else to enable.

config.sample/rhsbl_zones

@@ -0,0 +1,5 @@
+dsn.rfc-ignorant.org does not accept bounces. This violates RFC 821/2505/2821 http://www.rfc-ignorant.org/
+
+
+
+

config.sample/size_threshold

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

config.sample/smtpauth-checkpassword

@@ -0,0 +1 @@
+/usr/local/vpopmail/bin/vchkpw /bin/true

config.sample/tls_before_auth

@@ -0,0 +1,2 @@
+# change the next line to 0 if you want to offer AUTH without TLS
+1

config.sample/tls_ciphers

@@ -0,0 +1,10 @@
+# Override default security using suitable string from available ciphers at 
+# L<http://www.openssl.org/docs/apps/ciphers.html#CIPHER_STRINGS>
+# See plugins/tls for details.
+#
+# HIGH is a reasonable default that should satisfy most installations
+HIGH:!SSLv2
+#
+# if you have legacy clients that require less secure connections,
+# consider using this less secure, but PCI compliant setting:
+#DEFAULT:!ADH:!LOW:!EXP:!SSLv2:+HIGH:+MEDIUM

docs/FAQ.pod

@@ -0,0 +1,47 @@
+# best read with perldoc: perldoc FAQ.pod
+
+=head1 FAQ
+
+=head2 Q: Do I need to enable a logging plugin?
+
+=head2 A: No.
+
+When zero logging plugins are configured, logs are directed to STDERR. This
+is the 'default' logging and logs are piped to multilog and stored in
+log/main/current.
+
+When more than zero logging plugins are enabled, builtin logging is disabled
+and logs are sent to every logging plugin configured in config/plugins.
+
+
+=head2 Q: How do I watch the logs?
+
+=head2 A: Here's a few examples:
+
+The default log files can be watched in real time lik this:
+
+ tail -F ~smtpd/log/main/current
+
+To convert the tai timestamps to human readable date time:
+
+ tail -F ~smtpd/log/main/current | tai64nlocal
+
+To exclude the dates entirely, use this command:
+
+ tail -F ~smtpd/smtpd/log/main/current | cut -d' ' -f2-3
+
+
+=head2 Q: How do I get alerts when qpsmtpd has a problem?
+
+=head2 A: Send logs with levels below LOGERROR to syslog.
+
+This can be done by adding the following lines to config/plugins:
+
+  logging/syslog loglevel LOGERROR
+  logging/warn LOGINFO
+
+The warn logging plugin replicates the builtin logging, directing log messages to STDERR. The syslog plugin directs errors to syslog where standard monitoring tools can pick them up and act on them.
+
+With these settings, errors will still get sent to STDERR as well.
+
+=cut

docs/advanced.pod

@@ -0,0 +1,93 @@
+#
+# This file is best read with ``perldoc advanced.pod''
+#
+
+### 
+# Conventions:
+#  plugin names:  F<myplugin>, F<qpsmtpd-async>
+#  constants:     I<LOGDEBUG>
+#  smtp commands, answers: B<HELO>, B<250 Queued!>
+#
+# Notes: 
+#  * due to restrictions of some POD parsers, no C<<$object->method()>>
+#    are allowed, use C<$object-E<gt>method()> 
+# 
+
+=head1 Advanced Playground
+
+=head2 Discarding messages
+
+If you want to make the client think a message has been regularily accepted,
+but in real you delete it or send it to F</dev/null>, ..., use something
+like the following plugin and load it before your default queue plugin.
+
+  sub hook_queue {
+    my ($self, $transaction) = @_;
+    if ($transaction->notes('discard_mail')) {
+      my $msg_id = $transaction->header->get('Message-Id') || '';
+      $msg_id =~ s/[\r\n].*//s;
+      return(OK, "Queued! $msg_id");
+    }
+    return(DECLINED);
+  }
+
+
+=head2 Changing return values
+
+This is an example how to use the C<isa_plugin> method.
+
+The B<rcpt_ok_maxrelay> plugin wraps the B<rcpt_ok> plugin. The B<rcpt_ok>
+plugin checks the F<rcpthosts> and F<morercpthosts> config files for
+domains, which we accept mail for. If not found it tells the
+client that relaying is not allowed. Clients which are marked as
+C<relay clients> are excluded from this rule. This plugin counts the
+number of unsuccessfull relaying attempts and drops the connection if
+too many were made.
+
+The optional parameter I<MAX_RELAY_ATTEMPTS> configures this plugin to drop
+the connection after I<MAX_RELAY_ATTEMPTS> unsuccessful relaying attempts.
+Set to C<0> to disable, default is C<5>.
+
+Note: Do not load both (B<rcpt_ok> and B<rcpt_ok_maxrelay>). This plugin
+should be configured to run I<last>, like B<rcpt_ok>.
+
+ use Qpsmtpd::DSN;
+
+ sub init {
+   my ($self, $qp, @args) = @_;
+   die "too many arguments"
+     if @args > 1;
+   $self->{_count_relay_max} = defined $args[0] ? $args[0] : 5;
+   $self->isa_plugin("rcpt_ok");
+ }
+
+ sub hook_rcpt {
+   my ($self, $transaction, $recipient) = @_;
+   my ($rc, @msg) = $self->SUPER::hook_rcpt($transaction, $recipient);
+
+   return ($rc, @msg)
+      unless (($rc == DENY) and $self->{_count_relay_max});
+
+   my $count = 
+     ($self->connection->notes('count_relay_attempts') || 0) + 1;
+   $self->connection->notes('count_relay_attempts', $count);
+
+   return ($rc, @msg) unless ($count > $self->{_count_relay_max});
+   return Qpsmtpd::DSN->relaying_denied(DENY_DISCONNECT, 
+           "Too many relaying attempts"); 
+ }
+
+=head2 Results of other hooks
+
+B<NOTE:> just copied from README.plugins
+
+If we're in a transaction, the results of a callback are stored in
+
+    $self->transaction->notes( $code->{name})->{"hook_$hook"}->{return}
+
+If we're in a connection, store things in the connection notes instead.
+B<FIXME>: does the above (regarding connection notes) work?
+
+=cut
+
+# vim: ts=2 sw=2 expandtab

docs/authentication.pod

@@ -0,0 +1,258 @@
+#
+# read this with 'perldoc authentication.pod'  ...
+#
+
+=head1 NAME
+
+Authentication framework for qpsmtpd
+
+=head1 DESCRIPTION
+
+Provides support for SMTP AUTH within qpsmtpd transactions, see 
+
+L<http://www.faqs.org/rfcs/rfc2222.html>
+L<http://www.faqs.org/rfcs/rfc2554.html>
+
+for more details.
+
+=head1 USAGE
+
+This code is automatically loaded by Qpsmtpd::SMTP only if a plugin
+providing one of the defined L<Auth Hooks> is loaded.  The only
+time this can happen is if the client process employs the EHLO command to
+initiate the SMTP session.  If the client uses HELO, the AUTH command is
+not available and this module isn't even loaded.
+
+=head2 Plugin Design
+
+An authentication plugin can bind to one or more auth hooks or bind to all
+of them at once.  See L<Multiple Hook Behavior> for more details.
+
+All plugins must provide two functions:
+
+=over 4
+
+=item * init()
+
+This is the standard function which is called by qpsmtpd for any plugin 
+listed in config/plugins.  Typically, an auth plugin should register at
+least one hook, like this:
+
+
+  sub init {
+    my ($self, $qp) = @_;
+
+    $self->register_hook("auth", "authfunction");
+  }
+
+where in this case "auth" means this plugin expects to support any of 
+the defined authentication methods.
+
+=item * authfunction()
+
+The plugin must provide an authentication function which is part of
+the register_hook call.  That function will receive the following
+six parameters when called:
+
+=over 4
+
+=item $self
+
+A Qpsmtpd::Plugin object, which can be used, for example, to emit log
+entries or to send responses to the remote SMTP client.
+
+=item $transaction
+
+A Qpsmtpd::Transaction object which can be used to examine information
+about the current SMTP session like the remote IP address.
+
+=item $mechanism
+
+The lower-case name of the authentication mechanism requested by the
+client; either "plain", "login", or "cram-md5".
+
+=item $user
+
+Whatever the remote SMTP client sent to identify the user (may be bare
+name or fully qualified e-mail address).
+
+=item $clearPassword
+
+If the particular authentication method supports unencrypted passwords
+(currently PLAIN and LOGIN), which will be the plaintext password sent
+by the remote SMTP client.
+
+=item $hashPassword
+
+An encrypted form of the remote user's password, using the MD-5 algorithm
+(see also the $ticket parameter).
+
+=item $ticket
+
+This is the cryptographic challenge which was sent to the client as part
+of a CRAM-MD5 transaction.  Since the MD-5 algorithm is one-way, the same
+$ticket value must be used on the backend to compare with the encrypted
+password sent in $hashPassword.
+
+=back
+
+=back
+
+Plugins should perform whatever checking they want and then return one
+of the following values (taken from Qpsmtpd::Constants):
+
+=over 4
+
+=item OK
+
+If the authentication has succeeded, the plugin can return this value and
+all subsequently registered hooks will be skipped.
+
+=item DECLINED
+
+If the authentication has failed, but any additional plugins should be run, 
+this value will be returned.  If none of the registered plugins succeed, the
+overall authentication will fail.  Normally an auth plugin should return
+this value for all cases which do not succeed (so that another auth plugin
+can have a chance to authenticate the user).
+
+=item DENY
+
+If the authentication has failed, and the plugin wishes this to short circuit
+any further testing, it should return this value.  For example, a plugin could
+register the L<auth-plain> hook and immediately fail any connection which is
+not trusted (e.g. not in the same network).
+
+Another reason to return DENY over DECLINED would be if the user name matched
+an existing account but the password failed to match.  This would make a
+dictionary-based attack much harder to accomplish.  See the included
+auth_vpopmail_sql plugin for how this might be accomplished.
+
+By returning DENY, no further authentication attempts will be made using the
+current method and data.  A remote SMTP client is free to attempt a second
+auth method if the first one fails.
+
+=back
+
+Plugins may also return an optional message with the return code, e.g.
+
+  return (DENY, "If you forgot your password, contact your admin");
+
+and this will be appended to whatever response is sent to the remote SMTP
+client.  There is no guarantee that the end user will see this information,
+though, since some prominent MTA's (produced by M$oft) I<helpfully>
+hide this information under the default configuration.  This message will
+be logged locally, if appropriate, based on the configured log level.
+
+=head1 Auth Hooks
+
+The currently defined authentication methods are:
+
+=over 4
+
+=item * auth-plain
+
+Any plugin which registers an auth-plain hook will engage in a plaintext
+prompted negotiation.  This is the least secure authentication method since
+both the user name and password are visible in plaintext.  Most SMTP clients
+will preferentially choose a more secure method if it is advertised by the
+server.
+
+=item * auth-login
+
+A slightly more secure method where the username and password are Base-64
+encoded before sending.  This is still an insecure method, since it is
+trivial to decode the Base-64 data.  Again, it will not normally be chosen
+by SMTP clients unless a more secure method is not available (or if it fails).
+
+=item * auth-cram-md5
+
+A cryptographically secure authentication method which employs a one-way
+hashing function to transmit the secret information without significant
+risk between the client and server.  The server provides a challenge key
+L<$ticket>, which the client uses to encrypt the user's password.
+Then both user name and password are concatenated and Base-64 encoded before
+transmission.
+
+This hook must normally have access to the user's plaintext password,
+since there is no way to extract that information from the transmitted data.
+Since the CRAM-MD5 scheme requires that the server send the challenge
+L<$ticket> before knowing what user is attempting to log in, there is no way
+to use any existing MD5-encrypted password (like is frequently used with MySQL).
+
+=item * auth
+
+A catch-all hook which requires that the plugin support all three preceeding
+authentication methods.  Any plugins registering the auth hook will be run
+only after all other plugins registered for the specific authentication 
+method which was requested.  This allows you to move from more specific
+plugins to more general plugins (e.g. local accounts first vs replicated
+accounts with expensive network access later).
+
+=back
+
+=head2 Multiple Hook Behavior
+
+If more than one hook is registered for a given authentication method, then
+they will be tried in the order that they appear in the config/plugins file
+unless one of the plugins returns DENY, which will immediately cease all
+authentication attempts for this transaction.
+
+In addition, all plugins that are registered for a specific auth hook will
+be tried before any plugins which are registered for the general auth hook.
+
+=head1 VPOPMAIL
+
+There are 4 authentication (smtp-auth) plugins that can be used with
+vpopmail.
+
+=over 4
+
+=item auth_vpopmaild
+
+If you aren't sure which one to use, then use auth_vpopmaild. It
+supports the PLAIN and LOGIN authentication methods,
+doesn't require the qpsmtpd process to run with special permissions, and
+can authenticate against vpopmail running on another host. It does require
+the vpopmaild server to be running.
+
+=item auth_vpopmail
+
+The next best solution is auth_vpopmail. It requires the p5-vpopmail perl
+module and it compiles against libvpopmail.a. There are two catches. The
+qpsmtpd daemon must run as the vpopmail user, and you must be running v0.09
+or higher for CRAM-MD5 support. The released version is 0.08 but my
+CRAM-MD5 patch has been added to the developers repo:
+   http://github.com/sscanlon/vpopmail
+
+=item auth_vpopmail_sql
+
+If you are using the MySQL backend for vpopmail, then this module can be
+used for smtp-auth. It supports LOGIN, PLAIN, and CRAM-MD5. However, it
+does not work with some vpopmail features such as alias domains, service
+restrictions, nor does it update vpopmail's last_auth information.
+
+=item auth_checkpassword
+
+The auth_checkpassword is a generic authentication module that will work
+with any DJB style checkpassword program, including ~vpopmail/bin/vchkpw.
+It only supports PLAIN and LOGIN auth methods.
+
+=back
+
+=head1 AUTHOR
+
+John Peacock <jpeacock@cpan.org>
+
+Matt Simerson <msimerson@cpan.org> (added VPOPMAIL)
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2004-2006 John Peacock
+
+Portions based on original code by Ask Bjoern Hansen and Guillaume Filion
+
+This plugin is licensed under the same terms as the qpsmtpd package itself.
+Please see the LICENSE file included with qpsmtpd for details.
+
+=cut

docs/config.pod

@@ -0,0 +1,200 @@
+
+=head1 Qpsmtpd configuration
+
+The default way of setting config values is placing files with the
+name of the config variable in the config directory F<config/>, like
+qmail's F</var/qmail/control/> directory. NB: F</var/qmail/control> (or
+F<$ENV{QMAIL}/control>) is used if a file does not exist in C<config/>.
+The location of the C<config/> directory can be set via the
+I<QPSMTPD_CONFIG> environment variable and defaults to the current
+working directory.
+
+Any empty line or lines starting with C<#> are ignored. You may use a
+plugin which hooks the C<config> hook to store the settings in some other
+way. See L<docs/plugins.pod> and L<docs/hooks.pod> for more info on this.
+Some settings still have to go in files, because they are loaded before
+any plugin can return something via the C<config> hook: C<me>, C<logging>,
+C<plugin_dirs> and of course C<plugins>. B<FIXME: more?>
+
+=head2 Core settings
+
+These settings are used by the qpsmtpd core. Any other setting is (hopefully)
+documented by the corresponding plugin. Some settings of important plugins
+are shown below in L</Plugin settings>.
+
+=over 4
+
+=item plugins
+
+The main config file, where all used plugins and their arguments are listed.
+
+=item me
+
+Sets the hostname which is used all over the place: in the greeting message,
+the I<Received: >header, ...
+Default is whatever Sys::Hostname's hostname() returns.
+
+=item plugin_dirs
+
+Where to search for plugins (one directory per line), defaults to F<./plugins>.
+
+=item logging
+
+Sets the primary logging destination, see F<plugins/logging/*>. Format
+is the same as it's used for the F<plugins> config file. B<NOTE:> only
+the first non empty line is used (lines starting with C<#> are counted
+as empty).
+
+=item loglevel
+
+This is not used anymore, I<only> if no F<logging/> plugin is in use. Use a
+logging plugin.
+
+=item databytes
+
+Maximum size a message may be. Without this setting, there is no limit on the
+size. Should be something less than the backend MTA has set as it's maximum
+message size (if there is one).
+
+=item size_threshold
+
+When a message is greater than the size given in this config file, it will be
+spooled to disk. You probably want to enable spooling to disk for most virus
+scanner plugins and F<spamassassin>.
+
+=item smtpgreeting
+
+Override the default SMTP greeting with this string.
+
+=item spool_dir
+
+Where temporary files are stored, defaults to F<~/tmp/>.
+
+=item spool_perms
+
+Permissions of the I<spool_dir>, default is C<0700>. You probably have to
+change the defaults for some scanners (e.g. the F<clamdscan> plugin).
+
+=item timeout
+
+=item timeoutsmtpd
+
+Set the timeout for the clients, C<timeoutsmtpd> is the qmail smtpd control
+file, C<timeout> the qpsmtpd file. Default is 1200 seconds.
+
+=item tls_before_auth
+
+If set to a true value, clients will have to initiate an SSL secured
+connection before any auth succeeds, defaults to C<0>.
+
+=back
+
+=head2 Plugin settings files
+
+=over 4
+
+=item rcpthosts, morercpthosts
+
+Plugin: I<rcpt_ok>
+
+Domains listed in these files will be accepted as valid local domains,
+anything else is rejected with a C<Relaying denied> message. If an entry
+in the C<rcpthosts> file starts with a C<.>, mails to anything ending with
+this string will be accepted, e.g.:
+
+ example.com
+ .example.com
+
+will accept mails for C<user@example.com> and C<user@something.example.com>.
+The C<morercpthosts> file is just checked for exact (case insensitive)
+matches.
+
+=item hosts_allow
+
+Plugin: F<hosts_allow>.
+
+Don't use this config file. The plugin itself is required to set the
+maximum number of concurrent connections. This config setting should
+only be used for some extremly rude clients: if list is too big it will
+slow down accepting new connections.
+
+=item relayclients
+=item morerelayclients
+
+Plugin: F<check_relay>
+
+Allow relaying for hosts listed in this file. The C<relayclients> file accepts
+IPs and CIDR entries. The C<morercpthosts> file accepts IPs and C<prefixes>
+like C<192.168.2.> (note the trailing dot!). With the given example any host
+which IP starts with C<192.168.2.> may relay via us.
+
+=item dnsbl_zones
+
+Plugin: F<dnsbl>
+
+This file specifies the RBL zones list, used by the dnsbl plugin. Ihe IP
+address of each connecting host will be checked against each zone given.
+A few sample DNSBLs are listed in the sample config file, but you should
+evaluate the efficacy and listing policies of a DNSBL before using it.
+
+See also C<dnsbl_allow> and C<dnsbl_rejectmsg> in the documentation of the
+C<dnsbl> plugin
+
+=item require_resolvable_fromhost
+
+Plugin: F<require_resolvable_fromhost>
+
+Reject sender addresses where the MX is unresolvable, i.e. a boolean value
+is the only value in this file. If the MX resolves to something, reject the
+sender address if it resolves to something listed in the
+F<invalid_resolvable_fromhost> config file. The I<invalid_resolvable_fromhost>
+expects IP addresses or CIDR (i.e. C<network/mask> values) one per line, IPv4
+only currenlty.
+
+=back
+
+=head2 Plugin settings arguments
+
+These are arguments that can be set on the config/plugins line, after the name
+of the plugin. These config options are available to all plugins.
+
+=over 4
+
+=item loglevel
+
+Adjust the quantity of logging for the plugin. See docs/logging.pod
+
+=item reject
+
+ plugin reject [ 0 | 1 | naughty ]
+
+Should the plugin reject mail?
+
+The special 'naughty' case will mark the connection as a naughty. Most plugins
+skip processing naughty connections. Filtering plugins can learn from them.
+Naughty connections are terminated up by the B<naughty> plugin.
+
+Plugins that use $self->get_reject() or $self->get_reject_type() will
+automatically honor this setting.
+
+=item reject_type
+
+ plugin reject_type [ perm | temp | disconnect | temp_disconnect ]
+
+Default: perm
+
+Values with temp in the name return a 4xx code and the others return a 5xx
+code.
+
+The I<reject_type> argument and the corresponding get_reject_type() method
+provides a standard way for plugins to automatically return the selected
+rejection type, as chosen by the config setting, the plugin author, or the
+get_reject_type() method.
+
+Plugins that are updated to use the $self->get_reject() or
+$self->get_reject_type() methods will automatically honor this setting.
+
+=back
+
+=cut
+

docs/development.pod

@@ -0,0 +1,143 @@
+
+=head1 Developing Qpsmtpd
+
+=head2 Mailing List
+
+All qpsmtpd development happens on the qpsmtpd mailing list.
+
+Subscribe by sending mail to qpsmtpd-subscribe@perl.org
+
+=head2 Git
+
+We use git for version control.
+
+Ask owns the master repository at git://github.com/smtpd/qpsmtpd.git
+
+We suggest using github to host your repository -- it makes your
+changes easily accessible for pulling into the master.  After you
+create a github account, go to
+http://github.com/smtpd/qpsmtpd/tree/master and click on the "fork"
+button to get your own repository.
+
+=head3 Making a working Copy
+
+ git clone git@github.com:username/qpsmtpd.git qpsmtpd
+
+will check out your copy into a directory called qpsmtpd
+
+=head3 Making a branch for your change
+
+As a general rule, you'll be better off if you do your changes on a
+branch - preferably a branch per unrelated change.
+
+You can use the C<git branch> command to see which branch you are on.
+
+The easiest way to make a new branch is 
+
+  git checkout -b topic/my-great-change
+
+This will create a new branch with the name "topic/my-great-change"
+(and your current commit as the starting point).
+
+=head3 Committing a change
+
+Edit the appropriate files, and be sure to run the test suite.
+
+  emacs lib/Qpsmtpd.pm # for example
+  perl Makefile.PL
+  make test
+
+When you're ready to check it in...
+
+  git add lib/Qpsmtpd.pm     # to let git know you changed the file
+  git add --patch plugin/tls # interactive choose which changes to add
+  git diff --cached          # review changes added
+  git commit                 # describe the commit
+  git log -p                 # review your commit a last time
+  git push origin            # to send to github
+
+=head3 Commit Descriptions
+
+Though not required, it's a good idea to begin the commit message with
+a single short (less than 50 character) line summarizing the change,
+followed by a blank line and then a more thorough description. Tools
+that turn commits into email, for example, use the first line on the
+Subject: line and the rest of the commit in the body.
+(From: L<git-commit(1)>)
+
+=head3 Submit patches by mail
+
+The best way to submit patches to the project is to send them to the
+mailing list for review.  Use the C<git format-patch> command to
+generate patches ready to be mailed. For example:
+
+   git format-patch HEAD~3
+
+will put each of the last three changes in files ready to be mailed
+with the C<git send-email> tool (it might be a good idea to send them
+to yourself first as a test).
+
+Sending patches to the mailing list is the most effective way to
+submit changes, although it helps if you at the same time also commit
+them to a git repository (for example on github).
+
+=head3 Merging changes back in from the master repository
+
+Tell git about the master repository.  We're going to call it 'smtpd'
+for now, but you could call it anything you want.  You only have to do
+this once.
+
+  git remote add smtpd git://github.com/smtpd/qpsmtpd.git
+
+Pull in data from all remote branches
+
+  git remote update
+
+Forward-port local commits to the updated upstream head
+
+  git rebase smtpd/master
+
+If you have a change that conflicts with an upstream change (git will
+let you know) you have two options. 
+
+Manually fix the conflict and then do 
+
+  git add some/file
+  git commit
+
+Or if the conflicting upstream commit did the same logical change then
+you might want to just skip the local change:
+
+  git rebase --skip
+
+Be sure to decide whether you're going to skip before you merge, or
+you might get yourself into an odd situation.
+
+Conflicts happen because upstream committers may make minor tweaks to
+your change before applying it.
+
+=head3 Throwing away changes
+
+If you get your working copy into a state you don't like, you can
+always revert to the last commit:
+
+   git reset --hard HEAD
+
+Or throw away your most recent commit:
+
+   git reset --hard HEAD^
+
+If you make a mistake with this, git is pretty good about keeping your
+commits around even as you merge, rebase and reset away.  This log of
+your git changes is called with "git reflog".
+
+=head3 Applying other peoples changes
+
+If you get a change in an email with the patch, one easy way to apply
+other peoples changes is to use C<git am>.  That will go ahead and
+commit the change.  To modify it, you can use C<git commit --amend>.
+
+If the changes are in a repository, you can add that repository with
+"git remote add" and then either merge them in with "git merge" or
+pick just the relevant commits with "git cherry-pick".
+

docs/hooks.pod

@@ -0,0 +1,915 @@
+#
+# This file is best read with ``perldoc plugins.pod''
+#
+
+### 
+# Conventions:
+#  plugin names:  F<myplugin>, F<qpsmtpd-async>
+#  constants:     I<LOGDEBUG>
+#  smtp commands, answers: B<HELO>, B<250 Queued!>
+#
+# Notes: 
+#  * due to restrictions of some POD parsers, no C<<$object->method()>>
+#    are allowed, use C<$object-E<gt>method()> 
+# 
+
+=head1 SMTP hooks
+
+This section covers the hooks, which are run in a normal SMTP connection. 
+The order of these hooks is like you will (probably) see them, while a mail
+is received. 
+
+Every hook receives a C<Qpsmtpd::Plugin> object of the currently 
+running plugin as the first argument. A C<Qpsmtpd::Transaction> object is 
+the second argument of the current transaction in the most hooks, exceptions 
+are noted in the description of the hook. If you need examples how the 
+hook can be used, see the source of the plugins, which are given as 
+example plugins.
+
+B<NOTE>: for some hooks (post-fork, post-connection, disconnect, deny, ok) the
+return values are ignored. This does B<not> mean you can return anything you
+want. It just means the return value is discarded and you can not disconnect
+a client with I<DENY_DISCONNECT>. The rule to return I<DECLINED> to run the
+next plugin for this hook (or return I<OK> / I<DONE> to stop processing) 
+still applies.
+
+=head2 hook_pre_connection
+
+Called by a controlling process (e.g. forkserver or prefork) after accepting 
+the remote server, but before beginning a new instance (or handing the 
+connection to the worker process).
+
+Useful for load-management and rereading large config files at some
+frequency less than once per session.
+
+This hook is available in the F<qpsmtpd-forkserver>, F<qpsmtpd-prefork> and
+F<qpsmtpd-async> flavours. 
+
+=cut 
+
+NOT FOR: apache, -server and inetd/pperl
+
+=pod
+
+B<NOTE:> You should not use this hook to do major work and / or use lookup 
+methods which (I<may>) take some time, like DNS lookups. This will slow down
+B<all> incoming connections, no other connection will be accepted while this
+hook is running!
+
+Arguments this hook receives are (B<NOTE>: currently no C<%args> for 
+F<qpsmtpd-async>):
+
+  my ($self,$transaction,%args) = @_;
+  # %args is:
+  # %args = ( remote_ip    => inet_ntoa($iaddr),
+  #           remote_port  => $port,
+  #           local_ip     => inet_ntoa($laddr),
+  #           local_port   => $lport,
+  #           max_conn_ip  => $MAXCONNIP,
+  #           child_addrs  => [values %childstatus],
+  #         );
+
+B<NOTE:> the C<$transaction> is of course C<undef> at this time.
+
+Allowed return codes are
+
+=over 4
+
+=item DENY / DENY_DISCONNECT
+
+returns a B<550> to the client and ends the connection
+
+=item DENYSOFT / DENYSOFT_DISCONNECT
+
+returns a B<451> to the client and ends the connection
+
+=back
+
+Anything else is ignored.
+
+Example plugins are F<hosts_allow> and F<connection_time>. 
+
+=head2 hook_connect
+
+It is called at the start of a connection before the greeting is sent to 
+the connecting client.
+
+Arguments for this hook are
+
+  my $self = shift;
+
+B<NOTE:> in fact you get passed two more arguments, which are C<undef> at this
+early stage of the connection, so ignore them.
+
+Allowed return codes are
+
+=over 4
+
+=item OK
+
+Stop processing plugins, give the default response
+
+=item DECLINED
+
+Process the next plugin
+
+=item DONE
+
+Stop processing plugins and dont give the default response, i.e. the plugin 
+gave the response
+
+=item DENY
+
+Return hard failure code and disconnect
+
+=item DENYSOFT
+
+Return soft failure code and disconnect
+
+=back
+
+Example plugin for this hook is the F<check_relay> plugin. 
+
+=head2 hook_helo / hook_ehlo
+
+It is called after the client sent B<EHLO> (hook_ehlo) or B<HELO> (hook_helo)
+Allowed return codes are
+
+=over 4
+
+=item DENY
+
+Return a 550 code
+
+=item DENYSOFT
+
+Return a B<450> code
+
+=item DENY_DISCONNECT / DENYSOFT_DISCONNECT
+
+as above but with disconnect
+
+=item DONE
+
+Qpsmtpd wont do anything, the plugin sent the message
+
+=item DECLINED 
+
+Qpsmtpd will send the standard B<EHLO>/B<HELO> answer, of course only 
+if all plugins hooking I<helo/ehlo> return I<DECLINED>.
+
+=back
+
+Arguments of this hook are
+
+  my ($self, $transaction, $host) = @_;
+  # $host: the name the client sent in the 
+  # (EH|HE)LO line
+
+B<NOTE:> C<$transaction> is C<undef> at this point.
+
+=head2 hook_mail_pre
+
+After the B<MAIL FROM: > line sent by the client is broken into 
+pieces by the C<hook_mail_parse()>, this hook recieves the results.
+This hook may be used to pre-accept adresses without the surrounding 
+I<E<lt>E<gt>> (by adding them) or addresses like 
+I<E<lt>user@example.com.E<gt>> or I<E<lt>user@example.com E<gt>> by 
+removing the trailing I<"."> / C<" ">.
+
+Expected return values are I<OK> and an address which must be parseable
+by C<Qpsmtpd::Address-E<gt>parse()> on success or any other constant to
+indicate failure.
+
+Arguments are 
+
+  my ($self, $transaction, $addr) = @_;
+
+=head2 hook_mail
+
+Called right after the envelope sender line is parsed (the B<MAIL FROM: >
+command). The plugin gets passed a C<Qpsmtpd::Address> object, which means 
+the parsing and verifying the syntax of the address (and just the syntax, 
+no other checks) is already done. Default is to allow the sender address. 
+The remaining arguments are the extensions defined in RFC 1869 (if sent by 
+the client).
+
+B<NOTE:> According to the SMTP protocol, you can not reject an invalid
+sender until after the B<RCPT> stage (except for protocol errors, i.e.
+syntax errors in address). So store it in an C<$transaction-E<gt>note()> and 
+process it later in an rcpt hook.
+
+Allowed return codes are
+
+=over 4
+
+=item OK
+
+sender allowed
+
+=item DENY
+
+Return a hard failure code
+
+=item DENYSOFT
+
+Return a soft failure code
+
+=item DENY_DISCONNECT / DENYSOFT_DISCONNECT
+
+as above but with disconnect
+
+=item DECLINED
+
+next plugin (if any)
+
+=item DONE
+
+skip further processing, plugin sent response
+
+=back
+
+Arguments for this hook are 
+
+  my ($self,$transaction, $sender, %args) = @_;
+  # $sender: an Qpsmtpd::Address object for 
+  # sender of the message
+
+Example plugins for the C<hook_mail> are F<require_resolvable_fromhost>
+and F<check_badmailfrom>.
+
+=head2 hook_rcpt_pre
+
+See C<hook_mail_pre>, s/MAIL FROM:/RCPT TO:/.
+
+=head2 hook_rcpt
+
+This hook is called after the client sent an I<RCPT TO: > command (after 
+parsing the line). The given argument is parsed by C<Qpsmtpd::Address>, 
+then this hook is called. Default is to deny the mail with a soft error 
+code. The remaining arguments are the extensions defined in RFC 1869
+(if sent by the client).
+
+Allowed return codes
+
+=over 4
+
+=item OK
+
+recipient allowed
+
+=item DENY
+
+Return a hard failure code, for example for an I<User does not exist here> 
+message.
+
+=item DENYSOFT
+
+Return a soft failure code, for example if the connect to a user lookup 
+database failed
+
+=item DENY_DISCONNECT / DENYSOFT_DISCONNECT
+
+as above but with disconnect
+
+=item DONE
+
+skip further processing, plugin sent response
+
+=back
+
+Arguments are
+
+  my ($self, $transaction, $recipient, %args) = @_;
+  # $rcpt = Qpsmtpd::Address object with 
+  # the given recipient address
+
+Example plugin is F<rcpt_ok>.
+
+=head2 hook_data
+
+After the client sent the B<DATA> command, before any data of the message
+was sent, this hook is called. 
+
+B<NOTE:> This hook, like B<EHLO>, B<VRFY>, B<QUIT>, B<NOOP>, is an 
+endpoint of a pipelined command group (see RFC 1854) and may be used to 
+detect ``early talkers''. Since svn revision 758 the F<check_earlytalker>
+plugin may be configured to check at this hook for ``early talkers''.
+
+Allowed return codes are
+
+=over 4
+
+=item DENY
+
+Return a hard failure code
+
+=item DENYSOFT
+
+Return a soft failure code
+
+=item DENY_DISCONNECT / DENYSOFT_DISCONNECT
+
+as above but with disconnect
+
+=item DONE
+
+Plugin took care of receiving data and calling the queue (not recommended)
+
+B<NOTE:> The only real use for I<DONE> is implementing other ways of
+receiving the message, than the default... for example the CHUNKING SMTP
+extension (RFC 1869, 1830/3030) ... a plugin for this exists at 
+http://svn.perl.org/qpsmtpd/contrib/vetinari/experimental/chunking, but it
+was never tested ``in the wild''.
+
+=back
+
+Arguments:
+
+  my ($self, $transaction) = @_;
+
+Example plugin is F<greylisting>.
+
+=head2 hook_received_line
+
+If you wish to provide your own Received header line, do it here. You can use
+or discard any of the given arguments (see below).
+
+Allowed return codes:
+
+=over 4
+
+=item OK, $string
+
+use this string for the Received header.
+
+=item anything else
+
+use the default Received header
+
+=back
+
+Arguments are
+
+ my ($self, $transaction, $smtp, $auth, $sslinfo) = @_;
+ # $smtp - the SMTP type used (e.g. "SMTP" or "ESMTP").
+ # $auth - the Auth header additionals.
+ # $sslinfo - information about SSL for the header.
+
+=head2 data_headers_end
+
+This hook fires after all header lines of the message data has been received.
+Defaults to doing nothing, just continue processing. At this step,
+the sender is not waiting for a reply, but we can try and prevent him from
+sending the entire message by disconnecting immediately. (Although it is
+likely the packets are already in flight due to buffering and pipelining).
+
+B<NOTE:> BE CAREFUL! If you drop the connection legal MTAs will retry again 
+and again, spammers will probably not. This is not RFC compliant and can lead
+to an unpredictable mess. Use with caution.
+
+B<NOTE:> This hook does not currently work in async mode.
+
+Why this hook may be useful for you, see 
+L<http://www.nntp.perl.org/group/perl.qpsmtpd/2009/02/msg8502.html>, ff.
+
+Allowed return codes:
+
+=over 4
+
+=item DENY_DISCONNECT
+
+Return B<554 Message denied> and disconnect
+
+=item DENYSOFT_DISCONNECT
+
+Return B<421 Message denied temporarily> and disconnect
+
+=item DECLINED
+
+Do nothing
+
+=back
+
+Arguments:
+
+  my ($self, $transaction) = @_; 
+
+B<FIXME:> check arguments
+
+=head2 hook_data_post
+
+The C<data_post> hook is called after the client sent the final C<.\r\n> 
+of a message, before the mail is sent to the queue.
+
+Allowed return codes are
+
+=over 4
+
+=item DENY
+
+Return a hard failure code
+
+=item DENYSOFT
+
+Return a soft failure code
+
+=item DENY_DISCONNECT / DENYSOFT_DISCONNECT
+
+as above but with disconnect
+
+=item DONE
+
+skip further processing (message will not be queued), plugin gave the response.
+
+B<NOTE:> just returning I<OK> from a special queue plugin does (nearly) 
+the same (i.e. dropping the mail to F</dev/null>) and you don't have to 
+send the response on your own.
+
+If you want the mail to be queued, you have to queue it manually!
+
+=back
+
+Arguments:
+
+  my ($self, $transaction) = @_;
+
+Example plugins: F<spamassassin>, F<virus/clamdscan>
+
+=head2 hook_queue_pre
+
+This hook is run, just before the mail is queued to the ``backend''. You 
+may modify the in-process transaction object (e.g. adding headers) or add 
+something like a footer to the mail (the latter is not recommended).
+
+Allowed return codes are 
+
+=over 4
+
+=item DONE
+
+no queuing is done
+
+=item OK / DECLINED
+
+queue the mail
+
+=back
+
+=head2 hook_queue
+
+When all C<data_post> hooks accepted the message, this hook is called. It 
+is used to queue the message to the ``backend''.
+
+Allowed return codes:
+
+=over 4
+
+=item DONE
+
+skip further processing (plugin gave response code)
+
+=item OK
+
+Return success message, i.e. tell the client the message was queued (this
+may be used to drop the message silently).
+
+=item DENY
+
+Return hard failure code
+
+=item DENYSOFT
+
+Return soft failure code, i.e. if disk full or other temporary queuing 
+problems
+
+=back
+
+Arguments:
+
+  my ($self, $transaction) = @_;
+
+Example plugins: all F<queue/*> plugins
+
+=head2 hook_queue_post
+
+This hook is called always after C<hook_queue>. If the return code is 
+B<not> I<OK>, a message (all remaining return values) with level I<LOGERROR> 
+is written to the log.
+Arguments are
+
+ my $self = shift;
+
+B<NOTE:> C<$transaction> is not valid at this point, therefore not mentioned.
+
+
+=head2 hook_reset_transaction
+
+This hook will be called several times. At the beginning of a transaction 
+(i.e. when the client sends a B<MAIL FROM:> command the first time), 
+after queueing the mail and every time a client sends a B<RSET> command.
+Arguments are 
+
+ my ($self, $transaction) = @_;
+
+B<NOTE:> don't rely on C<$transaction> being valid at this point.
+
+=head2 hook_quit
+
+After the client sent a B<QUIT> command, this hook is called (before the
+C<hook_disconnect>).
+
+Allowed return codes
+
+=over 4
+
+=item DONE
+
+plugin sent response
+
+=item DECLINED
+
+next plugin and / or qpsmtpd sends response
+
+=back
+
+Arguments: the only argument is C<$self>
+
+=cut 
+
+### XXX: FIXME pass the rest of the line to this hook?
+
+=pod
+
+Expample plugin is the F<quit_fortune> plugin.
+
+=head2 hook_disconnect
+
+This hook will be called from several places: After a plugin returned 
+I<DENY(|SOFT)_DISCONNECT>, before connection is disconnected or after the 
+client sent the B<QUIT> command, AFTER the quit hook and ONLY if no plugin 
+hooking C<hook_quit> returned I<DONE>.
+
+All return values are ignored, arguments are just C<$self>
+
+Example plugin is F<logging/file>
+
+=head2 hook_post_connection
+
+This is the counter part of the C<pre-connection> hook, it is called 
+directly before the connection is finished, for example, just before the 
+qpsmtpd-forkserver instance exits or if the client drops the connection 
+without notice (without a B<QUIT>). This hook is not called if the qpsmtpd
+instance is killed.
+
+=cut 
+
+FIXME: we should run this hook on a ``SIGHUP'' or some other signal?
+
+=pod 
+
+The only argument is C<$self> and all return codes are ignored, it would 
+be too late anyway :-).
+
+Example: F<connection_time>
+
+=head1 Parsing Hooks
+
+Before the line from the client is parsed by 
+C<Qpsmtpd::Command-E<gt>parse()> with the built in parser, these hooks 
+are called. They can be used to supply a parsing function for the line,
+which will be used instead of the built in parser.
+
+The hook must return two arguments, the first is (currently) ignored,
+the second argument must be a (CODE) reference to a sub routine. This sub 
+routine receives three arguments:
+
+=over 4
+
+=item $self
+
+the plugin object
+
+=item $cmd
+
+the command (i.e. the first word of the line) sent by the client
+
+=item $line
+
+the line sent by the client without the first word
+
+=back
+
+Expected return values from this sub are I<DENY> and a reason which is 
+sent to the client or I<OK> and the C<$line> broken into pieces according
+to the syntax rules for the command.
+
+B<NOTE: ignore the example from C<Qpsmtpd::Command>, the C<unrecognized_command_parse> hook was never implemented,...>
+
+=head2 hook_helo_parse / hook_ehlo_parse
+
+The provided sub routine must return two or more values. The first is 
+discarded, the second is the hostname (sent by the client as argument 
+to the B<HELO> / B<EHLO> command). All other values are passed to the 
+helo / ehlo hook. This hook may be used to change the hostname the client
+sent... not recommended, but if your local policy says only to accept
+I<HELO> hosts with FQDNs and you have a legal client which can not be 
+changed to send his FQDN, this is the right place.
+
+=head2 hook_mail_parse / hook_rcpt_parse
+
+The provided sub routine must return two or more values. The first is 
+either I<OK> to indicate that parsing of the line was successfull
+or anything else to bail out with I<501 Syntax error in command>. In
+case of failure the second argument is used as the error message for the 
+client.
+
+If parsing was successfull, the second argument is the sender's / 
+recipient's address (this may be without the surrounding I<E<lt>> and 
+I<E<gt>>, don't add them here, use the C<hook_mail_pre()> / 
+C<hook_rcpt_pre()> methods for this). All other arguments are 
+sent to the C<mail / rcpt> hook as B<MAIL> / B<RCPT> parameters (see 
+RFC 1869 I<SMTP Service Extensions> for more info). Note that 
+the mail and rcpt hooks expect a list of key/value pairs as the 
+last arguments.
+
+=head2 hook_auth_parse
+
+B<FIXME...>
+
+=head1 Special hooks
+
+Now some special hooks follow. Some of these hooks are some internal hooks, 
+which may be used to alter the logging or retrieving config values from 
+other sources (other than flat files) like SQL databases.
+
+=head2 hook_logging
+
+This hook is called when a log message is written, for example in a plugin 
+it fires if someone calls C<$self-E<gt>log($level, $msg);>. Allowed
+return codes are
+
+=over 4
+
+=item DECLINED
+
+next logging plugin
+
+=item OK
+
+(not I<DONE>, as some might expect!) ok, plugin logged the message
+
+=back
+
+Arguments are
+
+  my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
+  # $trace: level of message, for example 
+  #          LOGWARN, LOGDEBUG, ...
+  # $hook:  the hook in/for which this logging 
+  #          was called
+  # $plugin: the plugin calling this hook
+  # @log:   the log message
+
+B<NOTE:> C<$transaction> may be C<undef>, depending when / where this hook
+is called. It's probably best not to try acessing it.
+
+All F<logging/*> plugins can be used as example plugins.
+
+=head2 hook_deny
+
+This hook is called after a plugin returned I<DENY>, I<DENYSOFT>, 
+I<DENY_DISCONNECT> or I<DENYSOFT_DISCONNECT>. All return codes are ignored, 
+arguments are
+
+  my ($self, $transaction, $prev_plugin, $return, $return_text) = @_;
+
+B<NOTE:> C<$transaction> may be C<undef>, depending when / where this hook
+is called. It's probably best not to try acessing it.
+
+Example plugin for this hook is F<logging/adaptive>.
+
+=head2 hook_ok
+
+The counter part of C<hook_deny>, it is called after a plugin B<did not>
+return I<DENY>, I<DENYSOFT>, I<DENY_DISCONNECT> or I<DENYSOFT_DISCONNECT>. 
+All return codes are ignored, arguments are
+
+  my ( $self, $transaction, $prev_plugin, $return, $return_text ) = @_;
+
+B<NOTE:> C<$transaction> may be C<undef>, depending when / where this hook
+is called. It's probably best not to try acessing it.
+
+=head2 hook_config
+
+Called when a config file is requested, for example in a plugin it fires 
+if someone calls C<my @cfg = $self-E<gt>qp-E<gt>config($cfg_name);>. 
+Allowed return codes are
+
+=over 4
+
+=item DECLINED
+
+plugin didn't find the requested value
+
+=item OK
+
+requested values as C<@list>, example:
+
+  return (OK, @{$config{$value}}) 
+    if exists $config{$value};
+  return (DECLINED);
+
+=back
+
+Arguments:
+
+  my ($self,$transaction,$value) = @_; 
+  # $value: the requested config item(s)
+
+B<NOTE:> C<$transaction> may be C<undef>, depending when / where this hook
+is called. It's probably best not to try acessing it.
+
+Example plugin is F<http_config> from the qpsmtpd distribution.
+
+=head2 hook_unrecognized_command
+
+This is called if the client sent a command unknown to the core of qpsmtpd.
+This can be used to implement new SMTP commands or just count the number 
+of unknown commands from the client, see below for examples.
+Allowed return codes:
+
+=over 4
+
+=item DENY_DISCONNECT
+
+Return B<521> and disconnect the client
+
+=item DENY
+
+Return B<500>
+
+=item DONE
+
+Qpsmtpd wont do anything; the plugin responded, this is what you want to 
+return, if you are implementing new commands
+
+=item Anything else...
+
+Return B<500 Unrecognized command>
+
+=back
+
+Arguments:
+
+  my ($self, $transaction, $cmd, @args) = @_;
+  # $cmd  = the first "word" of the line 
+  #         sent by the client
+  # @args = all the other "words" of the 
+  #         line sent by the client
+  #         "word(s)": white space split() line
+
+B<NOTE:> C<$transaction> may be C<undef>, depending when / where this hook
+is called. It's probably best not to try acessing it.
+
+Example plugin is F<tls>.
+
+=head2 hook_help
+
+This hook triggers if a client sends the B<HELP> command, allowed return
+codes are:
+
+=over 4
+
+=item DONE
+
+Plugin gave the answer.
+
+=item DENY
+
+The client will get a C<syntax error> message, probably not what you want, 
+better use
+
+  $self->qp->respond(502, "Not implemented.");
+  return DONE;
+
+=back
+
+Anything else will be send as help answer.
+
+Arguments are
+   my ($self, $transaction, @args) = @_;
+
+with C<@args> being the arguments from the client's command.
+
+=head2 hook_vrfy
+
+If the client sents the B<VRFY> command, this hook is called. Default is to 
+return a message telling the user to just try sending the message.
+Allowed return codes:
+
+=over 4
+
+=item OK
+
+Recipient Exists
+
+=item DENY
+
+Return a hard failure code
+
+=item DONE
+
+Return nothing and move on
+
+=item Anything Else...
+
+Return a B<252>
+
+=back
+
+Arguments are:
+
+ my ($self) = shift;
+
+=cut 
+
+FIXME: this sould be changed in Qpsmtpd::SMTP to pass the rest of the line
+as arguments to the hook
+
+=pod
+
+=head2 hook_noop 
+
+If the client sents the B<NOOP> command, this hook is called. Default is to
+return C<250 OK>.
+
+Allowed return codes are:
+
+=over 4
+
+=item DONE
+
+Plugin gave the answer
+
+=item DENY_DISCONNECT
+
+Return error code and disconnect client
+
+=item DENY
+
+Return error code.
+
+=item Anything Else...
+
+Give the default answer of B<250 OK>.
+
+=back
+
+Arguments are
+
+  my ($self,$transaction,@args) = @_;
+
+=head2 hook_post_fork
+
+B<NOTE:> This hook is only available in qpsmtpd-async.
+
+It is called while starting qpsmtpd-async. You can run more than one 
+instance of qpsmtpd-async (one per CPU probably). This hook is called 
+after forking one instance.
+
+Arguments: 
+
+ my $self = shift;
+
+The return values of this hook are discarded.
+
+=head1 Authentication hooks
+
+=cut 
+
+B<FIXME missing:> auth_parse
+
+#=head2 auth
+
+B<FIXME>
+
+#=head2 auth-plain
+
+B<FIXME>
+
+#=head2 auth-login
+
+B<FIXME>
+
+#=head2 auth-cram-md5
+
+B<FIXME>
+
+=pod
+
+See F<docs/authentication.pod>.
+
+=cut
+
+# vim: ts=2 sw=2 expandtab

docs/logging.pod

@@ -0,0 +1,191 @@
+#
+# read this with 'perldoc docs/logging.pod'
+#
+
+=head1 qpsmtpd logging; user documentation
+
+Qpsmtpd has a modular logging system. Here's a few things you need to know:
+
+ * The built-in logging prints log messages to STDERR.
+ * A variety of logging plugins is included, each with its own behavior.
+ * When a logging plugin is enabled, the built-in logging is disabled.
+ * plugins/logging/warn mimics the built-in logging.
+ * Multiple logging plugins can be enabled simultaneously.
+
+Read the POD within each logging plugin (perldoc plugins/logging/B<NAME>)
+to learn if it tickles your fancy.
+
+=head2 enabling plugins
+
+To enable logging plugins, edit the file I<config/logging> and uncomment the
+entries for the plugins you wish to use.
+
+=head2 logging level
+
+The 'master switch' for loglevel is I<config/loglevel>. Qpsmtpd and active
+plugins will output all messages that are less than or equal to the value
+specified. The log levels correspond to syslog levels:
+
+    LOGDEBUG   = 7
+    LOGINFO    = 6
+    LOGNOTICE  = 5
+    LOGWARN    = 4
+    LOGERROR   = 3
+    LOGCRIT    = 2
+    LOGALERT   = 1
+    LOGEMERG   = 0
+    LOGRADAR   = 0
+
+Level 6, LOGINFO, is the level at which most servers should start logging. At
+level 6, each plugin should log one and occasionally two entries that
+summarize their activity. Here's a few sample lines:
+
+ (connect) ident::geoip: SA, Saudi Arabia
+ (connect) ident::p0f: Windows 7 or 8
+ (connect) earlytalker: pass: remote host said nothing spontaneous
+ (data_post) domainkeys: skip: unsigned
+ (data_post) spamassassin: pass, Spam, 21.7 < 100
+ (data_post) dspam: fail: agree, Spam, 1.00 c
+ 552 we agree, no spam please (#5.6.1)
+
+Three plugins fired during the SMTP connection phase and 3 more ran during the
+data_post phase. Each plugin emitted one entry stating their findings.
+
+If you aren't processing the logs, you can save some disk I/O by reducing the
+loglevel, so that the only messages logged are ones that indicate a human
+should be taking some corrective action.
+
+=head2 log location
+
+If qpsmtpd is started using the distributed run file (cd ~smtpd; ./run), then
+you will see the log entries printed to your terminal. This solution works
+great for initial setup and testing and is the simplest case.
+
+A typical way to run qpsmtpd is as a supervised process with daemontools. If
+daemontools is already set up, setting up qpsmtpd may be as simple as:
+
+C<ln -s /usr/home/smtpd /var/service/>
+
+If svcscan is running, the symlink will be detected and tcpserver will
+run the 'run' files in the ./ and ./log directories. Any log entries
+emitted will get handled per the instructions in log/run. The default
+location specified in log/run is log/main/current.
+
+=head2 plugin loglevel
+
+Most plugins support a loglevel argument after their config/plugins entry.
+The value can be a whole number (N) or a relative number (+/-N), where
+N is a whole number from 0-7. See the descriptions of each below.
+
+C<ident/p0f loglevel 5>
+
+C<ident/p0f loglevel -1>
+
+ATTN plugin authors: To support loglevel in your plugin, you must store the
+loglevel settings from the plugins/config entry $self->{_args}{loglevel}. A
+simple and recommended example is as follows:
+
+ sub register {
+   my ( $self, $qp ) = shift, shift;
+   $self->log(LOGERROR, "Bad arguments") if @_ % 2;
+   $self->{_args} = { @_ };
+ }
+
+=head3 whole number
+
+If loglevel is a whole number, then all log activity in the plugin is logged
+at that level, regardless of the level the plugin author selected. This can
+be easily understood with a couple examples:
+
+The master loglevel is set at 6 (INFO). The mail admin sets a plugin loglevel
+to 7 (DEBUG). No messages from that plugin are emitted because DEBUG log
+entries are not <= 6 (INFO).
+
+The master loglevel is 6 (INFO) and the plugin loglevel is set to 5 or 6. All
+log entries will be logged because 5 is <= 6.
+
+This behavior is very useful to plugin authors. While testing and monitoring
+a plugin, they can set the level of their plugin to log everything. To return
+to 'normal' logging, they just update their config/plugins entry.
+
+=head3 relative
+
+Relative loglevel arguments adjust the loglevel of each logging call within
+a plugin. A value of I<loglevel +1> would make every logging entry one level
+less severe, where a value of I<loglevel -1> would make every logging entry
+one level more severe.
+
+For example, if a plugin has a loglevel setting of -1 and that same plugin
+logged a LOGDEBUG, it would instead be a LOGINFO message. Relative values
+makes it easy to control the verbosity and/or severity of individual plugins.
+
+=head1 qpsmtpd logging system; developer documentation
+
+Qpsmtpd now (as of 0.30-dev) supports a plugable logging architecture, so
+that different logging plugins can be supported.  See the example logging
+plugins in plugins/logging, specifically the L<plugins/logging/warn> and
+L<plugins/logging/adaptive> files for examples of how to write your own
+logging plugins.
+
+=head1 Internal support for pluggable logging
+
+Any code in the core can call C<$self->log()> and those log lines will be
+dispatched to each of the registered logging plugins.  When C<log()> is
+called from a plugin, the plugin and hook names are automatically included
+in the parameters passed the logging hooks.  All plugins which register for
+the logging hook should expect the following parameters to be passed:
+
+  $self, $transaction, $trace, $hook, $plugin, @log
+
+where those terms are:
+
+=over 4
+
+=item C<$self>
+
+The object which was used to call the log() method; this can be any object
+within the system, since the core code will automatically load logging
+plugins on behalf of any object.
+
+=item C<$transaction>
+
+This is the current SMTP transaction (defined as everything that happens
+between HELO/EHLO and QUIT/RSET).  If you want to defer outputting certain
+log lines, you can store them in the transaction object, but you will need
+to bind the C<reset_transaction> hook in order to retrieve that information
+before it is discarded when the transaction is closed (see the
+L<logging/adaptive> plugin for an example of doing this).
+
+=item C<$trace>
+
+This is the log level (as shown in config.sample/loglevel) that the caller
+asserted when calling log().  If you want to output the textural
+representation (e.g. C<LOGERROR>) of this in your log messages, you can use
+the log_level() function exported by Qpsmtpd::Constants (which is
+automatically available to all plugins).
+
+=item C<$hook>
+
+This is the hook that is currently being executed.  If log() is called by
+any core code (i.e. not as part of a hook), this term will be C<undef>.
+
+=item C<$plugin>
+
+This is the plugin name that executed the log().  Like C<$hook>, if part of
+the core code calls log(), this wil be C<undef>.  See L<logging/warn> for a
+way to prevent logging your own plugin's log entries from within that
+plugin (the system will not infinitely recurse in any case).
+
+=item C<@log>
+
+The remaining arguments are as passed by the caller, which may be a single
+term or may be a list of values.  It is usually sufficient to call
+C<join(" ",@log)> to deal with these terms, but it is possible that some
+plugin might pass additional arguments with signficance.
+
+=back
+
+Note: if you register a handler for certain hooks, e.g. C<deny>, there may
+be additional terms passed between C<$self> and C<$transaction>.  See
+L<logging/adaptive> for and example.
+

docs/plugins.pod

@@ -0,0 +1,401 @@
+#
+# This file is best read with ``perldoc plugins.pod''
+#
+
+### 
+# Conventions:
+#  plugin names:  F<myplugin>, F<qpsmtpd-async>
+#  constants:     I<LOGDEBUG>
+#  smtp commands, answers: B<HELO>, B<250 Queued!>
+#
+# Notes: 
+#  * due to restrictions of some POD parsers, no C<<$object->method()>>
+#    are allowed, use C<$object-E<gt>method()> 
+# 
+
+=head1 Introduction
+
+Plugins are the heart of qpsmtpd. The core implements only basic SMTP protocol
+functionality. No useful function can be done by qpsmtpd without loading 
+plugins.
+
+Plugins are loaded on startup where each of them register their interest in 
+various I<hooks> provided by the qpsmtpd core engine.
+
+At least one plugin B<must> allow or deny the B<RCPT> command to enable 
+receiving mail. The F<check_relay> plugin is the standard plugin for this.
+Other plugins provide extra functionality related to this; for example the
+F<require_resolvable_fromhost> plugin.
+
+=head2 Loading Plugins
+
+The list of plugins to load are configured in the I<config/plugins>
+configuration file. One plugin per line, empty lines and lines starting
+with I<#> are ignored. The order they are loaded is the same as given 
+in this config file. This is also the order the registered I<hooks>
+are run. The plugins are loaded from the F<plugins/> directory or 
+from a subdirectory of it. If a plugin should be loaded from such a 
+subdirectory, the directory must also be given, like the 
+F<virus/clamdscan> in the example below. Alternate plugin directories
+may be given in the F<config/plugin_dirs> config file, one directory
+per line, these will be searched first before using the builtin fallback
+of F<plugins/> relative to the qpsmtpd root directory. It may be 
+necessary, that the F<config/plugin_dirs> must be used (if you're using 
+F<Apache::Qpsmtpd>, for example).
+
+Some plugins may be configured by passing arguments in the F<plugins>
+config file.
+
+A plugin can be loaded two or more times with different arguments by adding
+I<:N> to the plugin filename, with I<N> being a number, usually starting at 
+I<0>. 
+
+Another method to load a plugin is to create a valid perl module, drop this
+module in perl's C<@INC> path and give the name of this module as
+plugin name. The only restriction to this is, that the module name B<must>
+contain I<::>, e.g. C<My::Plugin> would be ok, C<MyPlugin> not. Appending of
+I<:0>, I<:1>, ... does not work with module plugins.
+
+ check_relay
+ virus/clamdscan
+ spamassassin reject_threshold 7
+ my_rcpt_check example.com
+ my_rcpt_check:0 example.org
+ My::Plugin
+
+=head1 Anatomy of a plugin
+
+A plugin has at least one method, which inherits from the 
+C<Qpsmtpd::Plugin> object. The first argument for this method is always the 
+plugin object itself (and usually called C<$self>). The most simple plugin 
+has one method with a predefined name which just returns one constant.
+
+ # plugin temp_disable_connection
+ sub hook_connect {
+    return(DENYSOFT, "Sorry, server is temporarily unavailable.");
+ }
+
+While this is a valid plugin, it is not very useful except for rare 
+circumstances. So let us see what happens when a plugin is loaded.
+
+=head2 Initialisation
+
+After the plugin is loaded the C<init()> method of the plugin is called, 
+if present. The arguments passed to C<init()> are 
+
+=over 4
+
+=item $self 
+
+the current plugin object, usually called C<$self>
+
+=item $qp
+
+the Qpsmtpd object, usually called C<$qp>.
+
+=item @args
+
+the values following the plugin name in the F<plugins> config, split by 
+white space. These arguments can be used to configure the plugin with 
+default and/or static config settings, like database paths, 
+timeouts, ...
+
+=back
+
+This is mainly used for inheriting from other plugins, but may be used to do
+the same as in C<register()>.
+
+The next step is to register the hooks the plugin provides. Any method which 
+is named C<hook_$hookname> is automagically added.
+
+Plugins should be written using standard named hook subroutines. This 
+allows them to be overloaded and extended easily. Because some of the 
+callback names have characters invalid in subroutine names , they must be 
+translated. The current translation routine is C<s/\W/_/g;>, see 
+L</Hook - Subroutine translations> for more info. If you choose 
+not to use the default naming convention, you need to register the hooks in 
+your plugin in the C<register()> method (see below) with the 
+C<register_hook()> call on the plugin object.
+
+  sub register {
+    my ($self, $qp, @args) = @_;
+    $self->register_hook("mail", "mail_handler");
+    $self->register_hook("rcpt", "rcpt_handler");
+  }
+  sub mail_handler { ... }
+  sub rcpt_handler { ... }
+
+The C<register()> method is called last. It receives the same arguments as 
+C<init()>. There is no restriction, what you can do in C<register()>, but 
+creating database connections and reuse them later in the process may not be
+a good idea. This initialisation happens before any C<fork()> is done. 
+Therefore the file handle will be shared by all qpsmtpd processes and the 
+database will probably be confused if several different queries arrive on 
+the same file handle at the same time (and you may get the wrong answer, if
+any). This is also true for F<qpsmtpd-async> and the pperl flavours, but 
+not for F<qpsmtpd> started by (x)inetd or tcpserver. 
+
+In short: don't do it if you want to write portable plugins.
+
+=head2 Hook - Subroutine translations
+
+As mentioned above, the hook name needs to be translated to a valid perl
+C<sub> name. This is done like
+
+ ($sub = $hook) =~ s/\W/_/g;
+ $sub = "hook_$sub";
+
+Some examples follow, for a complete list of available (documented ;-))
+hooks (method names), use something like
+
+ $ perl -lne 'print if s/^=head2\s+(hook_\S+)/$1/' docs/plugins.pod
+
+All valid hooks are defined in F<lib/Qpsmtpd/Plugins.pm>, C<our @hooks>.
+
+=head3 Translation table
+
+ hook                          method
+ ----------                    ------------
+ config                        hook_config
+ queue                         hook_queue
+ data                          hook_data
+ data_post                     hook_data_post
+ quit                          hook_quit
+ rcpt                          hook_rcpt
+ mail                          hook_mail
+ ehlo                          hook_ehlo
+ helo                          hook_helo
+ auth                          hook_auth
+ auth-plain                    hook_auth_plain
+ auth-login                    hook_auth_login
+ auth-cram-md5                 hook_auth_cram_md5
+ connect                       hook_connect
+ reset_transaction             hook_reset_transaction
+ unrecognized_command          hook_unrecognized_command
+
+=head2 Inheritance
+
+Inheriting methods from other plugins is an advanced topic. You can alter 
+arguments for the underlying plugin, prepare something for the I<real> 
+plugin or skip a hook with this. Instead of modifying C<@ISA>
+directly in your plugin, use the C<isa_plugin()> method from the 
+C<init()> subroutine.
+
+  # rcpt_ok_child
+  sub init {
+    my ($self, $qp, @args) = @_;
+    $self->isa_plugin("rcpt_ok");
+  }
+
+  sub hook_rcpt {
+    my ($self, $transaction, $recipient) = @_;
+    # do something special here...
+    $self->SUPER::hook_rcpt($transaction, $recipient);
+  }
+
+See also chapter C<Changing return values> and 
+F<contrib/vetinari/rcpt_ok_maxrelay> in SVN.
+
+=head2 Config files
+
+Most of the existing plugins fetch their configuration data from files in the
+F<config/> sub directory. This data is read at runtime and may be changed
+without restarting qpsmtpd. 
+B<(FIXME: caching?!)>
+The contents of the files can be fetched via
+
+  @lines = $self->qp->config("my_config");
+
+All empty lines and lines starting with C<#> are ignored.
+
+If you don't want to read your data from files, but from a database you can 
+still use this syntax and write another plugin hooking the C<config>
+hook. 
+
+=head2 Logging
+
+Log messages can be written to the log file (or STDERR if you use the 
+F<logging/warn> plugin) with 
+
+  $self->log($loglevel, $logmessage);
+
+The log level is one of (from low to high priority)
+
+=over 4
+
+=item * 
+
+LOGDEBUG
+
+=item *
+
+LOGINFO
+
+=item *
+
+LOGNOTICE
+
+=item *
+
+LOGWARN
+
+=item *
+
+LOGERROR
+
+=item *
+
+LOGCRIT
+
+=item *
+
+LOGALERT
+
+=item *
+
+LOGEMERG
+
+=back
+
+While debugging your plugins, set your plugins loglevel to LOGDEBUG. This
+will log every logging statement within your plugin.
+
+For more information about logging, see F<docs/logging.pod>.
+
+=head2 Information about the current plugin
+
+Each plugin inherits the public methods from C<Qpsmtpd::Plugin>. 
+
+=over 4
+
+=item plugin_name()
+
+Returns the name of the currently running plugin
+
+=item hook_name()
+
+Returns the name of the running hook
+
+=item auth_user()
+
+Returns the name of the user the client is authed as (if authentication is 
+used, of course)
+
+=item auth_mechanism()
+
+Returns the auth mechanism if authentication is used
+
+=item connection()
+
+Returns the C<Qpsmtpd::Connection> object associated with the current 
+connection
+
+=item transaction()
+
+Returns the C<Qpsmtpd::Transaction> object associated with the current 
+transaction
+
+=back
+
+=head2 Temporary Files
+
+The temporary file and directory functions can be used for plugin specific 
+workfiles and will automatically be deleted at the end of the current 
+transaction.
+
+=over 4
+
+=item temp_file()
+
+Returns a unique name of a file located in the default spool directory, 
+but does not open that file (i.e. it is the name not a file handle).
+
+=item temp_dir()
+
+Returns the name of a unique directory located in the default spool 
+directory, after creating the directory with 0700 rights. If you need a 
+directory with different rights (say for an antivirus daemon), you will
+need to use the base function C<$self-E<gt>qp-E<gt>temp_dir()>, which takes a 
+single parameter for the permissions requested (see L<mkdir> for details). 
+A directory created like this will not be deleted when the transaction 
+is ended.
+
+=item spool_dir()
+
+Returns the configured system-wide spool directory.
+
+=back
+
+
+=head2 Connection and Transaction Notes
+
+Both may be used to share notes across plugins and/or hooks. The only real
+difference is their life time. The connection notes start when a new 
+connection is made and end, when the connection ends. This can, for example,
+be used to count the number of none SMTP commands. The plugin which uses 
+this is the F<count_unrecognized_commands> plugin from the qpsmtpd core
+distribution.
+
+The transaction note starts after the B<MAIL FROM: > command and are just 
+valid for the current transaction, see below in the I<reset_transaction>
+hook when the transaction ends.
+
+
+=head1 Return codes
+
+Each plugin must return an allowed constant for the hook and (usually)
+optionally a ``message'' for the client.
+Generally all plugins for a hook are processed until one returns 
+something other than I<DECLINED>.
+
+Plugins are run in the order they are listed in the F<plugins> 
+configuration file.
+
+The return constants are defined in C<Qpsmtpd::Constants> and have
+the following meanings:
+
+=over 4
+
+=item DECLINED
+
+Plugin declined work; proceed as usual. This return code is I<always allowed>
+unless noted otherwise.
+
+=item OK
+
+Action allowed.
+
+=item DENY
+
+Action denied.
+
+=item DENYSOFT
+
+Action denied; return a temporary rejection code (say B<450> instead 
+of B<550>).
+
+=item DENY_DISCONNECT
+
+Action denied; return a permanent rejection code and disconnect the client. 
+Use this for "rude" clients. Note that you're not supposed to do this 
+according to the SMTP specs, but bad clients don't listen sometimes.
+
+=item DENYSOFT_DISCONNECT
+
+Action denied; return a temporary rejection code and disconnect the client. 
+See note above about SMTP specs.
+
+=item DONE
+
+Finishing processing of the request. Usually used when the plugin sent the 
+response to the client.
+
+=item YIELD
+
+Only used in F<qpsmtpd-async>, see F<plugins/async/*> 
+
+=back
+
+=cut
+
+# vim: ts=2 sw=2 expandtab

docs/writing.pod

@@ -0,0 +1,271 @@
+#
+# This file is best read with ``perldoc writing.pod''
+#
+
+### 
+# Conventions:
+#  plugin names:  F<myplugin>, F<qpsmtpd-async>
+#  constants:     I<LOGDEBUG>
+#  smtp commands, answers: B<HELO>, B<250 Queued!>
+#
+# Notes: 
+#  * due to restrictions of some POD parsers, no C<<$object->method()>>
+#    are allowed, use C<$object-E<gt>method()> 
+# 
+
+=head1 Writing your own plugins
+
+This is a walk through a new queue plugin, which queues the mail to a (remote)
+QMQP-Server.
+
+First step is to pull in the necessary modules
+
+ use IO::Socket;
+ use Text::Netstring qw( netstring_encode 
+                         netstring_decode 
+                         netstring_verify 
+                         netstring_read );
+
+We know, we need a server to send the mails to. This will be the same 
+for every mail, so we can use arguments to the plugin to configure this 
+server (and port).
+
+Inserting this static config is done in C<register()>:
+
+  sub register {
+    my ($self, $qp, @args) = @_;
+
+    die "No QMQP server specified in qmqp-forward config"
+      unless @args;
+
+    $self->{_qmqp_timeout} = 120;
+
+    if ($args[0] =~ /^([\.\w_-]+)$/) {
+      $self->{_qmqp_server} = $1;
+    }
+    else {
+      die "Bad data in qmqp server: $args[0]";
+    }
+
+    $self->{_qmqp_port} = 628;
+    if (@args > 1 and $args[1] =~ /^(\d+)$/) {
+      $self->{_qmqp_port} = $1;
+    }
+
+    $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") 
+      if (@args > 2);
+  }
+
+We're going to write a queue plugin, so we need to hook to the I<queue>
+hook.
+
+  sub hook_queue {
+    my ($self, $transaction) = @_;
+
+    $self->log(LOGINFO, "forwarding to $self->{_qmqp_server}:"
+                       ."$self->{_qmqp_port}");
+
+The first step is to open a connection to the remote server.
+
+   my $sock = IO::Socket::INET->new(
+                 PeerAddr => $self->{_qmqp_server},
+                 PeerPort => $self->{_qmqp_port},
+                 Timeout  => $self->{_qmqp_timeout},
+                 Proto    => 'tcp')
+      or $self->log(LOGERROR, "Failed to connect to "
+                      ."$self->{_qmqp_server}:"
+                      ."$self->{_qmqp_port}: $!"),
+        return(DECLINED);
+    $sock->autoflush(1);
+
+=over 4
+
+=item *
+
+The client starts with a safe 8-bit text message. It encodes the message
+as the byte string C<firstline\012secondline\012 ... \012lastline>. (The
+last line is usually, but not necessarily, empty.) The client then encodes
+this byte string as a netstring. The client also encodes the envelope
+sender address as a netstring, and encodes each envelope recipient address
+as a netstring.
+
+The client concatenates all these netstrings, encodes the concatenation
+as a netstring, and sends the result.
+
+(from L<http://cr.yp.to/proto/qmqp.html>)
+
+=back
+
+The first idea is to build the package we send, in the order described
+in the paragraph above:
+
+  my $message = $transaction->header->as_string;
+  $transaction->body_resetpos;
+  while (my $line = $transaction->body_getline) {
+    $message .= $line;
+  }
+  $message  = netstring_encode($message);
+  $message .= netstring_encode($transaction->sender->address);
+  for ($transaction->recipients) {
+    push @rcpt, $_->address;
+  }
+  $message .= join "", netstring_encode(@rcpt);
+  print $sock netstring_encode($message)
+    or do {
+      my $err = $!;
+      $self->_disconnect($sock);
+      return(DECLINED, "Failed to print to socket: $err");
+    };
+
+This would mean, we have to hold the full message in memory... Not good 
+for large messages, and probably even slower (for large messages).
+
+Luckily it's easy to build a netstring without the help of the
+C<Text::Netstring> module if you know the size of the string (for more
+info about netstrings see L<http://cr.yp.to/proto/netstrings.txt>).
+
+We start with the sender and recipient addresses:
+
+  my ($addrs, $headers, @rcpt);
+  $addrs = netstring_encode($transaction->sender->address);
+  for ($transaction->recipients) {
+    push @rcpt, $_->address;
+  }
+  $addrs .= join "", netstring_encode(@rcpt);
+
+Ok, we got the sender and the recipients, now let's see what size the
+message is.
+
+  $headers   = $transaction->header->as_string;
+  my $msglen = length($headers) + $transaction->body_length;
+
+We've got everything we need. Now build the netstrings for the full package
+and the message.
+
+First the beginning of the netstring of the full package
+
+  # (+ 2: the ":" and "," of the message's netstring)
+  print $sock ($msglen + length($msglen) + 2 + length($addrs))
+               .":"
+               ."$msglen:$headers" ### beginning of messages netstring
+    or do { 
+      my $err = $!;
+      $self->_disconnect($sock);
+      return(DECLINED, 
+             "Failed to print to socket: $err");
+    };
+
+Go to beginning of the body
+
+  $transaction->body_resetpos;
+
+If the message is spooled to disk, read the message in
+blocks and write them to the server
+
+  if ($transaction->body_fh) {
+    my $buff;
+    my $size = read $transaction->body_fh, $buff, 4096;
+    unless (defined $size) {
+      my $err = $!;
+      $self->_disconnect($sock);
+      return(DECLINED, "Failed to read from body_fh: $err");
+    }
+    while ($size) {
+      print $sock $buff
+        or do { 
+          my $err = $!;
+          $self->_disconnect($sock);
+          return(DECLINED, "Failed to print to socket: $err");
+        };
+
+      $size = read $transaction->body_fh, $buff, 4096;
+      unless (defined $size) {
+        my $err = $!;
+        $self->_disconnect($sock);
+        return(DECLINED, 
+               "Failed to read from body_fh: $err");
+      }
+    }
+  }
+
+Else we have to read it line by line ...
+
+  else { 
+    while (my $line = $transaction->body_getline) {
+      print $sock $line
+        or do { 
+          my $err = $!;
+          $self->_disconnect($sock);
+          return(DECLINED, "Failed to print to socket: $err");
+        };
+    }
+  }
+
+Message is at the server, now finish the package.
+
+  print $sock ","    # end of messages netstring
+             .$addrs # sender + recpients
+             .","    # end of netstring of 
+                     #   the full package
+    or do { 
+      my $err = $!;
+      $self->_disconnect($sock);
+      return(DECLINED, 
+             "Failed to print to socket: $err");
+    };
+
+We're done. Now let's see what the remote qmqpd says...
+
+
+=over 4
+
+=item *
+
+(continued from L<http://cr.yp.to/proto/qmqp.html>:)
+
+The server's response is a nonempty string of 8-bit bytes, encoded as a
+netstring.
+
+The first byte of the string is either K, Z, or D. K means that the
+message has been accepted for delivery to all envelope recipients. This
+is morally equivalent to the 250 response to DATA in SMTP; it is subject
+to the reliability requirements of RFC 1123, section 5.3.3. Z means
+temporary failure; the client should try again later. D means permanent
+failure.
+
+Note that there is only one response for the entire message; the server
+cannot accept some recipients while rejecting others.
+
+=back
+
+
+    my $answer = netstring_read($sock);
+    $self->_disconnect($sock);
+
+    if (defined $answer and netstring_verify($answer)) {
+      $answer = netstring_decode($answer);
+
+      $answer =~ s/^K// and return(OK,
+                                 "Queued! $answer");
+      $answer =~ s/^Z// and return(DENYSOFT, 
+                                 "Deferred: $answer");
+      $answer =~ s/^D// and return(DENY,
+                                 "Denied: $answer");
+    }
+
+If this is the only F<queue/*> plugin, the client will get a 451 temp error:
+
+    return(DECLINED, "Protocol error");
+  }
+
+  sub _disconnect {
+    my ($self,$sock) = @_;
+    if (defined $sock) {
+      eval { close $sock; };
+      undef $sock;
+    }
+  }
+
+=cut
+
+# vim: ts=2 sw=2 expandtab

lib/Apache/Qpsmtpd.pm

@@ -0,0 +1,246 @@
+package Apache::Qpsmtpd;
+
+use 5.006001;
+use strict;
+use warnings FATAL => 'all';
+
+use Apache2::ServerUtil ();
+use Apache2::Connection ();
+use Apache2::Const -compile => qw(OK MODE_GETLINE);
+use APR::Const -compile => qw(SO_NONBLOCK EOF SUCCESS);
+use APR::Error ();
+use APR::Brigade ();
+use APR::Bucket ();
+use APR::Socket ();
+use Apache2::Filter ();
+use ModPerl::Util ();
+
+our $VERSION = '0.02';
+
+sub handler {
+    my Apache2::Connection $c = shift;
+    $c->client_socket->opt_set(APR::Const::SO_NONBLOCK => 0);
+
+    die "\$ENV{QPSMTPD_CONFIG} must be given" unless $ENV{QPSMTPD_CONFIG};
+    
+    my $qpsmtpd = Qpsmtpd::Apache->new();
+    $qpsmtpd->start_connection(
+        ip => $c->remote_ip,
+        host => $c->remote_host,
+        info => undef,
+        conn => $c,
+    );
+    
+    $qpsmtpd->run($c);
+    $qpsmtpd->run_hooks("post-connection");
+    $qpsmtpd->connection->reset;
+
+    return Apache2::Const::OK;
+}
+
+package Qpsmtpd::Apache;
+
+use Qpsmtpd::Constants;
+use base qw(Qpsmtpd::SMTP);
+
+my %cdir_memo;
+
+sub config_dir {
+  my ($self, $config) = @_;
+  if (exists $cdir_memo{$config}) {
+      return $cdir_memo{$config};
+  }
+
+  if (uc($ENV{QPSMTPD_CONFIG}) eq 'USE-VIRTUAL-DOMAINS') {
+      my $cdir = $self->{conn}->base_server->dir_config("qpsmtpd.config_dir");
+      $cdir =~ /^(.*)$/; # detaint
+      my $configdir = $1 if -e "$1/$config";
+      $cdir_memo{$config} = $configdir;
+  } else {
+      $cdir_memo{$config} = $self->SUPER::config_dir(@_);
+  }
+  return $cdir_memo{$config};
+}
+
+sub start_connection {
+    my $self = shift;
+    my %opts = @_;
+
+    $self->{conn} = $opts{conn};
+    $self->{conn}->client_socket->timeout_set($self->config('timeout') * 1_000_000);
+    $self->{bb_in} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
+    $self->{bb_out} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
+
+    my $remote_host = $opts{host} || ( $opts{ip} ? "[$opts{ip}]" : "[noip!]");
+    my $remote_info = $opts{info} ? "$opts{info}\@$remote_host" : $remote_host;
+    my $remote_ip = $opts{ip};
+
+    $self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]");
+
+    $self->SUPER::connection->start(
+        remote_info => $remote_info,
+        remote_ip   => $remote_ip,
+        remote_host => $remote_host,
+        local_ip    => $opts{conn}->local_ip,
+        @_
+    );
+}
+
+sub config {
+    my $self = shift;
+    my ($param, $type) = @_;
+    if (!$type) {
+        my $opt = $self->{conn}->base_server->dir_config("qpsmtpd.$param");
+        return $opt if defined($opt);
+    }
+    return $self->SUPER::config(@_);
+}
+
+sub run {
+    my $self = shift;
+
+    # should be somewhere in Qpsmtpd.pm and not here...
+    $self->load_plugins;
+
+    my $rc = $self->start_conversation;
+    return if $rc != DONE;
+
+    # this should really be the loop and read_input should just
+    # get one line; I think
+    $self->read_input();
+}
+
+sub getline {
+    my $self = shift;
+    my $c = $self->{conn} || die "Cannot getline without a conn";
+
+    return if $c->aborted;
+
+    my $bb = $self->{bb_in};
+    
+    while (1) {
+        my $rc = $c->input_filters->get_brigade($bb, Apache2::Const::MODE_GETLINE);
+        return if $rc == APR::Const::EOF;
+        die APR::Error::strerror($rc) unless $rc == APR::Const::SUCCESS;
+        
+        next unless $bb->flatten(my $data);
+        
+        $bb->cleanup;
+        return $data;
+    }
+    
+    return '';
+}
+
+sub read_input {
+    my $self = shift;
+    my $c = $self->{conn};
+
+    while (defined(my $data = $self->getline)) {
+        $data =~ s/\r?\n$//s; # advanced chomp
+        $self->connection->notes('original_string', $data);
+        $self->log(LOGDEBUG, "dispatching $data");
+        defined $self->dispatch(split / +/, $data, 2)
+            or $self->respond(502, "command unrecognized: '$data'");
+        last if $self->{_quitting};
+    }
+}
+
+sub respond {
+    my ($self, $code, @messages) = @_;
+    my $c = $self->{conn};
+    while (my $msg = shift @messages) {
+        my $bb = $self->{bb_out};
+        my $line = $code . (@messages?"-":" ").$msg;
+        $self->log(LOGDEBUG, $line);
+        my $bucket = APR::Bucket->new(($c->bucket_alloc), "$line\r\n");
+        $bb->insert_tail($bucket);
+        $c->output_filters->fflush($bb);
+        # $bucket->remove;
+        $bb->cleanup;
+    }
+    return 1;
+}
+
+sub disconnect {
+    my $self = shift;
+    $self->SUPER::disconnect(@_);
+    $self->{_quitting} = 1;
+    $self->{conn}->client_socket->close();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Apache::Qpsmtpd - a mod_perl-2 connection handler for qpsmtpd
+
+=head1 SYNOPSIS
+
+  Listen 0.0.0.0:25 smtp
+  AcceptFilter smtp none
+  ## "smtp" and the AcceptFilter are required for Linux, FreeBSD 
+  ## with apache >= 2.1.5, for others it doesn't hurt. See also
+  ## http://httpd.apache.org/docs/2.2/mod/core.html#acceptfilter
+  ## and http://httpd.apache.org/docs/2.2/mod/mpm_common.html#listen
+
+  LoadModule perl_module modules/mod_perl.so
+
+  <Perl>
+  use lib qw( /path/to/qpsmtpd/lib );
+  use Apache::Qpsmtpd;
+  $ENV{QPSMTPD_CONFIG} = "/path/to/qpsmtpd/config";
+  </Perl>
+
+  <VirtualHost _default_:25>
+  PerlModule Apache::Qpsmtpd
+  PerlProcessConnectionHandler Apache::Qpsmtpd
+  # can specify this in config/plugin_dirs if you wish:
+  PerlSetVar qpsmtpd.plugin_dirs /path/to/qpsmtpd/plugins
+  PerlSetVar qpsmtpd.loglevel 4
+  </VirtualHost>
+
+Using multiple instances of Qpsmtpd on the same server is also
+possible by setting:
+
+  $ENV{QPSMTPD_CONFIG} = "USE-VIRTUAL-DOMAINS";
+
+Then in the VirtualHost of each config define the configuration
+directory:
+
+  PerlSetVar qpsmtpd.config_dir /path/to/qpsmtpd/config
+
+Several different configurations can be running on the same
+server.
+
+=head1 DESCRIPTION
+
+This module implements a mod_perl/apache 2.0 connection handler
+that turns Apache into an SMTP server using Qpsmtpd.
+
+It also allows you to set single-valued config options (such
+as I<loglevel>, as seen above) using C<PerlSetVar> in F<httpd.conf>.
+
+This module should be considered beta software as it is not yet
+widely tested. However it is currently the fastest way to run
+Qpsmtpd, so if performance is important to you then consider this
+module.
+
+=head1 BUGS
+
+Probably a few. Make sure you test your plugins carefully.
+
+The Apache scoreboard (/server-status/) mostly works and shows
+connections, but could do with some enhancements specific to SMTP.
+
+=head1 AUTHOR
+
+Matt Sergeant, <matt@sergeant.org>
+
+Some credit goes to <mock@obscurity.org> for Apache::SMTP which gave
+me the inspiration to do this.  <peter@boku.net> added the virtual
+host support.
+
+=cut

lib/Danga/Client.pm

@@ -0,0 +1,221 @@
+# $Id: Client.pm,v 1.8 2005/02/14 22:06:38 msergeant Exp $
+
+package Danga::Client;
+use base 'Danga::TimeoutSocket';
+use fields qw(
+    line
+    pause_count
+    read_bytes
+    data_bytes
+    callback
+    get_chunks
+    reader_object
+    );
+use Time::HiRes ();
+
+use bytes;
+
+# 30 seconds max timeout!
+sub max_idle_time       { 30 }
+sub max_connect_time    { 1200 }
+
+sub new {
+    my Danga::Client $self = shift;
+    $self = fields::new($self) unless ref $self;
+    $self->SUPER::new( @_ );
+
+    $self->reset_for_next_message;
+    return $self;
+}
+
+sub reset_for_next_message {
+    my Danga::Client $self = shift;
+    $self->{line} = '';
+    $self->{pause_count} = 0;
+    $self->{read_bytes} = 0;
+    $self->{callback} = undef;
+    $self->{reader_object} = undef;
+    $self->{data_bytes} = '';
+    $self->{get_chunks} = 0;
+    return $self;
+}
+
+sub get_bytes {
+    my Danga::Client $self = shift;
+    my ($bytes, $callback) = @_;
+    if ($self->{callback}) {
+        die "get_bytes/get_chunks currently in progress!";
+    }
+    $self->{read_bytes} = $bytes;
+    $self->{data_bytes} = $self->{line};
+    $self->{read_bytes} -= length($self->{data_bytes});
+    $self->{line} = '';
+    if ($self->{read_bytes} <= 0) {
+        if ($self->{read_bytes} < 0) {
+            $self->{line} = substr($self->{data_bytes},
+                                   $self->{read_bytes}, # negative offset
+                                   0 - $self->{read_bytes}, # to end of str
+                                   ""); # truncate that substr
+        }
+        $callback->($self->{data_bytes});
+        return;
+    }
+    $self->{callback} = $callback;
+}
+
+sub process_chunk {
+    my Danga::Client $self = shift;
+    my $callback = shift;
+
+    my $last_crlf = rindex($self->{line}, "\r\n");
+
+    if ($last_crlf != -1) {
+        if ($last_crlf + 2 == length($self->{line})) {
+            my $data = $self->{line};
+            $self->{line} = '';
+            $callback->($data);
+        }
+        else {
+            my $data = substr($self->{line}, 0, $last_crlf + 2);
+            $self->{line} = substr($self->{line}, $last_crlf + 2);
+            $callback->($data);
+        }
+    }
+}
+
+sub get_chunks {
+    my Danga::Client $self = shift;
+    my ($bytes, $callback) = @_;
+    if ($self->{callback}) {
+        die "get_bytes/get_chunks currently in progress!";
+    }
+    $self->{read_bytes} = $bytes;
+    $self->process_chunk($callback) if length($self->{line});
+    $self->{callback} = $callback;
+    $self->{get_chunks} = 1;
+}
+
+sub end_get_chunks {
+    my Danga::Client $self = shift;
+    my $remaining = shift;
+    $self->{callback} = undef;
+    $self->{get_chunks} = 0;
+    if (defined($remaining)) {
+        $self->process_read_buf(\$remaining);
+    }
+}
+
+sub set_reader_object {
+    my Danga::Client $self = shift;
+    $self->{reader_object} = shift;
+}
+
+sub event_read {
+    my Danga::Client $self = shift;
+    if (my $obj = $self->{reader_object}) {
+        $self->{reader_object} = undef;
+        $obj->event_read($self);
+    }
+    elsif ($self->{callback}) {
+        $self->{alive_time} = time;
+        if ($self->{get_chunks}) {
+            my $bref = $self->read($self->{read_bytes});
+            return $self->close($!) unless defined $bref;
+            $self->{line} .= $$bref;
+            $self->process_chunk($self->{callback}) if length($self->{line});
+            return;
+        }
+        if ($self->{read_bytes} > 0) {
+            my $bref = $self->read($self->{read_bytes});
+            return $self->close($!) unless defined $bref;
+            $self->{read_bytes} -= length($$bref);
+            $self->{data_bytes} .= $$bref;
+        }
+        if ($self->{read_bytes} <= 0) {
+            # print "Erk, read too much!\n" if $self->{read_bytes} < 0;
+            my $cb = $self->{callback};
+            $self->{callback} = undef;
+            $cb->($self->{data_bytes});
+        }
+    }
+    else {
+        my $bref = $self->read(8192);
+        return $self->close($!) unless defined $bref;
+        $self->process_read_buf($bref);
+    }
+}
+
+sub process_read_buf {
+    my Danga::Client $self = shift;
+    my $bref = shift;
+    $self->{line} .= $$bref;
+    return if $self->{pause_count} || $self->{closed};
+    
+    if ($self->{line} =~ s/^(.*?\n)//) {
+        my $line = $1;
+        $self->{alive_time} = time;
+        my $resp = $self->process_line($line);
+        if ($::DEBUG > 1 and $resp) { print "$$:".($self+0)."S: $_\n" for split(/\n/, $resp) }
+        $self->write($resp) if $resp;
+        # $self->watch_read(0) if $self->{pause_count};
+        return if $self->{pause_count} || $self->{closed};
+        # read more in a timer, to give other clients a look in
+        $self->AddTimer(0, sub {
+            if (length($self->{line}) && !$self->paused) {
+                $self->process_read_buf(\""); # " for bad syntax highlighters
+            }
+        });
+    }
+}
+
+sub has_data {
+    my Danga::Client $self = shift;
+    return length($self->{line}) ? 1 : 0;
+}
+
+sub clear_data {
+    my Danga::Client $self = shift;
+    $self->{line} = '';
+}
+
+sub paused {
+    my Danga::Client $self = shift;
+    return 1 if $self->{pause_count};
+    return 1 if $self->{closed};
+    return 0;
+}
+
+sub pause_read {
+    my Danga::Client $self = shift;
+    $self->{pause_count}++;
+    # $self->watch_read(0);
+}
+
+sub continue_read {
+    my Danga::Client $self = shift;
+    $self->{pause_count}--;
+    if ($self->{pause_count} <= 0) {
+        $self->{pause_count} = 0;
+        $self->AddTimer(0, sub {
+            if (length($self->{line}) && !$self->paused) {
+                $self->process_read_buf(\""); # " for bad syntax highlighters
+            }
+        });
+    }
+}
+
+sub process_line {
+    my Danga::Client $self = shift;
+    return '';
+}
+
+sub close {
+    my Danga::Client $self = shift;
+    print "closing @_\n" if $::DEBUG;
+    $self->SUPER::close(@_);
+}
+
+sub event_err { my Danga::Client $self = shift; $self->close("Error") }
+sub event_hup { my Danga::Client $self = shift; $self->close("Disconnect (HUP)") }
+
+1;

lib/Danga/TimeoutSocket.pm

@@ -0,0 +1,67 @@
+# $Id: TimeoutSocket.pm,v 1.2 2005/02/02 20:44:35 msergeant Exp $
+
+package Danga::TimeoutSocket;
+
+use base 'Danga::Socket';
+use fields qw(alive_time create_time);
+
+our $last_cleanup = 0;
+
+Danga::Socket->AddTimer(15, \&_do_cleanup);
+
+sub new {
+    my Danga::TimeoutSocket $self = shift;
+    my $sock = shift;
+    $self = fields::new($self) unless ref($self);
+    $self->SUPER::new($sock);
+
+    my $now = time;
+    $self->{alive_time} = $self->{create_time} = $now;
+
+    return $self;
+}
+
+# overload these in a subclass
+sub max_idle_time       { 0 }
+sub max_connect_time    { 0 }
+
+sub Reset {
+    Danga::Socket->Reset;
+    Danga::Socket->AddTimer(15, \&_do_cleanup);
+}
+
+sub _do_cleanup {
+    my $now = time;
+    
+    Danga::Socket->AddTimer(15, \&_do_cleanup);
+    
+    my $sf = __PACKAGE__->get_sock_ref;
+
+    my %max_age;  # classname -> max age (0 means forever)
+    my %max_connect; # classname -> max connect time
+    my @to_close;
+    while (my $k = each %$sf) {
+        my Danga::TimeoutSocket $v = $sf->{$k};
+        my $ref = ref $v;
+        next unless $v->isa('Danga::TimeoutSocket');
+        unless (defined $max_age{$ref}) {
+            $max_age{$ref}      = $ref->max_idle_time || 0;
+            $max_connect{$ref}  = $ref->max_connect_time || 0;
+        }
+        if (my $t = $max_connect{$ref}) {
+            if ($v->{create_time} < $now - $t) {
+                push @to_close, $v;
+                next;
+            }
+        }
+        if (my $t = $max_age{$ref}) {
+            if ($v->{alive_time} < $now - $t) {
+                push @to_close, $v;
+            }
+        }
+    }
+
+    $_->close("Timeout") foreach @to_close;
+}
+
+1;

lib/Qpsmtpd.pm

@@ -0,0 +1,630 @@
+package Qpsmtpd;
+use strict;
+use vars qw($VERSION $TraceLevel $Spool_dir $Size_threshold);
+
+use Sys::Hostname;
+use Qpsmtpd::Constants;
+
+#use DashProfiler;
+
+$VERSION = "0.84";
+
+my $git;
+
+if (-e ".git") {
+    local $ENV{PATH} = "/usr/bin:/usr/local/bin:/opt/local/bin/";
+    $git = `git describe`;
+    $git && chomp $git;
+}
+
+my $hooks = {};
+my %defaults = (
+		  me      => hostname,
+		  timeout => 1200,
+		  );
+my $_config_cache = {};
+my %config_dir_memo;
+
+#DashProfiler->add_profile("qpsmtpd");
+#my $SAMPLER = DashProfiler->prepare("qpsmtpd");
+my $LOGGING_LOADED = 0;
+
+sub _restart {
+  my $self = shift;
+  my %args = @_;
+  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;
+  }
+}
+
+
+sub DESTROY {
+    #warn $_ for DashProfiler->profile_as_text("qpsmtpd");
+}
+
+sub version { $VERSION . ($git ? "/$git" : "") };
+
+sub TRACE_LEVEL { $TraceLevel }; # leave for plugin compatibility
+
+
+sub hooks { $hooks; }
+
+sub load_logging {
+  # need to do this differently than other plugins so as to
+  # not trigger logging activity
+  return if $LOGGING_LOADED;
+  my $self = shift;
+  return if $hooks->{"logging"};
+  my $configdir = $self->config_dir("logging");
+  my $configfile = "$configdir/logging";
+  my @loggers = $self->_config_from_file($configfile,'logging');
+
+  $configdir = $self->config_dir('plugin_dirs');
+  $configfile = "$configdir/plugin_dirs";
+  my @plugin_dirs = $self->_config_from_file($configfile,'plugin_dirs');
+  unless (@plugin_dirs) {
+    my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
+    @plugin_dirs = ( "$name/plugins" );
+  }
+
+  my @loaded;
+  for my $logger (@loggers) {
+    push @loaded, $self->_load_plugin($logger, @plugin_dirs);
+  }
+
+  foreach my $logger (@loaded) {
+    $self->log(LOGINFO, "Loaded $logger");
+  }
+
+  $configdir = $self->config_dir("loglevel");
+  $configfile = "$configdir/loglevel";
+  $TraceLevel = $self->_config_from_file($configfile,'loglevel');
+
+  unless (defined($TraceLevel) and $TraceLevel =~ /^\d+$/) {
+    $TraceLevel = LOGWARN; # Default if no loglevel file found.
+  }
+
+  $LOGGING_LOADED = 1;
+
+  return @loggers;
+}
+
+sub trace_level {
+  my $self = shift;
+  return $TraceLevel;
+}
+
+sub init_logger { # needed for compatibility purposes
+  shift->trace_level();
+}
+
+sub log {
+  my ($self, $trace, @log) = @_;
+  $self->varlog($trace,join(" ",@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) = @_;
+  }
+
+  $self->load_logging; # in case we don't have this loaded yet
+
+    my ($rc) = $self->run_hooks_no_respond("logging", $trace, $hook, $plugin, @log)
+        or return;
+
+    return if $rc == DECLINED || $rc == OK;  # plugin success
+    return if $trace > $TraceLevel;
+
+    # no logging plugins registered, fall back to STDERR
+    my $prefix = defined $plugin && defined $hook ? " ($hook) $plugin:" :
+                 defined $plugin ? " $plugin:" :
+                 defined $hook   ? " ($hook) running plugin:" : '';
+
+    warn join(' ', $$ . $prefix, @log), "\n";
+}
+
+sub clear_config_cache {
+    $_config_cache = {};
+}
+
+#
+# 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 try the cache 
+  # XXX - is this always the right thing to do? what if a config hook
+  # can return different values on subsequent calls?
+  if ($_config_cache->{$c}) {
+      $self->log(LOGDEBUG, "config($c) returning (@{$_config_cache->{$c}}) from cache");
+      return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
+  }
+
+  # then run the hooks
+  my ($rc, @config) = $self->run_hooks_no_respond("config", $c);
+  $self->log(LOGDEBUG, "config($c): hook returned ($rc, @config) ");
+  if ($rc == OK) {
+      $self->log(LOGDEBUG, "setting _config_cache for $c to [@config] from hooks and returning it");
+      $_config_cache->{$c} = \@config;
+      return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
+  }
+
+  # and then get_qmail_config
+  @config = $self->get_qmail_config($c, $type);
+  if (@config) {
+      $self->log(LOGDEBUG, "setting _config_cache for $c to [@config] from get_qmail_config and returning it");
+      $_config_cache->{$c} = \@config;
+      return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
+  }
+
+  # finally we use the default if there is any:
+  if (exists($defaults{$c})) {
+      $self->log(LOGDEBUG, "setting _config_cache for $c to @{[$defaults{$c}]} from defaults and returning it");
+      $_config_cache->{$c} = [$defaults{$c}];
+      return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
+  }
+  return;
+}
+
+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;
+}
+
+sub plugin_dirs {
+    my $self = shift;
+    my @plugin_dirs = $self->config('plugin_dirs');
+
+    unless (@plugin_dirs) {
+        my ($path) = ($ENV{PROCESS} ? $ENV{PROCESS} : $0) =~ m!(.*?)/([^/]+)$!;
+        @plugin_dirs = ( "$path/plugins" );
+    }
+    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")  {
+    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->_config_from_file($configfile, $config);
+}
+
+sub _config_from_file {
+  my ($self, $configfile, $config, $visited) = @_;
+  unless (-e $configfile) {
+      $_config_cache->{$config} ||= [];
+      return;
+  }
+
+  $visited ||= [];
+  push @{$visited}, $configfile;
+
+  open CF, "<$configfile" or warn "$$ could not open configfile $configfile: $!" and 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;
+
+  my @plugins = $self->config('plugins');
+  my @loaded;
+
+  if ($hooks->{queue}) {
+    #$self->log(LOGWARN, "Plugins already loaded");
+    return @plugins;
+  }
+
+  for my $plugin_line (@plugins) {
+    my $this_plugin = $self->_load_plugin($plugin_line, $self->plugin_dirs);
+    push @loaded, $this_plugin if $this_plugin;
+  }
+
+  return @loaded;
+}
+
+sub _load_plugin {
+  my $self = shift;
+  my ($plugin_line, @plugin_dirs) = @_;
+
+  my ($plugin, @args) = split ' ', $plugin_line;
+
+  my $package;
+
+  if ($plugin =~ m/::/) {
+    # "full" package plugin (My::Plugin)
+    $package = $plugin;
+    $package =~ s/[^_a-z0-9:]+//gi;
+    my $eval = qq[require $package;\n]
+              .qq[sub ${plugin}::plugin_name { '$plugin' }];
+    $eval =~ m/(.*)/s;
+    $eval = $1;
+    eval $eval;
+    die "Failed loading $package - eval $@" if $@;
+    $self->log(LOGDEBUG, "Loading $package ($plugin_line)")
+      unless $plugin_line =~ /logging/;
+  }
+  else {
+    # regular plugins/$plugin plugin
+    my $plugin_name = $plugin;
+    $plugin =~ s/:\d+$//;       # after this point, only used for filename
+
+    # Escape everything into valid perl identifiers
+    $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;
+
+    # second pass cares for slashes and words starting with a digit
+    $plugin_name =~ s{
+        (/+)       # directory
+        (\d?)      # package's first character
+       }[
+         "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
+        ]egx;
+
+    $package = "Qpsmtpd::Plugin::$plugin_name";
+
+    # don't reload plugins if they are already loaded
+    unless ( defined &{"${package}::plugin_name"} ) {
+      PLUGIN_DIR: for my $dir (@plugin_dirs) {
+        if (-e "$dir/$plugin") {
+          Qpsmtpd::Plugin->compile($plugin_name, $package,
+            "$dir/$plugin", $self->{_test_mode}, $plugin);
+          $self->log(LOGDEBUG, "Loading $plugin_line from $dir/$plugin")
+            unless $plugin_line =~ /logging/;
+          last PLUGIN_DIR;
+        }
+      }
+      die "Plugin $plugin_name not found in our plugin dirs (",
+      	  join(", ", @plugin_dirs),")"
+        unless defined &{"${package}::plugin_name"};
+    }
+  }
+
+  my $plug = $package->new();
+  $plug->_register($self, @args);
+
+  return $plug;
+}
+
+sub transaction { return {}; } # base class implements empty transaction
+
+sub run_hooks {
+  my ($self, $hook) = (shift, shift);
+  if ($hooks->{$hook}) {
+    my @r;
+    my @local_hooks = @{$hooks->{$hook}};
+    $self->{_continuation} = [$hook, [@_], @local_hooks];
+    return $self->run_continuation();
+  }
+  return $self->hook_responder($hook, [0, ''], [@_]);
+}
+
+sub run_hooks_no_respond {
+    my ($self, $hook) = (shift, shift);
+    if ($hooks->{$hook}) {
+        my @r;
+        for my $code (@{$hooks->{$hook}}) {
+            eval { (@r) = $code->{code}->($self, $self->transaction, @_); };
+            $@ and warn("FATAL PLUGIN ERROR [" . $code->{name} . "]: ", $@) and next;
+            if ($r[0] == YIELD) {
+                die "YIELD not valid from $hook hook";
+            }
+            last unless $r[0] == DECLINED;
+        }
+        $r[0] = DECLINED if not defined $r[0];
+        return @r;
+    }
+    return (0, '');
+}
+
+sub continue_read {} # subclassed in -async
+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};
+  $self->{_continuation} = undef;
+  my $hook = shift @$todo || die "No hook in the continuation";
+  my $args = shift @$todo || die "No hook args in the continuation";
+  my @r;
+  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;
+
+    !defined $r[0]
+        and $self->log(LOGERROR, "plugin ".$code->{name}
+                       ." running the $hook hook returned undef!")
+        and next;
+
+    # note this is wrong as $tran is always true in the
+    # current code...
+    if ($tran) {
+      my $tnotes = $tran->notes( $code->{name} );
+      $tnotes->{"hook_$hook"}->{'return'} = $r[0]
+        if (!defined $tnotes || ref $tnotes eq "HASH");
+    }
+    else {
+      my $cnotes = $self->connection->notes( $code->{name} );
+      $cnotes->{"hook_$hook"}->{'return'} = $r[0]
+        if (!defined $cnotes || ref $cnotes eq "HASH");
+    }
+
+    if ($r[0] == YIELD) {
+      $self->pause_read();
+      $self->{_continuation} = [$hook, $args, @$todo];
+      return @r;
+    }
+    elsif ($r[0] == DENY or $r[0] == DENYSOFT or
+          $r[0] == DENY_DISCONNECT or $r[0] == DENYSOFT_DISCONNECT)
+    {
+      $r[1] = "" if not defined $r[1];
+      $self->log(LOGDEBUG, "Plugin ".$code->{name}.
+	    ", hook $hook returned ".return_code($r[0]).", $r[1]");
+      $self->run_hooks_no_respond("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny");
+    }
+    else {
+      $r[1] = "" if not defined $r[1];
+      $self->log(LOGDEBUG, "Plugin ".$code->{name}.
+	    ", hook $hook returned ".return_code($r[0]).", $r[1]");
+      $self->run_hooks_no_respond("ok", $code->{name}, $r[0], $r[1]) unless ($hook eq "ok");
+    }
+
+    last unless $r[0] == DECLINED;
+  }
+  $r[0] = DECLINED if not defined $r[0];
+  # hook_*_parse() may return a CODE ref..
+  # ... which breaks when splitting as string:
+  @r = map { split /\n/ } @r unless (ref($r[1]) eq "CODE");
+  return $self->hook_responder($hook, \@r, $args);
+}
+
+sub hook_responder {
+  my ($self, $hook, $msg, $args) = @_;
+
+  #my $t1 = $SAMPLER->("hook_responder", undef, 1);
+  my $code = shift @$msg;
+
+  my $responder = $hook . '_respond';
+  if (my $meth = $self->can($responder)) {
+    return $meth->($self, $code, $msg, $args);
+  }
+  return $code, @$msg;
+}
+
+sub _register_hook {
+  my $self = shift;
+  my ($hook, $code, $unshift) = @_;
+
+  if ($unshift) {
+    unshift @{$hooks->{$hook}}, $code;
+  }
+  else {
+    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/');
+
+    $Spool_dir .= "/" unless ($Spool_dir =~ m!/$!);
+
+    $Spool_dir =~ /^(.+)$/ or die "spool_dir not configured properly";
+    $Spool_dir = $1; # cleanse the taint
+    my $Spool_perms = $self->config('spool_perms') || '0700';
+
+    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: $!";
+    };
+    # Make sure the spool dir has appropriate rights
+    $self->log(LOGWARN,
+       "Permissions on spool_dir $Spool_dir are not $Spool_perms")
+         unless ((stat $Spool_dir)[2] & 07777) == oct($Spool_perms);
+  }
+
+  return $Spool_dir;
+}
+
+# For unique filenames. We write to a local tmp dir so we don't need
+# to make them unpredictable.
+my $transaction_counter = 0;
+
+sub temp_file {
+  my $self = shift;
+  my $filename = $self->spool_dir()
+    . join(":", time, $$, $transaction_counter++);
+  return $filename;
+}
+
+sub temp_dir {
+  my $self = shift;
+  my $mask = shift || 0700;
+  my $dirname = $self->temp_file();
+  -d $dirname or 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(LOGNOTICE, "size_threshold set to $Size_threshold");
+  }
+  return $Size_threshold;
+}
+
+sub authenticated {
+  my $self = shift;
+  return (defined $self->{_auth} ? $self->{_auth} : "" );
+}
+
+sub auth_user {
+  my $self = shift;
+  return (defined $self->{_auth_user} ? $self->{_auth_user} : "" );
+}
+
+sub auth_mechanism {
+  my $self = shift;
+  return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Qpsmtpd - base class for the qpsmtpd mail server
+
+=head1 DESCRIPTION
+
+This is the base class for the qpsmtpd mail server.  See
+L<http://smtpd.develooper.com/> and the I<README> file for more information.
+
+=head1 COPYRIGHT
+
+Copyright 2001-2012 Ask Bjørn Hansen, Develooper LLC.  See the
+LICENSE file for more information.
+
+=cut
+

lib/Qpsmtpd/Address.pm

@@ -0,0 +1,362 @@
+#!/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, $user, $host) = @_;
+    my $self = {};
+    if ($user =~ /^<(.*)>$/ ) {
+	($user, $host) = $class->canonify($user);
+	return undef unless defined $user;
+    }
+    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:
+#
+#   Path = "<" [ A-d-l ":" ] Mailbox ">"
+#
+#   A-d-l = At-domain *( "," A-d-l )
+#       ; Note that this form, the so-called "source route",
+#       ; MUST BE accepted, SHOULD NOT be generated, and SHOULD be
+#       ; ignored.
+#
+#   At-domain = "@" domain
+#
+#   Mailbox = Local-part "@" Domain
+# 
+#   Local-part = Dot-string / Quoted-string
+#       ; MAY be case-sensitive
+# 
+#   Dot-string = Atom *("." Atom)
+# 
+#   Atom = 1*atext
+# 
+#   Quoted-string = DQUOTE *qcontent DQUOTE
+# 
+#   Domain = (sub-domain 1*("." sub-domain)) / address-literal
+#   sub-domain = Let-dig [Ldh-str]
+# 
+#   address-literal = "[" IPv4-address-literal /
+#                     IPv6-address-literal /
+#                     General-address-literal "]"
+# 
+#   IPv4-address-literal = Snum 3("." Snum)
+#   IPv6-address-literal = "IPv6:" IPv6-addr
+#   General-address-literal = Standardized-tag ":" 1*dcontent
+#   Standardized-tag = Ldh-str
+#         ; MUST be specified in a standards-track RFC
+#         ; and registered with IANA
+# 
+#   Snum = 1*3DIGIT  ; representing a decimal integer
+#         ; value in the range 0 through 255
+#   Let-dig = ALPHA / DIGIT
+#   Ldh-str = *( ALPHA / DIGIT / "-" ) Let-dig
+# 
+#   IPv6-addr = IPv6-full / IPv6-comp / IPv6v4-full / IPv6v4-comp
+#   IPv6-hex  = 1*4HEXDIG
+#   IPv6-full = IPv6-hex 7(":" IPv6-hex)
+#   IPv6-comp = [IPv6-hex *5(":" IPv6-hex)] "::" [IPv6-hex *5(":"
+#          IPv6-hex)]
+#         ; The "::" represents at least 2 16-bit groups of zeros
+#         ; No more than 6 groups in addition to the "::" may be
+#         ; present
+#   IPv6v4-full = IPv6-hex 5(":" IPv6-hex) ":" IPv4-address-literal
+#   IPv6v4-comp = [IPv6-hex *3(":" IPv6-hex)] "::"
+#            [IPv6-hex *3(":" IPv6-hex) ":"] IPv4-address-literal
+#         ; The "::" represents at least 2 16-bit groups of zeros
+#         ; No more than 4 groups in addition to the "::" and
+#         ; IPv4-address-literal may be present
+# 
+# 
+# 
+# atext and qcontent are not defined in RFC 2821.
+# From RFC 2822:
+# 
+# atext           =       ALPHA / DIGIT / ; Any character except controls,
+#                         "!" / "#" /     ;  SP, and specials.
+#                         "$" / "%" /     ;  Used for atoms
+#                         "&" / "'" /
+#                         "*" / "+" /
+#                         "-" / "/" /
+#                         "=" / "?" /
+#                         "^" / "_" /
+#                         "`" / "{" /
+#                         "|" / "}" /
+#                         "~"
+# qtext           =       NO-WS-CTL /     ; Non white space controls
+# 
+#                         %d33 /          ; The rest of the US-ASCII
+#                         %d35-91 /       ;  characters not including "\"
+#                         %d93-126        ;  or the quote character
+# 
+# qcontent        =       qtext / quoted-pair
+# 
+# NO-WS-CTL       =       %d1-8 /         ; US-ASCII control characters
+#                         %d11 /          ;  that do not include the
+#                         %d12 /          ;  carriage return, line feed,
+#                         %d14-31 /       ;  and white space characters
+#                         %d127
+# 
+# quoted-pair     =       ("\" text) / obs-qp
+# 
+# text            =       %d1-9 /         ; Characters excluding CR and LF
+#                         %d11 /
+#                         %d12 /
+#                         %d14-127 /
+#                         obs-text
+#
+#
+# (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
+
+# address components are defined as package variables so that they can
+# be overriden (in hook_pre_connection, for example) if people have
+# different needs.
+our $atom_expr = '[a-zA-Z0-9!#%&*+=?^_`{|}~\$\x27\x2D\/]+';
+our $address_literal_expr =
+  '(?:\[(?:\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}|IPv6:[0-9A-Fa-f:.]+)\])';
+our $subdomain_expr = '(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?)';
+our $domain_expr;
+our $qtext_expr = '[\x01-\x08\x0B\x0C\x0E-\x1F\x21\x23-\x5B\x5D-\x7F]';
+our $text_expr  = '[\x01-\x09\x0B\x0C\x0E-\x7F]';
+
+sub canonify {
+    my ($dummy, $path) = @_;
+
+    # strip delimiters
+    return undef unless ($path =~ /^<(.*)>$/);
+    $path = $1;
+
+    my $domain = $domain_expr ? $domain_expr
+                              : "$subdomain_expr(?:\.$subdomain_expr)*";
+    # it is possible for $address_literal_expr to be empty, if a site
+    # doesn't want to allow them
+    $domain = "(?:$address_literal_expr|$domain)"
+      if !$domain_expr and $address_literal_expr;
+
+    # strip source route
+    $path =~ s/^\@$domain(?:,\@$domain)*://;
+
+    # empty path is ok
+    return "" if $path eq "";
+
+    # bare postmaster is permissible, perl RFC-2821 (4.5.1)
+    return ("postmaster", undef) if $path =~ m/^postmaster$/i;
+
+    my ($localpart, $domainpart) = ($path =~ /^(.*)\@($domain)$/);
+    return (undef) unless defined $localpart;
+
+    if ($localpart =~ /^$atom_expr(\.$atom_expr)*/) {
+        # simple case, we are done
+        return ($localpart, $domainpart);
+      }
+    if ($localpart =~ /^"(($qtext_expr|\\$text_expr)*)"$/) {
+        $localpart = $1;
+        $localpart =~ s/\\($text_expr)/$1/g;
+        return ($localpart, $domainpart);
+      }
+    return (undef);
+}
+
+=head2 parse()
+
+Retained as a compatibility method, it is completely equivalent
+to new() called with a single parameter.
+
+=cut
+
+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) = @_;
+    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\/=\?\^_`{\|}~.]';
+    return '<>' unless defined $self->{_user};
+    if ( ( my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) {
+        return qq(<"$user")
+	. ( defined $self->{_host} ? '@'.$self->{_host} : '' ). ">";
+      }
+    return "<".$self->address().">";
+}
+
+=head2 user([$user])
+
+Returns the "localpart" of the address, per RFC-2821, or the portion
+before the '@' sign.
+
+If called with one parameter, the localpart is set and the new value is
+returned.
+
+=cut
+
+sub user {
+    my ($self, $user) = @_;
+    $self->{_user} = $user if defined $user;
+    return $self->{_user};
+}
+
+=head2 host([$host])
+
+Returns the "domain" part of the address, per RFC-2821, or the portion
+after the '@' sign.
+
+If called with one parameter, the domain is set and the new value is
+returned.
+
+=cut
+
+sub host {
+    my ($self, $host) = @_;
+    $self->{_host} = $host if defined $host;
+    return $self->{_host};
+}
+
+=head2 notes($key[,$value])
+
+Get or set a note on the address. This is a piece of data that you wish
+to attach to the address and read somewhere else. For example you can
+use this to pass data between plugins.
+
+=cut
+
+sub notes {
+  my ($self,$key) = (shift,shift);
+  # Check for any additional arguments passed by the caller -- including undef
+  return $self->{_notes}->{$key} unless @_;
+  return $self->{_notes}->{$key} = shift;
+}
+
+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  = join( '=', reverse( split('@', $left->format))) ) =~ tr/[<>]//d;
+    ($right = join( '=', reverse( split('@',$right->format))) ) =~ tr/[<>]//d;
+
+    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/Auth.pm

@@ -0,0 +1,223 @@
+package Qpsmtpd::Auth;
+# See the documentation in 'perldoc docs/authentication.pod' 
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
+
+use Digest::HMAC_MD5 qw(hmac_md5_hex);
+use MIME::Base64;
+
+sub e64 {
+  my ($arg) = @_;
+  my $res = encode_base64($arg);
+  chomp($res);
+  return($res);
+}
+
+sub SASL {
+
+    # $DB::single = 1;
+    my ( $session, $mechanism, $prekey ) = @_;
+    my ( $user, $passClear, $passHash, $ticket, $loginas );
+
+    if ( $mechanism eq 'plain' ) {
+        ($loginas, $user, $passClear) = get_auth_details_plain($session,$prekey);
+        return DECLINED if ! $user || ! $passClear;
+    }
+    elsif ( $mechanism eq 'login' ) {
+        ($user, $passClear) = get_auth_details_login($session,$prekey);
+        return DECLINED if ! $user || ! $passClear;
+    }
+    elsif ( $mechanism eq 'cram-md5' ) {
+        ( $ticket, $user, $passHash ) = get_auth_details_cram_md5($session);
+        return DECLINED if ! $user || ! $passHash;
+    }
+    else {
+        #this error is now caught in SMTP.pm's sub auth
+        $session->respond( 500, "Internal server error" );
+        return DECLINED;
+    }
+
+    # try running the specific hooks first
+    my ( $rc, $msg ) =
+      $session->run_hooks( "auth-$mechanism", $mechanism, $user, $passClear,
+        $passHash, $ticket );
+
+    # try running the polymorphous hooks next
+    if ( !$rc || $rc == DECLINED ) {    
+        ( $rc, $msg ) =
+          $session->run_hooks( "auth", $mechanism, $user, $passClear,
+            $passHash, $ticket );
+    }
+
+    if ( $rc == OK ) {
+        $msg = uc($mechanism) . " authentication successful for $user" .
+            ( $msg ? " - $msg" : '');
+        $session->respond( 235, $msg );
+        $session->connection->relay_client(1);
+        if ( $session->connection->notes('naughty' ) ) {
+            $session->log( LOGINFO, "auth success cleared naughty" );
+            $session->connection->notes('naughty',0);
+        };
+        $session->log( LOGDEBUG, $msg );  # already logged by $session->respond
+
+        $session->{_auth_user} = $user;
+        $session->{_auth_mechanism} = $mechanism;
+        s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_mechanism}); 
+
+        return OK;
+    }
+    else {
+        $msg = uc($mechanism) . " authentication failed for $user" .
+            ( $msg ? " - $msg" : '');
+        $session->respond( 535, $msg );
+        $session->log( LOGDEBUG, $msg );  # already logged by $session->respond
+        return DENY;
+    }
+}
+
+sub get_auth_details_plain {
+    my ( $session, $prekey ) = @_;
+
+    if ( ! $prekey) {
+        $session->respond( 334, ' ' );
+        $prekey= <STDIN>;
+    }
+
+    my ( $loginas, $user, $passClear ) = split /\x0/, decode_base64($prekey);
+
+    if ( ! $user ) {
+        if ( $loginas ) {
+            $session->respond(535, "Authentication invalid ($loginas)");
+        }
+        else {
+            $session->respond(535, "Authentication invalid");
+        }
+        return;
+    };
+
+    # Authorization ID must not be different from Authentication ID
+    if ( $loginas ne '' && $loginas ne $user ) {
+        $session->respond(535, "Authentication invalid for $user");
+        return;
+    }
+
+    return ($loginas, $user, $passClear);
+};
+
+sub get_auth_details_login {
+    my ( $session, $prekey ) = @_;
+
+    my $user;
+
+    if ( $prekey ) {
+        $user = decode_base64($prekey);
+    }
+    else {
+        $user = get_base64_response($session,'Username:') or return;
+    }
+
+    my $passClear = get_base64_response($session,'Password:') or return;
+
+    return ($user, $passClear);
+};
+
+sub get_auth_details_cram_md5 {
+    my ( $session, $ticket ) = @_;
+
+    if ( ! $ticket ) {  # ticket is only passed in during testing
+    # rand() is not cryptographic, but we only need to generate a globally
+    # unique number.  The rand() is there in case the user logs in more than
+    # once in the same second, or if the clock is skewed.
+        $ticket = sprintf( '<%x.%x@%s>',
+            rand(1000000), time(), $session->config('me') );
+    };
+
+    # send the base64 encoded ticket
+    $session->respond( 334, encode_base64( $ticket, '' ) );
+    my $line = <STDIN>;
+
+    if ( $line eq '*' ) {
+        $session->respond( 501, "Authentication canceled" );
+        return;
+    };
+
+    my ( $user, $passHash ) = split( ' ', decode_base64($line) );
+    unless ( $user && $passHash ) {
+        $session->respond(504, "Invalid authentication string");
+        return;
+    }
+
+    $session->{auth}{ticket} = $ticket;
+    return ($ticket, $user, $passHash);
+};
+
+sub get_base64_response {
+    my ($session, $question) = @_;
+
+    $session->respond(334, e64($question));
+    my $answer = decode_base64( <STDIN> );
+    if ($answer eq '*') {
+        $session->respond(501, "Authentication canceled");
+        return;
+    }
+    return $answer;
+};
+
+sub validate_password {
+    my ( $self, %a ) = @_;
+
+    my ($pkg, $file, $line) = caller();
+    $file = (split '/', $file)[-1];     # strip off the path
+
+    my $src_clear     = $a{src_clear};
+    my $src_crypt     = $a{src_crypt};
+    my $attempt_clear = $a{attempt_clear};
+    my $attempt_hash  = $a{attempt_hash};
+    my $method        = $a{method} or die "missing method";
+    my $ticket        = $a{ticket} || $self->{auth}{ticket};
+    my $deny          = $a{deny} || DENY;
+
+    if ( ! $src_crypt && ! $src_clear ) {
+        $self->log(LOGINFO, "fail: missing password");
+        return ( $deny, "$file - no such user" );
+    };
+
+    if ( ! $src_clear && $method =~ /CRAM-MD5/i ) {
+        $self->log(LOGINFO, "skip: cram-md5 not supported w/o clear pass");
+        return ( DECLINED, $file );
+    }
+
+    if ( defined $attempt_clear ) {
+        if ( $src_clear && $src_clear eq $attempt_clear ) {
+            $self->log(LOGINFO, "pass: clear match");
+            return ( OK, $file );
+        };
+
+        if ( $src_crypt && $src_crypt eq crypt( $attempt_clear, $src_crypt ) ) {
+            $self->log(LOGINFO, "pass: crypt match");
+            return ( OK, $file );
+        }
+    };
+
+    if ( defined $attempt_hash && $src_clear ) {
+        if ( ! $ticket ) {
+            $self->log(LOGERROR, "skip: missing ticket");
+            return ( DECLINED, $file );
+        };
+
+        if ( $attempt_hash eq hmac_md5_hex( $ticket, $src_clear ) ) {
+            $self->log(LOGINFO, "pass: hash match");
+            return ( OK, $file );
+        };
+    };
+
+    $self->log(LOGINFO, "fail: wrong password");
+    return ( $deny, "$file - wrong password" );
+};
+
+# tag: qpsmtpd plugin that sets RELAYCLIENT when the user authenticates
+
+1;

lib/Qpsmtpd/Command.pm

@@ -0,0 +1,171 @@
+package Qpsmtpd::Command;
+
+=head1 NAME
+
+Qpsmtpd::Command - parse arguments to SMTP commands
+
+=head1 DESCRIPTION
+
+B<Qpsmtpd::Command> provides just one public sub routine: B<parse()>.
+
+This sub expects two or three arguments. The first is the name of the 
+SMTP command (such as I<HELO>, I<MAIL>, ...). The second must be the remaining
+of the line the client sent.
+
+If no third argument is given (or it's not a reference to a CODE) it parses 
+the line according to RFC 1869 (SMTP Service Extensions) for the I<MAIL> and 
+I<RCPT> commands and splitting by spaces (" ") for all other.
+
+Any module can supply it's own parsing routine by returning a sub routine 
+reference from a hook_*_parse. This sub will be called with I<$self>, I<$cmd>
+and I<$line>. 
+
+On successfull parsing it MUST return B<OK> (the constant from 
+I<Qpsmtpd::Constants>) success as first argument and a list of 
+values, which will be the arguments to the hook for this command.
+
+If parsing failed, the second returned value (if any) will be returned to the
+client as error message.
+
+=head1 EXAMPLE
+
+Inside a plugin 
+
+ sub hook_unrecognized_command_parse {
+    my ($self, $transaction, $cmd) = @_;
+    return (OK, \&bdat_parser) if ($cmd eq 'bdat');
+ }
+
+ sub bdat_parser {
+    my ($self,$cmd,$line) = @_;
+    # .. do something with $line...
+    return (DENY, "Invalid arguments") 
+      if $some_reason_why_there_is_a_syntax_error;
+    return (OK, @args);
+ }
+
+ sub hook_unrecognized_command {
+    my ($self, $transaction, $cmd, @args) = @_;
+    return (DECLINED) if ($self->qp->connection->hello eq 'helo');
+    return (DECLINED) unless ($cmd eq 'bdat');
+    ....
+ }
+
+=cut
+
+use strict;
+
+use Qpsmtpd::Constants;
+use vars qw(@ISA);
+@ISA = qw(Qpsmtpd::SMTP);
+
+sub parse {
+    my ($me,$cmd,$line,$sub) = @_;
+    return (OK) unless defined $line; # trivial case
+    my $self = {};
+    bless $self, $me;
+    $cmd = lc $cmd;
+    if ($sub and (ref($sub) eq 'CODE')) {
+        my @ret = eval { $sub->($self, $cmd, $line); };
+        if ($@) {
+            $self->log(LOGERROR, "Failed to parse command [$cmd]: $@");
+            return (DENY, $line, ());
+        }
+        ## my @log = @ret;
+        ## for (@log) {
+        ##     $_ ||= "";
+        ## }
+        ## $self->log(LOGDEBUG, "parse($cmd) => [".join("], [", @log)."]");
+        return @ret;
+    } 
+    my $parse = "parse_$cmd";
+    if ($self->can($parse)) {
+        # print "CMD=$cmd,line=$line\n";
+        my @out = eval { $self->$parse($cmd, $line); };
+        if ($@) {
+            $self->log(LOGERROR, "$parse($cmd,$line) failed: $@");
+            return(DENY, "Failed to parse line");
+        }
+        return @out;
+    }
+    return(OK, split(/ +/, $line)); # default :)
+}
+
+sub parse_rcpt {
+    my ($self,$cmd,$line) = @_;
+    return (DENY, "Syntax error in command") unless $line =~ s/^to:\s*//i;
+    return &_get_mail_params($cmd, $line);
+}
+
+sub parse_mail {
+    my ($self,$cmd,$line) = @_;
+    return (DENY, "Syntax error in command") unless $line =~ s/^from:\s*//i;
+    return &_get_mail_params($cmd, $line);
+}
+### RFC 1869:
+## 6.  MAIL FROM and RCPT TO Parameters
+## [...]
+##
+##   esmtp-cmd        ::= inner-esmtp-cmd [SP esmtp-parameters] CR LF
+##   esmtp-parameters ::= esmtp-parameter *(SP esmtp-parameter)
+##   esmtp-parameter  ::= esmtp-keyword ["=" esmtp-value]
+##   esmtp-keyword    ::= (ALPHA / DIGIT) *(ALPHA / DIGIT / "-")
+##
+##                        ; syntax and values depend on esmtp-keyword
+##   esmtp-value      ::= 1*<any CHAR excluding "=", SP, and all
+##                           control characters (US ASCII 0-31
+##                           inclusive)>
+##
+##                        ; The following commands are extended to
+##                        ; accept extended parameters.
+##   inner-esmtp-cmd  ::= ("MAIL FROM:" reverse-path)   /
+##                        ("RCPT TO:" forward-path)
+sub _get_mail_params {
+    my ($cmd,$line) = @_;
+    my @params = ();
+    $line =~ s/\s*$//;
+
+    while ($line =~ s/\s+([A-Za-z0-9][A-Za-z0-9\-]*(=[^= \x00-\x1f]+)?)$//) {
+        push @params, $1;
+    }
+    @params = reverse @params;
+
+    # the above will "fail" (i.e. all of the line in @params) on 
+    # some addresses without <> like
+    #    MAIL FROM: user=name@example.net
+    # or RCPT TO: postmaster
+
+    # let's see if $line contains nothing and use the first value as address:
+    if ($line) {
+        # parameter syntax error, i.e. not all of the arguments were 
+        # stripped by the while() loop:
+        return (DENY, "Syntax error in parameters")
+          if ($line =~ /\@.*\s/); 
+        return (OK, $line, @params);
+    }
+
+    $line = shift @params; 
+    if ($cmd eq "mail") {
+        return (OK, "<>") unless $line; # 'MAIL FROM:' --> 'MAIL FROM:<>'
+        return (DENY, "Syntax error in parameters") 
+          if ($line =~ /\@.*\s/); # parameter syntax error
+    }
+    else {
+        if ($line =~ /\@/) {
+            return (DENY, "Syntax error in parameters") 
+              if ($line =~ /\@.*\s/);
+        } 
+        else {
+            # XXX: what about 'abuse' in Qpsmtpd::Address?
+            return (DENY, "Syntax error in parameters") if $line =~ /\s/;
+            return (DENY, "Syntax error in address") 
+              unless ($line =~ /^(postmaster|abuse)$/i); 
+        }
+    }
+    ## XXX:  No: let this do a plugin, so it's not up to us to decide
+    ##       if we require <> around an address :-)
+    ## unless ($line =~ /^<.*>$/) { $line = "<".$line.">"; }
+    return (OK, $line, @params);
+}
+
+1;

lib/Qpsmtpd/ConfigServer.pm

@@ -0,0 +1,287 @@
+package Qpsmtpd::ConfigServer;
+
+use base ('Danga::Client');
+use Qpsmtpd::Constants;
+
+use strict;
+
+use fields qw(
+    _auth
+    _commands
+    _config_cache
+    _connection
+    _transaction
+    _test_mode
+    _extras
+    other_fds
+);
+
+my $PROMPT = "Enter command: ";
+
+sub new {
+    my Qpsmtpd::ConfigServer $self = shift;
+    
+    $self = fields::new($self) unless ref $self;
+    $self->SUPER::new( @_ );
+    $self->write($PROMPT);
+    return $self;
+}
+
+sub max_idle_time { 3600 } # one hour
+
+sub process_line {
+    my $self = shift;
+    my $line = shift || return;
+    if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; }
+    local $SIG{ALRM} = sub {
+        my ($pkg, $file, $line) = caller();
+        die "ALARM: $pkg, $file, $line";
+    };
+    my $prev = alarm(2); # must process a command in < 2 seconds
+    my $resp = eval { $self->_process_line($line) };
+    alarm($prev);
+    if ($@) {
+        print STDERR "Error: $@\n";
+    }
+    return $resp || '';
+}
+
+sub respond {
+    my $self = shift;
+    my (@messages) = @_;
+    while (my $msg = shift @messages) {
+        $self->write("$msg\r\n");
+    }
+    return;
+}
+
+sub fault {
+  my $self = shift;
+  my ($msg) = shift || "program fault - command not performed";
+  print STDERR "$0 [$$]: $msg ($!)\n";
+  $self->respond("Error - " . $msg);
+  return $PROMPT;
+}
+
+sub _process_line {
+    my $self = shift;
+    my $line = shift;
+
+    $line =~ s/\r?\n//;
+    my ($cmd, @params) = split(/ +/, $line);
+    my $meth = "cmd_" . lc($cmd);
+    if (my $lookup = $self->can($meth)) {
+        my $resp = eval {
+            $lookup->($self, @params);
+        };
+        if ($@) {
+            my $error = $@;
+            chomp($error);
+            Qpsmtpd->log(LOGERROR, "Command Error: $error");
+            return $self->fault("command '$cmd' failed unexpectedly");
+        }
+        return "$resp\n$PROMPT";
+    }
+    else {
+        # No such method - i.e. unrecognized command
+        return $self->fault("command '$cmd' unrecognised");
+    }
+}
+
+my %helptext = (
+    help => "HELP [CMD] - Get help on all commands or a specific command",
+    status => "STATUS - Returns status information about current connections",
+    list => "LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list",
+    kill => "KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF",
+    pause => "PAUSE - Stop accepting new connections",
+    continue => "CONTINUE - Resume accepting connections",
+    reload => "RELOAD - Reload all plugins and config",
+    quit => "QUIT - Exit the config server",
+    );
+
+sub cmd_help {
+    my $self = shift;
+    my ($subcmd) = @_;
+    
+    $subcmd ||= 'help';
+    $subcmd = lc($subcmd);
+    
+    if ($subcmd eq 'help') {
+        my $txt = join("\n", map { substr($_, 0, index($_, "-")) } sort values(%helptext));
+        return "Available Commands:\n\n$txt\n";
+    }
+    my $txt = $helptext{$subcmd} || "Unrecognised help option. Try 'help' for a full list.";
+    return "$txt\n";
+}
+
+sub cmd_quit {
+    my $self = shift;
+    $self->close;
+}
+
+sub cmd_shutdown {
+    exit;
+}
+
+sub cmd_pause {
+    my $self = shift;
+    
+    my $other_fds = $self->OtherFds;
+    
+    $self->{other_fds} = { %$other_fds };
+    %$other_fds = ();
+    return "PAUSED";
+}
+
+sub cmd_continue {
+    my $self = shift;
+    
+    my $other_fds = $self->{other_fds};
+    
+    $self->OtherFds( %$other_fds );
+    %$other_fds = ();
+    return "UNPAUSED";
+}
+
+sub cmd_status {
+    my $self = shift;
+ 
+# Status should show:
+#  - Total time running
+#  - Total number of mails received
+#  - Total number of mails rejected (5xx)
+#  - Total number of mails tempfailed (5xx)
+#  - Avg number of mails/minute
+#  - Number of current connections
+#  - Number of outstanding DNS queries
+    
+    my $output = "Current Status as of " . gmtime() . " GMT\n\n";
+    
+    if (defined &Qpsmtpd::Plugin::stats::get_stats) {
+        # Stats plugin is loaded
+        $output .= Qpsmtpd::Plugin::stats->get_stats;
+    }
+    
+    my $descriptors = Danga::Socket->DescriptorMap;
+    
+    my $current_connections = 0;
+    my $current_dns = 0;
+    foreach my $fd (keys %$descriptors) {
+        my $pob = $descriptors->{$fd};
+        if ($pob->isa("Qpsmtpd::PollServer")) {
+            $current_connections++;
+        }
+        elsif ($pob->isa("ParaDNS::Resolver")) {
+            $current_dns = $pob->pending;
+        }
+    }
+    
+    $output .= "Curr Connections: $current_connections / $::MAXconn\n".
+               "Curr DNS Queries: $current_dns";
+    
+    return $output;
+}
+
+sub cmd_list {
+    my $self = shift;
+    my ($count) = @_;
+    
+    my $descriptors = Danga::Socket->DescriptorMap;
+    
+    my $list = "Current" . ($count ? (($count > 0) ? " Oldest $count" : " Newest ".-$count) : "") . " Connections: \n\n";
+    my @all;
+    foreach my $fd (keys %$descriptors) {
+        my $pob = $descriptors->{$fd};
+        if ($pob->isa("Qpsmtpd::PollServer")) {
+            next unless $pob->connection->remote_ip; # haven't even started yet
+            push @all, [$pob+0, $pob->connection->remote_ip,
+                        $pob->connection->remote_host, $pob->uptime];
+        }
+    }
+    
+    @all = sort { $a->[3] <=> $b->[3] } @all;
+    if ($count) {
+        if ($count > 0) {
+            @all = @all[$#all-($count-1) .. $#all];
+        }
+        else {
+            @all = @all[0..(abs($count) - 1)];
+        }
+    }
+    foreach my $item (@all) {
+        $list .= sprintf("%x : %s [%s] Connected %0.2fs\n", map { defined()?$_:'' } @$item);
+    }
+    
+    return $list;
+}
+
+sub cmd_kill {
+    my $self = shift;
+    my ($match) = @_;
+    
+    return "SYNTAX: KILL (\$IP | \$REF)\n" unless $match;
+    
+    my $descriptors = Danga::Socket->DescriptorMap;
+    
+    my $killed = 0;
+    my $is_ip = (index($match, '.') >= 0);
+    foreach my $fd (keys %$descriptors) {
+        my $pob = $descriptors->{$fd};
+        if ($pob->isa("Qpsmtpd::PollServer")) {
+            if ($is_ip) {
+                next unless $pob->connection->remote_ip; # haven't even started yet
+                if ($pob->connection->remote_ip eq $match) {
+                    $pob->write("550 Your connection has been killed by an administrator\r\n");
+                    $pob->disconnect;
+                    $killed++;
+                }
+            }
+            else {
+                # match by ID
+                if ($pob+0 == hex($match)) {
+                    $pob->write("550 Your connection has been killed by an administrator\r\n");
+                    $pob->disconnect;
+                    $killed++;
+                }
+            }
+        }
+    }
+    
+    return "Killed $killed connection" . ($killed > 1 ? "s" : "") . "\n";
+}
+
+sub cmd_dump {
+    my $self = shift;
+    my ($ref) = @_;
+    
+    return "SYNTAX: DUMP \$REF\n" unless $ref;
+    require Data::Dumper;
+    $Data::Dumper::Indent=1;
+    
+    my $descriptors = Danga::Socket->DescriptorMap;
+    foreach my $fd (keys %$descriptors) {
+        my $pob = $descriptors->{$fd};
+        if ($pob->isa("Qpsmtpd::PollServer")) {
+            if ($pob+0 == hex($ref)) {
+                return Data::Dumper::Dumper($pob);
+            }
+        }
+    }
+    
+    return "Unable to find the connection: $ref. Try the LIST command\n";
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Qpsmtpd::ConfigServer - a configuration server for qpsmtpd
+
+=head1 DESCRIPTION
+
+When qpsmtpd runs in multiplex mode it also provides a config server that you
+can connect to. This allows you to view current connection statistics and other
+gumph that you probably don't care about.
+
+=cut

lib/Qpsmtpd/Connection.pm

@@ -0,0 +1,228 @@
+package Qpsmtpd::Connection;
+use strict;
+
+# All of these parameters depend only on the physical connection, 
+# i.e. not on anything sent from the remote machine.  Hence, they
+# are an appropriate set to use for either start() or clone().  Do
+# not add parameters here unless they also meet that criteria.
+my @parameters = qw(
+        remote_host
+        remote_ip 
+        remote_info 
+        remote_port
+        local_ip
+        local_port
+        relay_client
+);
+
+
+sub new {
+  my $proto = shift;
+  my $class = ref($proto) || $proto;
+  my $self = {};
+  bless ($self, $class);
+}
+
+sub start {
+  my $self = shift;
+  $self = $self->new(@_) unless ref $self;
+
+  my %args = @_;
+
+  foreach my $f ( @parameters ) {
+    $self->$f($args{$f}) if $args{$f};
+  }
+
+  return $self;
+}
+
+sub clone {
+  my $self = shift;
+  my %args = @_;
+  my $new = $self->new();
+  foreach my $f ( @parameters ) {
+    $new->$f($self->$f()) if $self->$f();
+  }
+  $new->{_notes} = $self->{_notes} if defined $self->{_notes};
+  # reset the old connection object like it's done at the end of a connection
+  # to prevent leaks (like prefork/tls problem with the old SSL file handle 
+  # still around)
+  $self->reset unless $args{no_reset}; 
+  # should we generate a new id here?
+  return $new;
+}
+
+sub remote_host {
+  my $self = shift;
+  @_ and $self->{_remote_host} = shift;
+  $self->{_remote_host};
+}
+
+sub remote_ip {
+  my $self = shift;
+  @_ and $self->{_remote_ip} = shift;
+  $self->{_remote_ip};
+}
+
+sub remote_port {
+  my $self = shift;
+  @_ and $self->{_remote_port} = shift;
+  $self->{_remote_port};
+}
+
+sub local_ip {
+  my $self = shift;
+  @_ and $self->{_local_ip} = shift;
+  $self->{_local_ip};
+}
+
+sub local_port {
+  my $self = shift;
+  @_ and $self->{_local_port} = shift;
+  $self->{_local_port};
+}
+
+
+sub remote_info {
+  my $self = shift;
+  @_ and $self->{_remote_info} = shift;
+  $self->{_remote_info};
+}
+
+sub relay_client {
+  my $self = shift;
+  @_ and $self->{_relay_client} = shift;
+  $self->{_relay_client};
+}
+
+sub hello {
+  my $self = shift;
+  @_ and $self->{_hello} = shift;
+  $self->{_hello};
+}
+
+sub hello_host {
+  my $self = shift;
+  @_ and $self->{_hello_host} = shift;
+  $self->{_hello_host};
+}
+
+sub notes {
+  my ($self,$key) = (shift,shift);
+  # Check for any additional arguments passed by the caller -- including undef
+  return $self->{_notes}->{$key} unless @_;
+  return $self->{_notes}->{$key} = shift;
+}
+
+sub reset {
+   my $self = shift;
+   $self->{_notes} = undef;
+   $self = $self->new;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Qpsmtpd::Connection - A single SMTP connection
+
+=head1 SYNOPSIS
+
+  my $rdns = $qp->connection->remote_host;
+  my $ip = $qp->connection->remote_ip;
+
+=head1 DESCRIPTION
+
+This class contains details about an individual SMTP connection. A
+connection lasts the lifetime of a TCP connection to the SMTP server.
+
+See also L<Qpsmtpd::Transaction> which is a class containing details
+about an individual SMTP transaction. A transaction lasts from
+C<MAIL FROM> to the end of the C<DATA> marker, or a C<RSET> command,
+whichever comes first, whereas a connection lasts until the client
+disconnects.
+
+=head1 API
+
+These API docs assume you already have a connection object. See the
+source code if you need to construct one. You can access the connection
+object via the C<Qpsmtpd> object's C<< $qp->connection >> method.
+
+=head2 new ( )
+
+Instantiates a new Qpsmtpd::Connection object.
+
+=head2 start ( %args )
+
+Initializes the connection object with %args attribute data.
+
+=head2 remote_host( )
+
+The remote host connecting to the server as looked up via reverse dns.
+
+=head2 remote_ip( )
+
+The remote IP address of the connecting host.
+
+=head2 remote_port( )
+
+The remote port.
+
+=head2 remote_info( )
+
+If your server does an ident lookup on the remote host, this is the
+identity of the remote client.
+
+=head2 local_ip( )
+
+The local ip.
+
+=head2 local_port( )
+
+The local port.
+
+=head2 hello( )
+
+Either C<"helo"> or C<"ehlo"> depending on how the remote client
+greeted your server.
+
+NOTE: This field is empty during the helo or ehlo hooks, it is only
+set after a successful return from those hooks.
+
+=head2 hello_host( )
+
+The host name specified in the C<HELO> or C<EHLO> command.
+
+NOTE: This field is empty during the helo or ehlo hooks, it is only
+set after a successful return from those hooks.
+
+=head2 notes($key [, $value])
+
+Get or set a note on the connection. This is a piece of data that you wish
+to attach to the connection and read somewhere else. For example you can
+use this to pass data between plugins.
+
+=head2 clone([%args])
+
+Returns a copy of the Qpsmtpd::Connection object. The optional args parameter
+may contain:
+
+=over 4
+
+=item no_reset (1|0) 
+
+If true, do not reset the original connection object, the author has to care
+about that: only the cloned connection object is reset at the end of the 
+connection
+
+=back
+
+=cut
+
+=head2 relay_client( )
+
+True if the client is allowed to relay messages.
+
+=cut

lib/Qpsmtpd/Constants.pm

@@ -0,0 +1,110 @@
+package Qpsmtpd::Constants;
+use strict;
+require Exporter;
+
+# log levels
+my %log_levels = (
+	LOGDEBUG   => 7,
+	LOGINFO    => 6,
+	LOGNOTICE  => 5,
+	LOGWARN    => 4,
+	LOGERROR   => 3,
+	LOGCRIT    => 2,
+	LOGALERT   => 1,
+	LOGEMERG   => 0,
+	LOGRADAR   => 0,
+);
+
+# return codes
+my %return_codes = (
+	OK                     => 900,
+	DENY                   => 901,   # 550
+	DENYSOFT               => 902,   # 450
+	DENYHARD               => 903,   # 550 + disconnect  (deprecated in 0.29)
+	DENY_DISCONNECT        => 903,   # 550 + disconnect
+	DENYSOFT_DISCONNECT    => 904,   # 450 + disconnect
+	DECLINED               => 909,
+	DONE                   => 910,
+	CONTINUATION           => 911,   # deprecated - use YIELD
+	YIELD                  => 911,
+);
+
+use vars qw(@ISA @EXPORT);
+@ISA = qw(Exporter);
+@EXPORT = (keys(%return_codes), keys(%log_levels), "return_code", "log_level");
+
+foreach (keys %return_codes ) {
+    eval "use constant $_ => ".$return_codes{$_};
+}
+
+foreach (keys %log_levels ) {
+    eval "use constant $_ => ".$log_levels{$_};
+}
+
+sub return_code {
+    my $test = shift;
+    if ( $test =~ /^\d+$/ ) { # need to return the textural form
+	foreach ( keys %return_codes ) {
+	    return $_ if $return_codes{$_} =~ /$test/;
+	}
+    }
+    else { # just return the numeric value
+	return $return_codes{$test};
+    }
+}
+
+sub log_level {
+    my $test = shift;
+    if ( $test =~ /^\d+$/ ) { # need to return the textural form
+	foreach ( keys %log_levels ) {
+	    return $_ if $log_levels{$_} =~ /$test/;
+	}
+    }
+    else { # just return the numeric value
+	return $log_levels{$test};
+    }
+}
+
+1;
+
+=head1 NAME
+
+Qpsmtpd::Constants - Constants for plugins to use
+
+=head1 CONSTANTS
+
+See L<README.plugins> for hook specific information on applicable
+constants.
+
+Constants available:
+
+=over 4
+
+=item C<OK>
+
+Return this only from the queue phase to indicate the mail was queued
+successfully.
+
+=item C<DENY>
+
+Returning this from a hook causes a 5xx error (hard failure) to be
+returned to the connecting client.
+
+=item C<DENYSOFT>
+
+Returning this from a hook causes a 4xx error (temporary failure - try
+again later) to be returned to the connecting client.
+
+=item C<DECLINED>
+
+Returning this from a hook implies success, but tells qpsmtpd to go
+on to the next plugin.
+
+=item C<DONE>
+
+Returning this from a hook implies success, but tells qpsmtpd to
+skip any remaining plugins for this phase.
+
+=back
+
+=cut

lib/Qpsmtpd/DSN.pm

@@ -0,0 +1,621 @@
+#
+# Enhanced Mail System Status Codes - RFC 1893
+#
+package Qpsmtpd::DSN;
+use strict;
+use Qpsmtpd::Constants;
+
+=head1 NAME
+
+Qpsmtpd::DSN - Enhanced Mail System Status Codes - RFC 1893
+
+=head1 DESCRIPTION
+
+The B<Qpsmtpd::DSN> implements the I<Enhanced Mail System Status Codes> from
+RFC 1893.
+
+=head1 USAGE
+
+Any B<qpsmtpd> plugin can access these status codes. All sub routines are used
+the same way:
+ use Qpsmtpd::DSN;
+ ...;
+ return Qpsmtpd::DSN->relaying_denied();
+
+or
+
+ return Qpsmtpd::DSN->relaying_denied("Relaying from $ip denied");
+
+or 
+
+ return Qpsmtpd::DSN->relaying_denied(DENY,"Relaying from $ip denied");
+
+If no status message was given, it will use the predefined one from the 
+RFC. If the first argument is numeric, it will use this as a return code, 
+else the default return code is used. See below which default return code
+is used in the different functions.
+
+The first example will return 
+I<(DENY, "Relaying denied");>
+the others 
+I<(DENY, "Relaying from $ip denied");>
+which will be returned to qpsmtpd.
+
+In those sub routines which don't start with I<addr_, sys_, net_, proto_, 
+media_, sec_> I've added a default message which describes the status better
+than the RFC message.
+
+=cut
+
+my @rfc1893 = (
+    [ 
+        "Other or Undefined Status",                              # x.0.x
+    ],
+    [
+        "Other address status.",                                  # x.1.0
+        "Bad destination mailbox address.",                       # x.1.1
+        "Bad destination system address.",                        # x.1.2
+        "Bad destination mailbox address syntax.",                # x.1.3
+        "Destination mailbox address ambiguous.",                 # x.1.4
+        "Destination address valid.",                             # x.1.5
+        "Destination mailbox has moved, No forwarding address.",  # x.1.6
+        "Bad sender's mailbox address syntax.",                   # x.1.7
+        "Bad sender's system address.",                           # x.1.8
+    ],
+    [
+        "Other or undefined mailbox status.",                     # x.2.0
+        "Mailbox disabled, not accepting messages.",              # x.2.1
+        "Mailbox full.",                                          # x.2.2
+        "Message length exceeds administrative limit.",           # x.2.3
+        "Mailing list expansion problem.",                        # x.2.4
+    ],
+    [
+        "Other or undefined mail system status.",                 # x.3.0
+        "Mail system full.",                                      # x.3.1
+        "System not accepting network messages.",                 # x.3.2
+        "System not capable of selected features.",               # x.3.3
+        "Message too big for system.",                            # x.3.4
+        "System incorrectly configured.",                         # x.3.5
+    ],
+    [ 
+        "Other or undefined network or routing status.",          # x.4.0
+        "No answer from host.",                                   # x.4.1
+        "Bad connection.",                                        # x.4.2
+        "Directory server failure.",                              # x.4.3
+        "Unable to route.",                                       # x.4.4
+        "Mail system congestion.",                                # x.4.5
+        "Routing loop detected.",                                 # x.4.6
+        "Delivery time expired.",                                 # x.4.7
+    ],
+    [
+        "Other or undefined protocol status.",                    # x.5.0 
+        "Invalid command.",                                       # x.5.1 
+        "Syntax error.",                                          # x.5.2 
+        "Too many recipients.",                                   # x.5.3 
+        "Invalid command arguments.",                             # x.5.4 
+        "Wrong protocol version.",                                # x.5.5 
+    ],
+    [
+        "Other or undefined media error.",                        # x.6.0
+        "Media not supported.",                                   # x.6.1
+        "Conversion required and prohibited.",                    # x.6.2
+        "Conversion required but not supported.",                 # x.6.3
+        "Conversion with loss performed.",                        # x.6.4
+        "Conversion Failed.",                                     # x.6.5
+    ],
+    [
+        "Other or undefined security status.",                    # x.7.0
+        "Delivery not authorized, message refused.",              # x.7.1
+        "Mailing list expansion prohibited.",                     # x.7.2
+        "Security conversion required but not possible.",         # x.7.3
+        "Security features not supported.",                       # x.7.4
+        "Cryptographic failure.",                                 # x.7.5
+        "Cryptographic algorithm not supported.",                 # x.7.6
+        "Message integrity failure.",                             # x.7.7
+    ],
+);
+
+sub _status {
+    my $return = shift;
+    my $const = Qpsmtpd::Constants::return_code($return);
+    if ($const =~ /^DENYSOFT/) {
+        return 4;
+    } 
+    elsif ($const =~ /^DENY/) {
+        return 5;
+    }
+    elsif ($const eq 'OK' or $const eq 'DONE') {
+        return 2;
+    }
+    else { # err .... no :)
+        return 4; # just 2,4,5 are allowed.. temp error by default
+    }
+}
+
+sub _dsn {
+    my ($self,$return,$reason,$default,$subject,$detail) = @_;
+    if (!defined $return) {
+        $return = $default;
+    } 
+    elsif ($return !~ /^\d+$/) {
+        $reason = $return;
+        $return = $default;
+    }
+    my $msg = $rfc1893[$subject][$detail];
+    unless (defined $msg) {
+        $detail = 0;
+        $msg    = $rfc1893[$subject][$detail];
+        unless (defined $msg) {
+            $subject = 0;
+            $msg     = $rfc1893[$subject][$detail];
+        }
+    }
+    my $class = &_status($return);
+    if (defined $reason) {
+        $msg = $reason;
+    }
+    return ($return, "$msg (#$class.$subject.$detail)");
+}
+
+sub unspecified { shift->_dsn(shift,shift,DENYSOFT,0,0); }
+
+=head1 ADDRESS STATUS
+
+=over 9
+
+=item addr_unspecified
+
+X.1.0
+default: DENYSOFT
+
+=cut
+
+sub addr_unspecified { shift->_dsn(shift,shift,DENYSOFT,1,0); }
+
+=item no_such_user, addr_bad_dest_mbox
+
+X.1.1
+default: DENY
+
+=cut
+
+sub no_such_user         { shift->_dsn(shift,(shift||"No such user"),DENY,1,1); }
+sub addr_bad_dest_mbox   { shift->_dsn(shift,shift,DENY,1,1); }
+
+=item addr_bad_dest_system 
+
+X.1.2
+default: DENY
+
+=cut
+
+sub addr_bad_dest_system      { shift->_dsn(shift,shift,DENY,1,2); }
+
+=item addr_bad_dest_syntax
+
+X.1.3
+default: DENY
+
+=cut
+
+sub addr_bad_dest_syntax      { shift->_dsn(shift,shift,DENY,1,3); }
+
+=item addr_dest_ambigous
+
+X.1.4
+default: DENYSOFT
+
+=cut
+
+sub addr_dest_ambigous    { shift->_dsn(shift,shift,DENYSOFT,1,4); }
+
+=item addr_rcpt_ok
+
+X.1.5
+default: OK
+
+=cut
+
+# XXX: do we need this? Maybe in all address verifying plugins?
+sub addr_rcpt_ok  { shift->_dsn(shift,shift,OK,1,5); } 
+
+=item addr_mbox_moved 
+
+X.1.6
+default: DENY
+
+=cut
+
+sub addr_mbox_moved           { shift->_dsn(shift,shift,DENY,1,6); }
+
+=item addr_bad_from_syntax
+
+X.1.7
+default: DENY
+
+=cut 
+
+sub addr_bad_from_syntax      { shift->_dsn(shift,shift,DENY,1,7); }
+
+=item addr_bad_from_system
+
+X.1.8
+default: DENY
+
+=back
+
+=cut
+
+sub addr_bad_from_system      { shift->_dsn(shift,shift,DENY,1,8); }
+
+=head1 MAILBOX STATUS
+
+=over 5
+
+=item mbox_unspecified
+
+X.2.0
+default: DENYSOFT
+
+=cut
+
+sub mbox_unspecified  { shift->_dsn(shift,shift,DENYSOFT,2,0); }
+
+=item mbox_disabled
+
+X.2.1
+default: DENY ...but RFC says:
+   The mailbox exists, but is not accepting messages.  This may
+   be a permanent error if the mailbox will never be re-enabled
+   or a transient error if the mailbox is only temporarily
+   disabled.
+
+=cut 
+
+sub mbox_disabled           { shift->_dsn(shift,shift,DENY,2,1); }
+
+=item mbox_full
+
+X.2.2
+default: DENYSOFT
+
+=cut
+
+sub mbox_full               { shift->_dsn(shift,shift,DENYSOFT,2,2); }
+
+=item mbox_msg_too_long 
+
+X.2.3
+default: DENY
+
+=cut
+
+sub mbox_msg_too_long            { shift->_dsn(shift,shift,DENY,2,3); }
+
+=item mbox_list_expansion_problem   
+
+X.2.4
+default: DENYSOFT
+
+=back
+
+=cut
+
+sub mbox_list_expansion_problem  { shift->_dsn(shift,shift,DENYSOFT,2,4); }
+
+=head1 MAIL SYSTEM STATUS
+
+=over 4
+
+=item sys_unspecified
+
+X.3.0
+default: DENYSOFT
+
+=cut
+
+sub sys_unspecified        { shift->_dsn(shift,shift,DENYSOFT,3,0); }
+
+=item sys_disk_full
+
+X.3.1
+default: DENYSOFT
+
+=cut
+
+sub sys_disk_full            { shift->_dsn(shift,shift,DENYSOFT,3,1); }
+
+=item sys_not_accepting_mail
+
+X.3.2
+default: DENYSOFT
+
+=cut
+
+sub sys_not_accepting_mail   { shift->_dsn(shift,shift,DENYSOFT,3,2); }
+
+=item sys_not_supported
+
+X.3.3
+default: DENYSOFT
+          Selected features specified for the message are not
+          supported by the destination system.  This can occur in
+          gateways when features from one domain cannot be mapped onto
+          the supported feature in another.
+
+=cut
+
+sub sys_not_supported        { shift->_dsn(shift,shift,DENYSOFT,3,3); }
+
+=item sys_msg_too_big           
+
+X.3.4
+default DENY
+
+=back
+
+=cut
+
+sub sys_msg_too_big          { shift->_dsn(shift,shift,DENY,3,4); }
+
+=head1 NETWORK AND ROUTING STATUS
+
+=cut
+
+=over 4
+
+=item net_unspecified 
+
+X.4.0
+default: DENYSOFT
+
+=cut 
+
+sub net_unspecified                { shift->_dsn(shift,shift,DENYSOFT,4,0); } 
+
+# not useful # sub net_no_answer   { shift->_dsn(shift,shift,4,1); } 
+# not useful # sub net_bad_connection { shift->_dsn(shift,shift,4,2); } 
+
+=item net_directory_server_failed, temp_resolver_failed
+
+X.4.3
+default: DENYSOFT
+
+=cut
+
+sub temp_resolver_failed { 
+      shift->_dsn(shift,
+                 (shift || "Temporary address resolution failure"),
+                 DENYSOFT,4,3); 
+}
+sub net_directory_server_failed  { shift->_dsn(shift,shift,DENYSOFT,4,3); }
+
+# not useful # sub net_unable_to_route { shift->_dsn(shift,shift,4,4); }
+
+=item net_system_congested
+
+X.4.5
+default: DENYSOFT
+
+=cut
+
+sub net_system_congested         { shift->_dsn(shift,shift,DENYSOFT,4,5); }
+
+=item net_routing_loop, too_many_hops
+
+X.4.6
+default: DENY, but RFC says:
+  A routing loop caused the message to be forwarded too many
+  times, either because of incorrect routing tables or a user
+  forwarding loop. This is useful only as a persistent
+  transient error.
+
+Why do we want to DENYSOFT something like this?
+
+=back
+
+=cut
+
+sub net_routing_loop   { shift->_dsn(shift,shift,DENY,4,6); }
+sub too_many_hops  { shift->_dsn(shift,(shift || "Too many hops"),DENY,4,6,); }
+# not useful # sub delivery_time_expired    { shift->_dsn(shift,shift,4,7); }
+
+=head1 MAIL DELIVERY PROTOCOL STATUS
+
+=over 6
+
+=item proto_unspecified
+
+X.5.0
+default: DENYSOFT
+
+=cut
+
+sub proto_unspecified     { shift->_dsn(shift,shift,DENYSOFT,5,0); }
+
+=item proto_invalid_command
+
+X.5.1
+default: DENY
+
+=cut
+
+sub proto_invalid_command        { shift->_dsn(shift,shift,DENY,5,1); }
+
+=item proto_syntax_error
+
+X.5.2
+default: DENY
+
+=cut
+
+sub proto_syntax_error           { shift->_dsn(shift,shift,DENY,5,2); }
+
+=item proto_rcpt_list_too_long, too_many_rcpts
+
+X.5.3
+default: DENYSOFT
+
+=cut
+
+sub proto_rcpt_list_too_long { shift->_dsn(shift,shift,DENYSOFT,5,3); }
+sub too_many_rcpts           { shift->_dsn(shift,shift,DENYSOFT,5,3); }
+
+=item proto_invalid_cmd_args 
+
+X.5.4
+default: DENY
+
+=cut
+
+sub proto_invalid_cmd_args       { shift->_dsn(shift,shift,DENY,5,4); }
+
+=item proto_wrong_version 
+
+X.5.5
+default: DENYSOFT
+
+=back
+
+=cut
+
+sub proto_wrong_version { shift->_dsn(shift,shift,DENYSOFT,5,5); }
+
+=head1 MESSAGE CONTENT OR MESSAGE MEDIA STATUS
+
+=over 5
+
+=item media_unspecified
+
+X.6.0
+default: DENYSOFT
+
+=cut
+
+sub media_unspecified      { shift->_dsn(shift,shift,DENYSOFT,6,0); }
+
+=item media_unsupported
+
+X.6.1
+default: DENY
+
+=cut
+
+sub media_unsupported      { shift->_dsn(shift,shift,DENY,6,1); }
+
+=item media_conv_prohibited
+
+X.6.2
+default: DENY
+
+=cut
+
+sub media_conv_prohibited        { shift->_dsn(shift,shift,DENY,6,2); }
+
+=item media_conv_unsupported
+
+X.6.3
+default: DENYSOFT
+
+=cut
+
+sub media_conv_unsupported       { shift->_dsn(shift,shift,DENYSOFT,6,3); }
+
+=item media_conv_lossy
+
+X.6.4
+default: DENYSOFT
+
+=back 
+
+=cut
+
+sub media_conv_lossy             { shift->_dsn(shift,shift,DENYSOFT,6,4); }
+
+=head1 SECURITY OR POLICY STATUS
+
+=over 8
+
+=item sec_unspecified
+
+X.7.0
+default: DENYSOFT
+
+=cut
+
+sub sec_unspecified                { shift->_dsn(shift,shift,DENYSOFT,7,0); }
+
+=item sec_sender_unauthorized, bad_sender_ip, relaying_denied 
+
+X.7.1
+default: DENY
+
+=cut
+
+sub sec_sender_unauthorized      { shift->_dsn(shift,shift,DENY,7,1); }
+sub bad_sender_ip { 
+    shift->_dsn(shift,(shift || "Bad sender's IP"),DENY,7,1,); 
+}
+sub relaying_denied { 
+    shift->_dsn(shift,(shift || "Relaying denied"),DENY,7,1); 
+}
+
+=item sec_list_dest_prohibited
+
+X.7.2
+default: DENY
+
+=cut
+
+sub sec_list_dest_prohibited    { shift->_dsn(shift,shift,DENY,7,2); }
+
+=item sec_conv_failed 
+
+X.7.3
+default: DENY
+
+=cut
+
+sub sec_conv_failed              { shift->_dsn(shift,shift,DENY,7,3); }
+
+=item sec_feature_unsupported 
+
+X.7.4
+default: DENY
+
+=cut
+
+sub sec_feature_unsupported      { shift->_dsn(shift,shift,DENY,7,4); }
+
+=item sec_crypto_failure
+
+X.7.5
+default: DENY
+
+=cut
+
+sub sec_crypto_failure               { shift->_dsn(shift,shift,DENY,7,5); }
+
+=item sec_crypto_algorithm_unsupported
+
+X.7.6
+default: DENYSOFT
+
+=cut
+
+sub sec_crypto_algorithm_unsupported { shift->_dsn(shift,shift,DENYSOFT,7,6); }
+
+=item sec_msg_integrity_failure
+
+X.7.7
+default: DENY
+
+=back
+
+=cut
+
+sub sec_msg_integrity_failure         { shift->_dsn(shift,shift,DENY,7,7); }
+
+1;
+
+# vim: st=4 sw=4 expandtab

lib/Qpsmtpd/Plugin.pm

@@ -0,0 +1,292 @@
+package Qpsmtpd::Plugin;
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
+
+# more or less in the order they will fire
+our @hooks = qw(
+    logging config post-fork pre-connection connect ehlo_parse ehlo
+    helo_parse helo auth_parse auth auth-plain auth-login auth-cram-md5
+    rcpt_parse rcpt_pre rcpt mail_parse mail mail_pre
+    data data_headers_end data_post queue_pre queue queue_post vrfy noop
+    quit reset_transaction disconnect post-connection
+    unrecognized_command deny ok received_line help
+);
+our %hooks = map { $_ => 1 } @hooks;
+
+sub new {
+  my $proto = shift;
+  my $class = ref($proto) || $proto;
+  bless ({}, $class);
+}
+
+sub hook_name {
+  return shift->{_hook};
+}
+
+sub register_hook {
+  my ($plugin, $hook, $method, $unshift) = @_;
+
+  die $plugin->plugin_name . " : Invalid hook: $hook" unless $hooks{$hook};
+
+  $plugin->{_qp}->log(LOGDEBUG, $plugin->plugin_name, "hooking", $hook)
+      unless $hook =~ /logging/; # can't log during load_logging()
+
+  # I can't quite decide if it's better to parse this code ref or if
+  # we should pass the plugin object and method name ... hmn.
+  $plugin->qp->_register_hook
+    ($hook,
+     { code => sub { local $plugin->{_qp} = shift;
+                     local $plugin->{_hook} = $hook;
+                     $plugin->$method(@_)
+                   },
+       name => $plugin->plugin_name,
+     },
+     $unshift,
+    );
+}
+
+sub _register {
+  my $self = shift;
+  my $qp = shift;
+  local $self->{_qp} = $qp;
+  $self->init($qp, @_)     if $self->can('init');
+  $self->_register_standard_hooks($qp, @_);
+  $self->register($qp, @_) if $self->can('register');
+}
+
+sub qp {
+  shift->{_qp};
+}
+
+sub log {
+  my $self = shift;
+  return if defined $self->{_hook} && $self->{_hook} eq 'logging';
+  my $level = $self->adjust_log_level( shift, $self->plugin_name );
+  $self->{_qp}->varlog($level, $self->{_hook}, $self->plugin_name, @_);
+}
+
+sub adjust_log_level {
+    my ( $self, $cur_level, $plugin_name) = @_;
+
+    my $adj = $self->{_args}{loglevel} or return $cur_level;
+
+    return $adj if $adj =~ m/^[01234567]$/;  # a raw syslog numeral
+
+    if ( $adj !~ /^[\+\-][\d]$/ ) {
+        $self->log( LOGERROR, $self-"invalid $plugin_name loglevel setting ($adj)" );
+        undef $self->{_args}{loglevel};  # only complain once per plugin
+        return $cur_level;
+    };
+
+    my $operator = substr($adj, 0, 1);
+    my $adjust  = substr($adj, -1, 1);
+
+    my $new_level = $operator eq '+' ? $cur_level + $adjust : $cur_level - $adjust;
+
+    $new_level = 7 if $new_level > 7;
+    $new_level = 0 if $new_level < 0;
+
+    return $new_level;
+};
+
+sub transaction {
+  # not sure if this will work in a non-forking or a threaded daemon
+  shift->qp->transaction;
+}
+
+sub connection {
+  shift->qp->connection;
+}
+
+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;
+  push @{$self->qp->transaction->{_temp_files}}, $tempfile;
+  return $tempfile;
+}
+
+sub temp_dir {
+  my $self = shift;
+  my $tempdir = $self->qp->temp_dir();
+  push @{$self->qp->transaction->{_temp_dirs}}, $tempdir;
+  return $tempdir;
+}
+
+# plugin inheritance:
+# usage:
+#  sub init {
+#    my $self = shift;
+#    $self->isa_plugin("rhsbl");
+#    $self->SUPER::register(@_);
+#  }
+sub isa_plugin {
+  my ($self, $parent) = @_;
+  my ($currentPackage) = caller;
+
+  my $cleanParent = $parent;
+  $cleanParent =~ s/\W/_/g;
+  my $newPackage = $currentPackage."::_isa_$cleanParent";
+
+  # don't reload plugins if they are already loaded
+  return if defined &{"${newPackage}::plugin_name"};
+
+  # find $parent in plugin_dirs
+  my $parent_dir;
+  for ($self->qp->plugin_dirs) {
+    if (-e "$_/$parent") {
+      $parent_dir = $_;
+      last;
+    }
+  }
+  die "cannot find plugin '$parent'" unless $parent_dir;
+
+  $self->compile($self->plugin_name . "_isa_$cleanParent",
+                    $newPackage,
+                    "$parent_dir/$parent");
+  warn "---- $newPackage\n";
+  no strict 'refs';
+  push @{"${currentPackage}::ISA"}, $newPackage;
+}
+
+# why isn't compile private?  it's only called from Plugin and Qpsmtpd.
+sub compile {
+    my ($class, $plugin, $package, $file, $test_mode, $orig_name) = @_;
+
+    my $sub;
+    open F, $file or die "could not open $file: $!";
+    {
+      local $/ = undef;
+      $sub = <F>;
+    }
+    close F;
+
+    my $line = "\n#line 0 $file\n";
+
+    if ($test_mode) {
+        if (open(F, "t/plugin_tests/$orig_name")) {
+            local $/ = undef;
+            $sub .= "#line 1 t/plugin_tests/$orig_name\n";
+            $sub .= <F>;
+            close F;
+        }
+    }
+
+    my $eval = join(
+		    "\n",
+		    "package $package;",
+		    'use Qpsmtpd::Constants;',
+		    "require Qpsmtpd::Plugin;",
+		    'use vars qw(@ISA);',
+                    'use strict;',
+		    '@ISA = qw(Qpsmtpd::Plugin);',
+		    ($test_mode ? 'use Test::More;' : ''),
+		    "sub plugin_name { qq[$plugin] }",
+		    $line,
+		    $sub,
+		    "\n", # last line comment without newline?
+		   );
+
+    #warn "eval: $eval";
+
+    $eval =~ m/(.*)/s;
+    $eval = $1;
+
+    eval $eval;
+    die "eval $@" if $@;
+}
+
+sub get_reject {
+    my $self = shift;
+    my $message = shift || "why didn't you pass an error message?";
+    my $log_info = shift || '';
+    $log_info = ", $log_info" if $log_info;
+
+    my $reject = $self->{_args}{reject};
+    if ( defined $reject && ! $reject ) {
+        $self->log(LOGINFO, 'fail, reject disabled');
+        return DECLINED;
+    };
+
+    # the naughty plugin will reject later
+    if ( $reject eq 'naughty' ) {
+        $self->log(LOGINFO, 'fail, NAUGHTY');
+        $self->connection->notes('naughty', $message);
+        return (DECLINED);
+    };
+
+    # they asked for reject, we give them reject
+    $self->log(LOGINFO, 'fail'.$log_info);
+    return ( $self->get_reject_type(), $message);
+};
+
+sub get_reject_type {
+    my $self = shift;
+    my $default = shift || DENY;
+    my $deny = $self->{_args}{reject_type} or return $default;
+
+    return $deny =~ /^(temp|soft)$/i  ? DENYSOFT
+         : $deny =~ /^(perm|hard)$/i  ? DENY
+         : $deny eq 'disconnect'      ? DENY_DISCONNECT
+         : $deny eq 'temp_disconnect' ? DENYSOFT_DISCONNECT
+         : $default;
+};
+
+sub is_immune {
+    my $self = shift;
+
+    if ( $self->qp->connection->relay_client() ) {
+        # set by plugins/relay, or Qpsmtpd::Auth
+        $self->log(LOGINFO, "skip, relay client");
+        return 1;
+    };
+    if ( $self->qp->connection->notes('whitelisthost') ) {
+        # set by plugins/dns_whitelist_soft or plugins/whitelist
+        $self->log(LOGINFO, "skip, whitelisted host");
+        return 1;
+    };
+    if ( $self->qp->transaction->notes('whitelistsender') ) {
+        # set by plugins/whitelist
+        $self->log(LOGINFO, "skip, whitelisted sender");
+        return 1;
+    };
+    if ( $self->connection->notes('naughty') ) {
+        # see plugins/naughty
+        $self->log(LOGINFO, "skip, naughty");
+        return 1;
+    };
+    if ( $self->connection->notes('rejected') ) {
+        # http://www.steve.org.uk/Software/ms-lite/
+        $self->log(LOGINFO, "skip, already rejected");
+        return 1;
+    };
+    return;
+};
+
+sub _register_standard_hooks {
+  my ($plugin, $qp) = @_;
+
+  for my $hook (@hooks) {
+    my $hooksub = "hook_$hook";
+    $hooksub  =~ s/\W/_/g;
+    $plugin->register_hook( $hook, $hooksub )
+      if ($plugin->can($hooksub));
+  }
+}
+
+
+1;

lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm

@@ -0,0 +1,87 @@
+package Qpsmtpd::Plugin::Async::DNSBLBase;
+
+# Class methods shared by the async plugins using DNS based blacklists or
+# whitelists.
+
+use strict;
+use Qpsmtpd::Constants;
+use ParaDNS;
+
+sub lookup {
+    my ($class, $qp, $A_lookups, $TXT_lookups) = @_;
+
+    my $total_zones = @$A_lookups + @$TXT_lookups;
+
+    my ($A_pdns, $TXT_pdns);
+
+    if (@$A_lookups) {
+        $qp->log(LOGDEBUG, "Checking ",
+                 join(", ", @$A_lookups),
+                 " for A record in the background");
+
+        $A_pdns = ParaDNS->new(
+            callback => sub {
+                my ($result, $query) = @_;
+                return if $result !~ /^\d+\.\d+\.\d+\.\d+$/;
+                $qp->log(LOGDEBUG, "Result for A $query: $result");
+                $class->process_a_result($qp, $result, $query);
+            },
+            finished => sub {
+                $total_zones -= @$A_lookups;
+                $class->finished($qp, $total_zones);
+            },
+            hosts  => [@$A_lookups],
+            type   => 'A',
+            client => $qp->input_sock,
+                              );
+
+        return unless defined $A_pdns;
+    }
+
+    if (@$TXT_lookups) {
+        $qp->log(LOGDEBUG, "Checking ",
+                 join(", ", @$TXT_lookups),
+                 " for TXT record in the background");
+
+        $TXT_pdns = ParaDNS->new(
+            callback => sub {
+                my ($result, $query) = @_;
+                return if $result !~ /[a-z]/;
+                $qp->log(LOGDEBUG, "Result for TXT $query: $result");
+                $class->process_txt_result($qp, $result, $query);
+            },
+            finished => sub {
+                $total_zones -= @$TXT_lookups;
+                $class->finished($qp, $total_zones);
+            },
+            hosts  => [@$TXT_lookups],
+            type   => 'TXT',
+            client => $qp->input_sock,
+                                );
+
+        unless (defined $TXT_pdns) {
+            undef $A_pdns;
+            return;
+        }
+    }
+
+    return 1;
+}
+
+sub finished {
+    my ($class, $qp, $total_zones) = @_;
+    $qp->log(LOGDEBUG, "Finished ($total_zones)");
+    $qp->run_continuation unless $total_zones;
+}
+
+# plugins should implement the following two methods to do something
+# useful with the results
+sub process_a_result {
+    my ($class, $qp, $result, $query) = @_;
+}
+
+sub process_txt_result {
+    my ($class, $qp, $result, $query) = @_;
+}
+
+1;

lib/Qpsmtpd/PollServer.pm

@@ -0,0 +1,349 @@
+package Qpsmtpd::PollServer;
+
+use base ('Danga::Client', 'Qpsmtpd::SMTP');
+# use fields required to be a subclass of Danga::Client. Have to include
+# all fields used by Qpsmtpd.pm here too.
+use fields qw(
+    input_sock
+    mode
+    header_lines
+    in_header
+    data_size
+    max_size
+    hooks
+    start_time
+    cmd_timeout
+    conn
+    _auth
+    _auth_mechanism
+    _auth_state
+    _auth_ticket
+    _auth_user
+    _commands
+    _config_cache
+    _connection
+    _continuation
+    _extras
+    _test_mode
+    _transaction
+);
+use Qpsmtpd::Constants;
+use Qpsmtpd::Address;
+use ParaDNS;
+use Mail::Header;
+use POSIX qw(strftime);
+use Socket qw(inet_aton AF_INET CRLF);
+use Time::HiRes qw(time);
+use strict;
+
+sub max_idle_time { 60 }
+sub max_connect_time { 1200 }
+
+sub input_sock {
+    my $self = shift;
+    @_ and $self->{input_sock} = shift;
+    $self->{input_sock} || $self;
+}
+
+sub new {
+    my Qpsmtpd::PollServer $self = shift;
+    
+    $self = fields::new($self) unless ref $self;
+    $self->SUPER::new( @_ );
+    $self->{cmd_timeout} = 5;
+    $self->{start_time} = time;
+    $self->{mode} = 'connect';
+    $self->load_plugins;
+    $self->load_logging;
+
+    my ($rc, @msg) = $self->run_hooks_no_respond("pre-connection");
+    if ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) {
+        @msg = ("Sorry, try again later")
+          unless @msg;
+        $self->respond(451, @msg);
+        $self->disconnect;
+    }
+    elsif ($rc == DENY || $rc == DENY_DISCONNECT) {
+        @msg = ("Sorry, service not available for you")
+          unless @msg;
+        $self->respond(550, @msg);
+        $self->disconnect;
+    }
+
+    return $self;
+}
+
+sub uptime {
+    my Qpsmtpd::PollServer $self = shift;
+    
+    return (time() - $self->{start_time});
+}
+
+sub reset_for_next_message {
+    my Qpsmtpd::PollServer $self = shift;
+    $self->SUPER::reset_for_next_message(@_);
+    
+    $self->{_commands} = {
+        ehlo => 1,
+        helo => 1,
+        rset => 1,
+        mail => 1,
+        rcpt => 1,
+        data => 1,
+        help => 1,
+        vrfy => 1,
+        noop => 1,
+        quit => 1,
+        auth => 0, # disabled by default
+    };
+    $self->{mode} = 'cmd';
+    $self->{_extras} = {};
+}
+
+sub respond {
+    my Qpsmtpd::PollServer $self = shift;
+    my ($code, @messages) = @_;
+    while (my $msg = shift @messages) {
+        my $line = $code . (@messages ? "-" : " ") . $msg;
+        $self->write("$line\r\n");
+    }
+    return 1;
+}
+
+sub fault {
+    my Qpsmtpd::PollServer $self = shift;
+    $self->SUPER::fault(@_);
+    return;
+}
+
+my %cmd_cache;
+
+sub process_line {
+    my Qpsmtpd::PollServer $self = shift;
+    my $line = shift || return;
+    if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; }
+    if ($self->{mode} eq 'cmd') {
+        $line =~ s/\r?\n$//s;
+        $self->connection->notes('original_string', $line);
+        my ($cmd, @params) = split(/ +/, $line, 2);
+        my $meth = lc($cmd);
+        if (my $lookup = $cmd_cache{$meth} || $self->{_commands}->{$meth} && $self->can($meth)) {
+            $cmd_cache{$meth} = $lookup;
+            eval {
+                $lookup->($self, @params);
+            };
+            if ($@) {
+                my $error = $@;
+                chomp($error);
+                $self->log(LOGERROR, "Command Error: $error");
+                $self->fault("command '$cmd' failed unexpectedly");
+            }
+        }
+        else {
+            # No such method - i.e. unrecognized command
+            my ($rc, $msg) = $self->run_hooks("unrecognized_command", $meth, @params);
+        }
+    }
+    elsif ($self->{mode} eq 'connect') {
+        $self->{mode} = 'cmd';
+        # I've removed an eval{} from around this. It shouldn't ever die()
+        # but if it does we're a bit screwed... Ah well :-)
+        $self->start_conversation;
+    }
+    else {
+        die "Unknown mode";
+    }
+    return;
+}
+
+sub disconnect {
+    my Qpsmtpd::PollServer $self = shift;
+    $self->SUPER::disconnect(@_);
+    $self->close;
+}
+
+sub close {
+    my Qpsmtpd::PollServer $self = shift;
+    $self->run_hooks_no_respond("post-connection");
+    $self->connection->reset;
+    $self->SUPER::close;
+}
+
+sub start_conversation {
+    my Qpsmtpd::PollServer $self = shift;
+    
+    my $conn = $self->connection;
+    # set remote_host, remote_ip and remote_port
+    my ($ip, $port) = split(':', $self->peer_addr_string);
+    return $self->close() unless $ip;
+    $conn->remote_ip($ip);
+    $conn->remote_port($port);
+    $conn->remote_info("[$ip]");
+    my ($lip,$lport) = split(':', $self->local_addr_string);
+    $conn->local_ip($lip);
+    $conn->local_port($lport);
+    
+    ParaDNS->new(
+        finished   => sub { $self->continue_read(); $self->run_hooks("connect") },
+        # NB: Setting remote_info to the same as remote_host
+        callback   => sub { $conn->remote_info($conn->remote_host($_[0])) },
+        host       => $ip,
+    );
+    
+    return;
+}
+
+sub data {
+    my Qpsmtpd::PollServer $self = shift;
+    
+    my ($rc, $msg) = $self->run_hooks("data");
+    return 1;
+}
+
+sub data_respond {
+    my Qpsmtpd::PollServer $self = shift;
+    my ($rc, $msg) = @_;
+    if ($rc == DONE) {
+        return;
+    }
+    elsif ($rc == DENY) {
+        $msg->[0] ||= "Message denied";
+        $self->respond(554, @$msg);
+        $self->reset_transaction();
+        return;
+    }
+    elsif ($rc == DENYSOFT) {
+        $msg->[0] ||= "Message denied temporarily";
+        $self->respond(451, @$msg);
+        $self->reset_transaction();
+        return;
+    } 
+    elsif ($rc == DENY_DISCONNECT) {
+        $msg->[0] ||= "Message denied";
+        $self->respond(554, @$msg);
+        $self->disconnect;
+        return;
+    }
+    elsif ($rc == DENYSOFT_DISCONNECT) {
+        $msg->[0] ||= "Message denied temporarily";
+        $self->respond(451, @$msg);
+        $self->disconnect;
+        return;
+    }
+    return $self->respond(503, "MAIL first") unless $self->transaction->sender;
+    return $self->respond(503, "RCPT first") unless $self->transaction->recipients;
+    
+    $self->{header_lines} = '';
+    $self->{data_size} = 0;
+    $self->{in_header} = 1;
+    $self->{max_size} = ($self->config('databytes'))[0] || 0;
+    
+    $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}");
+
+    $self->respond(354, "go ahead");
+
+    my $max_get = $self->{max_size} || 1048576;
+    $self->get_chunks($max_get, sub { $self->got_data($_[0]) });
+    return 1;
+}
+
+sub got_data {
+    my Qpsmtpd::PollServer $self = shift;
+    my $data = shift;
+
+    my $done = 0;
+    my $remainder;
+    if ($data =~ s/^\.\r\n(.*)\z//ms) {
+        $remainder = $1;
+        $done = 1;
+    }
+
+    # add a transaction->blocked check back here when we have line by line plugin access...
+    unless (($self->{max_size} and $self->{data_size} > $self->{max_size})) {
+        $data =~ s/\r\n/\n/mg;
+        $data =~ s/^\.\./\./mg;
+        
+        if ($self->{in_header}) {
+            $self->{header_lines} .= $data;
+            
+            if ($self->{header_lines} =~ s/\n(\n.*)\z/\n/ms) {
+                $data = $1;
+                # end of headers
+                $self->{in_header} = 0;
+                
+                # ... need to check that we don't reformat any of the received lines.
+                #
+                # 3.8.2 Received Lines in Gatewaying
+                #   When forwarding a message into or out of the Internet environment, a
+                #   gateway MUST prepend a Received: line, but it MUST NOT alter in any
+                #   way a Received: line that is already in the header.
+                my @header_lines = split(/^/m, $self->{header_lines});
+    
+                my $header = Mail::Header->new(\@header_lines,
+                                                Modify => 0, MailFrom => "COERCE");
+                $self->transaction->header($header);
+                $self->transaction->body_write($self->{header_lines});
+                $self->{header_lines} = '';
+
+                #$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/");
+    
+                # FIXME - call plugins to work on just the header here; can
+                # save us buffering the mail content.
+            
+                # Save the start of just the body itself	
+                $self->transaction->set_body_start();
+            }
+        }
+
+        $self->transaction->body_write(\$data);
+        $self->{data_size} += length $data;
+    }
+ 
+
+    if ($done) {
+        $self->end_of_data;
+        $self->end_get_chunks($remainder);
+    }
+
+}
+
+sub end_of_data {
+    my Qpsmtpd::PollServer $self = shift;
+    
+    #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300);
+    
+    $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}");
+    
+    my $header = $self->transaction->header;
+    if (!$header) {
+        $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE");
+        $self->transaction->header($header);
+    }
+    
+    my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
+    my $esmtp = substr($smtp,0,1) eq "E";
+    my $authheader;
+    my $sslheader;
+    
+    if (defined $self->connection->notes('tls_enabled')
+            and $self->connection->notes('tls_enabled'))
+    {
+        $smtp .= "S" if $esmtp; # RFC3848
+        $sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) ";
+    }
+    
+    if (defined $self->{_auth} and $self->{_auth} == OK) {
+        $smtp .= "A" if $esmtp; # RFC3848
+        $authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n";
+    }
+    
+    $header->add("Received", $self->received_line($smtp, $authheader, $sslheader), 0);
+    
+    return $self->respond(552, "Message too big!") if $self->{max_size} and $self->{data_size} > $self->{max_size};
+    
+    my ($rc, $msg) = $self->run_hooks("data_post");
+    return 1;
+}
+
+1;
+

lib/Qpsmtpd/Postfix.pm

@@ -0,0 +1,223 @@
+package Qpsmtpd::Postfix;
+
+=head1 NAME
+
+Qpsmtpd::Postfix - postfix queueing support for qpsmtpd
+
+=head2 DESCRIPTION
+
+This package implements the protocol Postfix servers use to communicate
+with each other. See src/global/rec_type.h in the postfix source for
+details.
+
+=cut
+
+use strict;
+use IO::Socket::UNIX;
+use IO::Socket::INET;
+use vars qw(@ISA);
+@ISA = qw(IO::Socket::UNIX);
+
+my %rec_types;
+
+sub init {
+  my ($self) = @_;
+
+  %rec_types = (
+    REC_TYPE_SIZE    => 'C',	# first record, created by cleanup
+    REC_TYPE_TIME    => 'T',	# time stamp, required
+    REC_TYPE_FULL    => 'F',	# full name, optional
+    REC_TYPE_INSP    => 'I',	# inspector transport
+    REC_TYPE_FILT    => 'L',	# loop filter transport
+    REC_TYPE_FROM    => 'S',	# sender, required
+    REC_TYPE_DONE    => 'D',	# delivered recipient, optional
+    REC_TYPE_RCPT    => 'R',	# todo recipient, optional
+    REC_TYPE_ORCP    => 'O',	# original recipient, optional
+    REC_TYPE_WARN    => 'W',	# warning message time
+    REC_TYPE_ATTR    => 'A',	# named attribute for extensions
+
+    REC_TYPE_MESG    => 'M',	# start message records
+
+    REC_TYPE_CONT    => 'L',	# long data record
+    REC_TYPE_NORM    => 'N',	# normal data record
+
+    REC_TYPE_XTRA    => 'X',	# start extracted records
+
+    REC_TYPE_RRTO    => 'r',	# return-receipt, from headers
+    REC_TYPE_ERTO    => 'e',	# errors-to, from headers
+    REC_TYPE_PRIO    => 'P',	# priority
+    REC_TYPE_VERP    => 'V',	# VERP delimiters
+
+    REC_TYPE_END     => 'E',	# terminator, required
+
+  );
+
+}
+
+sub print_rec {
+  my ($self, $type, @list) = @_;
+
+  die "unknown record type" unless ($rec_types{$type});
+  $self->print($rec_types{$type});
+
+  # the length is a little endian base-128 number where each 
+  # byte except the last has the high bit set:
+  my $s = "@list";
+  my $ln = length($s);
+  while ($ln >= 0x80) {
+    my $lnl = $ln & 0x7F;
+    $ln >>= 7;
+    $self->print(chr($lnl | 0x80));
+  }
+  $self->print(chr($ln));
+
+  $self->print($s);
+}
+
+sub print_rec_size {
+  my ($self, $content_size, $data_offset, $rcpt_count) = @_;
+
+  my $s = sprintf("%15ld %15ld %15ld", $content_size, $data_offset, $rcpt_count);
+  $self->print_rec('REC_TYPE_SIZE', $s);
+}
+
+sub print_rec_time {
+  my ($self, $time) = @_;
+
+  $time = time() unless (defined($time));
+
+  my $s = sprintf("%d", $time);
+  $self->print_rec('REC_TYPE_TIME', $s);
+}
+
+sub open_cleanup {
+  my ($class, $socket) = @_;
+
+  my $self;
+  if ($socket =~ m#^(/.+)#) {
+    $socket = $1; # un-taint socket path
+    $self = IO::Socket::UNIX->new(Type => SOCK_STREAM,
+                                  Peer => $socket) if $socket;
+    
+  } elsif ($socket =~ /(.*):(\d+)/) {
+    my ($host,$port) = ($1,$2); # un-taint address and port
+    $self = IO::Socket::INET->new(Proto => 'tcp',
+                                  PeerAddr => $host,PeerPort => $port)
+      if $host and $port;
+  }
+  unless (ref $self) {
+    warn "Couldn't open \"$socket\": $!";
+    return;
+  }
+  # allow buffered writes
+  $self->autoflush(0);
+  bless ($self, $class);
+  $self->init();
+  return $self;
+}
+
+sub print_attr {
+  my ($self, @kv) = @_;
+  for (@kv) {
+    $self->print("$_\0");
+  }
+  $self->print("\0");
+}
+
+sub get_attr {
+  my ($self) = @_;
+  local $/ = "\0";
+  my %kv;
+  for(;;) {
+    my $k = $self->getline;
+    chomp($k);
+    last unless ($k);
+    my $v = $self->getline;
+    chomp($v);
+    $kv{$k} = $v;
+  }
+  return %kv;
+}
+
+
+=head2 print_msg_line($line)
+
+print one line of a message to cleanup.
+
+This removes any linefeed characters from the end of the line
+and splits the line across several records if it is longer than
+1024 chars. 
+
+=cut
+
+sub print_msg_line {
+  my ($self, $line) = @_;
+
+  $line =~ s/\r?\n$//s;
+
+  # split into 1k chunks. 
+  while (length($line) > 1024) {
+    my $s = substr($line, 0, 1024);
+    $line = substr($line, 1024);
+    $self->print_rec('REC_TYPE_CONT', $s);
+  }
+  $self->print_rec('REC_TYPE_NORM', $line);
+}
+
+=head2 inject_mail($transaction)
+
+(class method) inject mail in $transaction into postfix queue via cleanup.
+$transaction is supposed to be a Qpsmtpd::Transaction object.
+
+=cut
+
+sub inject_mail {
+  my ($class, $transaction) = @_;
+
+  my @sockets = @{$transaction->notes('postfix-queue-sockets')
+                  // ['/var/spool/postfix/public/cleanup']};
+  my $strm;
+  $strm = $class->open_cleanup($_) and last for @sockets;
+  die "Unable to open any cleanup sockets!" unless $strm;
+
+  my %at = $strm->get_attr;
+  my $qid = $at{queue_id};
+  print STDERR "qid=$qid\n";
+  $strm->print_attr('flags' => $transaction->notes('postfix-queue-flags'));
+  $strm->print_rec_time();
+  $strm->print_rec('REC_TYPE_FROM', $transaction->sender->address|| "");
+  for (map { $_->address } $transaction->recipients) {
+    $strm->print_rec('REC_TYPE_RCPT', $_);
+  }
+  # add an empty message length record.
+  # cleanup is supposed to understand that.
+  # see src/pickup/pickup.c
+  $strm->print_rec('REC_TYPE_MESG', "");
+
+  # a received header has already been added in SMTP.pm
+  # so we can just copy the message:
+
+  my $hdr = $transaction->header->as_string;
+  for (split(/\r?\n/, $hdr)) {
+    print STDERR "hdr: $_\n";
+    $strm->print_msg_line($_);
+  }
+  $transaction->body_resetpos;
+  while (my $line = $transaction->body_getline) {
+    # print STDERR "body: $line\n";
+    $strm->print_msg_line($line);
+  }
+
+  # finish it.
+  $strm->print_rec('REC_TYPE_XTRA', "");
+  $strm->print_rec('REC_TYPE_END', "");
+  $strm->flush();
+  %at = $strm->get_attr;
+  my $status = $at{status};
+  my $reason = $at{reason};
+  $strm->close();
+  return wantarray ? ($status, $qid, $reason || "") : $status;
+}
+
+1;
+# vim:sw=2

lib/Qpsmtpd/Postfix/Constants.pm

@@ -0,0 +1,86 @@
+#
+# Qpsmtpd::Postfix::Constants
+#
+# This is a generated file, do not edit
+#
+# created by pf2qp.pl v0.1 @ Sun Oct 29 09:10:18 2006
+# postfix version 2.4
+#
+package Qpsmtpd::Postfix::Constants;
+
+use Qpsmtpd::Constants;
+
+require Exporter;
+
+use vars qw(@ISA @EXPORT %cleanup_soft %cleanup_hard $postfix_version);
+use strict;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(
+	%cleanup_soft
+	%cleanup_hard
+	$postfix_version
+	CLEANUP_FLAG_NONE
+	CLEANUP_FLAG_BOUNCE
+	CLEANUP_FLAG_FILTER
+	CLEANUP_FLAG_HOLD
+	CLEANUP_FLAG_DISCARD
+	CLEANUP_FLAG_BCC_OK
+	CLEANUP_FLAG_MAP_OK
+	CLEANUP_FLAG_MILTER
+	CLEANUP_FLAG_FILTER_ALL
+	CLEANUP_FLAG_MASK_EXTERNAL
+	CLEANUP_FLAG_MASK_INTERNAL
+	CLEANUP_FLAG_MASK_EXTRA
+	CLEANUP_STAT_OK
+	CLEANUP_STAT_BAD
+	CLEANUP_STAT_WRITE
+	CLEANUP_STAT_SIZE
+	CLEANUP_STAT_CONT
+	CLEANUP_STAT_HOPS
+	CLEANUP_STAT_RCPT
+	CLEANUP_STAT_PROXY
+	CLEANUP_STAT_DEFER
+	CLEANUP_STAT_MASK_CANT_BOUNCE
+	CLEANUP_STAT_MASK_INCOMPLETE
+);
+
+$postfix_version = "2.4";
+use constant CLEANUP_FLAG_NONE => 0; # /* No special features */ 
+use constant CLEANUP_FLAG_BOUNCE => (1<<0); # /* Bounce bad messages */ 
+use constant CLEANUP_FLAG_FILTER => (1<<1); # /* Enable header/body checks */ 
+use constant CLEANUP_FLAG_HOLD => (1<<2); # /* Place message on hold */ 
+use constant CLEANUP_FLAG_DISCARD => (1<<3); # /* Discard message silently */ 
+use constant CLEANUP_FLAG_BCC_OK => (1<<4); # /* Ok to add auto-BCC addresses */ 
+use constant CLEANUP_FLAG_MAP_OK => (1<<5); # /* Ok to map addresses */ 
+use constant CLEANUP_FLAG_MILTER => (1<<6); # /* Enable Milter applications */ 
+use constant CLEANUP_FLAG_FILTER_ALL => (CLEANUP_FLAG_FILTER | CLEANUP_FLAG_MILTER); 
+use constant CLEANUP_FLAG_MASK_EXTERNAL => (CLEANUP_FLAG_FILTER_ALL | CLEANUP_FLAG_BCC_OK | CLEANUP_FLAG_MAP_OK); 
+use constant CLEANUP_FLAG_MASK_INTERNAL => CLEANUP_FLAG_MAP_OK; 
+use constant CLEANUP_FLAG_MASK_EXTRA => (CLEANUP_FLAG_HOLD | CLEANUP_FLAG_DISCARD); 
+
+use constant CLEANUP_STAT_OK => 0; # /* Success. */ 
+use constant CLEANUP_STAT_BAD => (1<<0); # /* Internal protocol error */ 
+use constant CLEANUP_STAT_WRITE => (1<<1); # /* Error writing message file */ 
+use constant CLEANUP_STAT_SIZE => (1<<2); # /* Message file too big */ 
+use constant CLEANUP_STAT_CONT => (1<<3); # /* Message content rejected */ 
+use constant CLEANUP_STAT_HOPS => (1<<4); # /* Too many hops */ 
+use constant CLEANUP_STAT_RCPT => (1<<6); # /* No recipients found */ 
+use constant CLEANUP_STAT_PROXY => (1<<7); # /* Proxy reject */ 
+use constant CLEANUP_STAT_DEFER => (1<<8); # /* Temporary reject */ 
+use constant CLEANUP_STAT_MASK_CANT_BOUNCE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_DEFER); 
+use constant CLEANUP_STAT_MASK_INCOMPLETE => (CLEANUP_STAT_BAD | CLEANUP_STAT_WRITE | CLEANUP_STAT_SIZE | CLEANUP_STAT_DEFER); 
+
+%cleanup_soft = (
+    CLEANUP_STAT_DEFER =>  "service unavailable (#4.7.1)",
+    CLEANUP_STAT_PROXY =>  "queue file write error (#4.3.0)",
+    CLEANUP_STAT_BAD =>  "internal protocol error (#4.3.0)",
+    CLEANUP_STAT_WRITE =>  "queue file write error (#4.3.0)",
+);
+%cleanup_hard = (
+    CLEANUP_STAT_RCPT =>  "no recipients specified (#5.1.0)",
+    CLEANUP_STAT_HOPS =>  "too many hops (#5.4.0)",
+    CLEANUP_STAT_SIZE =>  "message file too big (#5.3.4)",
+    CLEANUP_STAT_CONT =>  "message content rejected (#5.7.1)",
+);
+1;

lib/Qpsmtpd/Postfix/pf2qp.pl

@@ -0,0 +1,115 @@
+#/usr/bin/perl -w
+#
+#
+my $version = "0.1";
+$0 =~ s#.*/##;
+my $path = $&; # sneaky way to get path back
+
+my $POSTFIX_SRC = shift || die <<"EOF";
+Usage:
+  $0 /path/to/postfix/source
+
+EOF
+
+my $header  = "$POSTFIX_SRC/src/global/cleanup_user.h";
+my $src     = "$POSTFIX_SRC/src/global/cleanup_strerror.c";
+my $pf_vers = "$POSTFIX_SRC/src/global/mail_version.h";
+my $postfix_version = "";
+
+open VERS, $pf_vers
+  or die "Could not open $pf_vers: $!\n";
+while (<VERS>) {
+    next unless /^\s*#\s*define\s+MAIL_VERSION_NUMBER\s+"(.+)"\s*$/;
+    $postfix_version = $1;
+    last;
+}
+close VERS;
+$postfix_version =~ s/^(\d+\.\d+).*/$1/;
+if ($postfix_version < 2.3) {
+    die "Need at least postfix v2.3";
+}
+my $start = <<'_END';
+#
+# Qpsmtpd::Postfix::Constants
+#
+# This is a generated file, do not edit
+#
+_END
+$start .= "# created by $0 v$version @ ".scalar(gmtime)."\n"
+         ."# postfix version $postfix_version\n"
+         ."#\n";
+$start .= <<'_END';
+package Qpsmtpd::Postfix::Constants;
+
+use Qpsmtpd::Constants;
+
+require Exporter;
+
+use vars qw(@ISA @EXPORT %cleanup_soft %cleanup_hard $postfix_version);
+use strict;
+
+@ISA = qw(Exporter);
+_END
+
+my @export = qw(%cleanup_soft %cleanup_hard $postfix_version);
+my @out = ();
+
+open HEAD, $header
+  or die "Could not open $header: $!\n";
+
+while (<HEAD>) {
+    while (s/\\\n$//) {
+        $_ .= <HEAD>;
+    }
+    chomp;
+    if (/^\s*#define\s/) {
+        s/^\s*#define\s*//;
+        next if /^_/;
+        s#(/\*.*\*/)##;
+        my $comment = $1 || "";
+        my @words = split ' ', $_;
+        my $const = shift @words;
+        if ($const eq "CLEANUP_STAT_OK") {
+            push @out, "";
+        }
+        push @export, $const;
+        push @out, "use constant $const => ". join(" ", @words). "; " 
+               .($comment ? "# $comment ": "");
+    }
+}
+close HEAD;
+
+open SRC, $src
+  or die "Could not open $src: $!\n";
+my $data;
+{ 
+  local $/ = undef;
+  $data = <SRC>;
+}
+close SRC;
+$data =~ s/.*cleanup_stat_map\[\]\s*=\s*{\s*\n//s;
+$data =~ s/};.*$//s;
+my @array = split "\n", $data;
+my (@denysoft,@denyhard);
+foreach (@array) {
+    chomp;
+    s/,/ => /;
+    s/"(\d\.\d\.\d)",\s+"(.*)",/"$2 (#$1)",/;
+    s!(/\*.*\*/)!# $1!;
+    s/4\d\d,\s// && push @denysoft, $_;
+    s/5\d\d,\s// && push @denyhard, $_;
+}
+
+open my $CONSTANTS, '>', "$path/Constants.pm";
+
+print ${CONSTANTS} $start, '@EXPORT = qw(', "\n";
+while (@export) {
+    print ${CONSTANTS} "\t", shift @export, "\n";
+}
+print ${CONSTANTS} ");\n\n", 
+       "\$postfix_version = \"$postfix_version\";\n",
+       join("\n", @out),"\n\n";
+print ${CONSTANTS} "\%cleanup_soft = (\n", join("\n", @denysoft), "\n);\n\n";
+print ${CONSTANTS} "\%cleanup_hard = (\n", join("\n", @denyhard), "\n);\n\n1;\n";
+
+close $CONSTANTS;

lib/Qpsmtpd/SMTP.pm

@@ -0,0 +1,854 @@
+package Qpsmtpd::SMTP;
+use Qpsmtpd;
+@ISA = qw(Qpsmtpd);
+my %auth_mechanisms = ();
+
+package Qpsmtpd::SMTP;
+use strict;
+use Carp;
+
+use Qpsmtpd::Connection;
+use Qpsmtpd::Transaction;
+use Qpsmtpd::Plugin;
+use Qpsmtpd::Constants;
+use Qpsmtpd::Auth;
+use Qpsmtpd::Address ();
+use Qpsmtpd::Command;
+
+use Mail::Header ();
+#use Data::Dumper;
+use POSIX qw(strftime);
+use Net::DNS;
+
+# this is only good for forkserver
+# can't set these here, cause forkserver resets them
+#$SIG{ALRM} = sub { respond(421, "Game over pal, game over. You got a timeout; I just can't wait that long..."); exit };
+#$SIG{ALRM} = sub { warn "Connection Timed Out\n"; exit; };
+
+sub new {
+  my $proto = shift;
+  my $class = ref($proto) || $proto;
+
+  my %args = @_;
+
+  my $self = bless ({ args => \%args }, $class);
+
+  my (@commands) = qw(ehlo helo rset mail rcpt data help vrfy noop quit);
+  my (%commands); @commands{@commands} = ('') x @commands;
+  # this list of valid commands should probably be a method or a set of methods
+  $self->{_commands} = \%commands;
+  $self->SUPER::_restart(%args) if $args{restart}; # calls Qpsmtpd::_restart()
+  $self;
+}
+
+sub command_counter {
+  my $self = shift;
+  $self->{_counter} || 0;
+}
+
+sub dispatch {
+  my $self = shift;
+  my ($cmd) = lc shift;
+
+  $self->{_counter}++; 
+
+  if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) {
+    $self->run_hooks("unrecognized_command", $cmd, @_);
+    return 1;
+  }
+  $cmd = $1;
+
+    my ($result) = eval { $self->$cmd(@_) };
+    $self->log(LOGERROR, "XX: $@") if $@;
+    return $result if defined $result;
+    return $self->fault("command '$cmd' failed unexpectedly");
+}
+
+sub unrecognized_command_respond {
+    my ($self, $rc, $msg) = @_;
+    if ($rc == DENY_DISCONNECT) {
+      $self->respond(521, @$msg);
+      $self->disconnect;
+    }
+    elsif ($rc == DENY) {
+      $self->respond(500, @$msg);
+    }
+    elsif ($rc != DONE) {
+      $self->respond(500, "Unrecognized command");
+    }
+}
+
+sub fault {
+  my $self = shift;
+  my ($msg) = shift || "program fault - command not performed";
+  my ($name) = split /\s+/, $0, 2;
+  print STDERR $name,"[$$]: $msg ($!)\n";
+  return $self->respond(451, "Internal error - try again later - " . $msg);
+}
+
+
+sub start_conversation {
+    my $self = shift;
+    # this should maybe be called something else than "connect", see
+    # lib/Qpsmtpd/TcpServer.pm for more confusion.
+    $self->run_hooks("connect");
+    return DONE;
+}
+
+sub connect_respond {
+    my ($self, $rc, $msg) = @_;
+    if ($rc == DENY || $rc == DENY_DISCONNECT) {
+      $msg->[0] ||= 'Connection from you denied, bye bye.';
+      $self->respond(550, @$msg);
+      $self->disconnect;
+    }
+    elsif ($rc == DENYSOFT || $rc == DENYSOFT_DISCONNECT) {
+      $msg->[0] ||= 'Connection from you temporarily denied, bye bye.';
+      $self->respond(450, @$msg);
+      $self->disconnect;
+    }
+    elsif ($rc != DONE) {
+      my $greets = $self->config('smtpgreeting');
+      if ( $greets ) {
+	  $greets .= " ESMTP" unless $greets =~ /(^|\W)ESMTP(\W|$)/;
+      }
+      else {
+	  $greets = $self->config('me') 
+	    . " ESMTP qpsmtpd " 
+	    . $self->version 
+	    . " ready; send us your mail, but not your spam.";
+      }
+
+      $self->respond(220, $greets);
+    }
+}
+
+sub transaction {
+  my $self = shift;
+  return $self->{_transaction} || $self->reset_transaction();
+}
+
+sub reset_transaction {
+  my $self = shift;
+  $self->run_hooks("reset_transaction") if $self->{_transaction};
+  return $self->{_transaction} = Qpsmtpd::Transaction->new();
+}
+
+
+sub connection {
+  my $self = shift;
+  @_ and $self->{_connection} = shift;
+  return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new());
+}
+
+sub helo {
+  my ($self, $line) = @_;
+  my ($rc, @msg) = $self->run_hooks('helo_parse');
+  my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('helo', $line, $msg[0]);
+
+  return $self->respond (501,
+    "helo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host;
+  my $conn = $self->connection;
+  return $self->respond (503, "but you already said HELO ...") if $conn->hello;
+
+  $self->run_hooks("helo", $hello_host, @stuff);
+}
+
+sub helo_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  my ($hello_host) = @$args;
+  if ($rc == DONE) {
+    # do nothing:
+    1;
+  } elsif ($rc == DENY) {
+    $self->respond(550, @$msg);
+  } elsif ($rc == DENYSOFT) {
+    $self->respond(450, @$msg);
+  } elsif ($rc == DENY_DISCONNECT) {
+      $self->respond(550, @$msg);
+      $self->disconnect;
+  } elsif ($rc == DENYSOFT_DISCONNECT) {
+      $self->respond(450, @$msg);
+      $self->disconnect;
+  } else {
+    my $conn = $self->connection;
+    $conn->hello("helo");
+    $conn->hello_host($hello_host);
+    $self->transaction;
+    $self->respond(250, $self->config('me') ." Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]; I am so happy to meet you.");
+  }
+}
+
+sub ehlo {
+  my ($self, $line) = @_;
+  my ($rc, @msg) = $self->run_hooks('ehlo_parse');
+  my ($ok, $hello_host, @stuff) = Qpsmtpd::Command->parse('ehlo', $line, $msg[0]);
+  return $self->respond (501,
+    "ehlo requires domain/address - see RFC-2821 4.1.1.1") unless $hello_host;
+  my $conn = $self->connection;
+  return $self->respond (503, "but you already said HELO ...") if $conn->hello;
+
+  $self->run_hooks("ehlo", $hello_host, @stuff);
+}
+
+sub ehlo_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  my ($hello_host) = @$args;
+  if ($rc == DONE) {
+    # do nothing:
+    1; 
+  } elsif ($rc == DENY) {
+    $self->respond(550, @$msg);
+  } elsif ($rc == DENYSOFT) {
+    $self->respond(450, @$msg);
+  } elsif ($rc == DENY_DISCONNECT) {
+      $self->respond(550, @$msg);
+      $self->disconnect;
+  } elsif ($rc == DENYSOFT_DISCONNECT) {
+      $self->respond(450, @$msg);
+      $self->disconnect;
+  } else {
+    my $conn = $self->connection;
+    $conn->hello("ehlo");
+    $conn->hello_host($hello_host);
+    $self->transaction;
+
+    my @capabilities = $self->transaction->notes('capabilities')
+                        ? @{ $self->transaction->notes('capabilities') }
+                        : ();  
+
+    # Check for possible AUTH mechanisms
+HOOK: foreach my $hook ( keys %{$self->hooks} ) {
+        if ( $hook =~ m/^auth-?(.+)?$/ ) {
+            if ( defined $1 ) {
+                $auth_mechanisms{uc($1)} = 1;
+            }
+            else { # at least one polymorphous auth provider
+                %auth_mechanisms = map {$_,1} qw(PLAIN CRAM-MD5 LOGIN);
+                last HOOK;
+            }
+        }
+    }
+
+    # Check if we should only offer AUTH after TLS is completed
+    my $tls_before_auth = ($self->config('tls_before_auth') ? ($self->config('tls_before_auth'))[0] && $self->transaction->notes('tls_enabled') : 0); 
+    if ( %auth_mechanisms && !$tls_before_auth) {
+        push @capabilities, 'AUTH '.join(" ",keys(%auth_mechanisms));    
+        $self->{_commands}->{'auth'} = "";
+    }
+
+    $self->respond(250,
+                 $self->config("me") . " Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]",
+                 "PIPELINING",
+                 "8BITMIME",
+                 ($self->config('databytes') ? "SIZE ". ($self->config('databytes'))[0] : ()),
+                 @capabilities,  
+                );
+  }
+}
+
+sub auth {
+    my ($self, $line) = @_;
+    $self->run_hooks('auth_parse', $line);
+}
+
+sub auth_parse_respond {
+    my ($self, $rc, $msg, $args) = @_;
+    my ($line) = @$args;
+
+    my ($ok, $mechanism, @stuff) = Qpsmtpd::Command->parse('auth', $line, $msg->[0]);
+    return $self->respond(501, $mechanism || "Syntax error in command") 
+      unless ($ok == OK);
+
+    $mechanism = lc($mechanism);
+
+    #they AUTH'd once already
+    return $self->respond( 503, "but you already said AUTH ..." )
+      if ( defined $self->{_auth} && $self->{_auth} == OK );
+
+    return $self->respond( 503, "AUTH not defined for HELO" )
+      if ( $self->connection->hello eq "helo" );
+
+    return $self->respond( 503, "SSL/TLS required before AUTH" )
+      if ( ($self->config('tls_before_auth'))[0] 
+        && $self->transaction->notes('tls_enabled') );
+
+    # we don't have a plugin implementing this auth mechanism, 504
+    if( exists $auth_mechanisms{uc($mechanism)} ) {
+      return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $mechanism, @stuff );
+    };
+
+    $self->respond( 504, "Unimplemented authentification mechanism: $mechanism" );
+    return DENY;
+}
+
+sub mail {
+  my ($self, $line) = @_;
+  # -> from RFC2821
+  # The MAIL command (or the obsolete SEND, SOML, or SAML commands)
+  # begins a mail transaction.  Once started, a mail transaction
+  # consists of a transaction beginning command, one or more RCPT
+  # commands, and a DATA command, in that order.  A mail transaction
+  # may be aborted by the RSET (or a new EHLO) command.  There may be
+  # zero or more transactions in a session.  MAIL (or SEND, SOML, or
+  # SAML) MUST NOT be sent if a mail transaction is already open,
+  # i.e., it should be sent only if no mail transaction had been
+  # started in the session, or it the previous one successfully
+  # concluded with a successful DATA command, or if the previous one
+  # was aborted with a RSET.
+
+  # sendmail (8.11) rejects a second MAIL command.
+
+  # qmail-smtpd (1.03) accepts it and just starts a new transaction.
+  # Since we are a qmail-smtpd thing we will do the same.
+
+  $self->reset_transaction;
+  
+  unless ($self->connection->hello) {
+    return $self->respond(503, "please say hello first ...");
+  }
+  else {
+    $self->log(LOGDEBUG, "full from_parameter: $line");
+    $self->run_hooks("mail_parse", $line);
+  }
+}
+
+sub mail_parse_respond {
+    my ($self, $rc, $msg, $args) = @_;
+    my ($line) = @$args;
+    my ($ok, $from, @params) = Qpsmtpd::Command->parse('mail', $line, $msg->[0]);
+    return $self->respond(501, $from || "Syntax error in command") 
+      unless ($ok == OK); 
+    my %param;
+    foreach (@params) {
+        my ($k,$v) = split /=/, $_, 2;
+        $param{lc $k} = $v;
+    }
+    # to support addresses without <> we now require a plugin
+    # hooking "mail_pre" to 
+    #   return (OK, "<$from>"); 
+    # (...or anything else parseable by Qpsmtpd::Address ;-))
+    # see also comment in sub rcpt()
+    $self->run_hooks("mail_pre", $from, \%param);
+}
+
+sub mail_pre_respond {
+    my ($self, $rc, $msg, $args) = @_;
+    my ($from, $param) = @$args;
+    if ($rc == OK) {
+      $from = shift @$msg;
+    }
+
+    $self->log(LOGDEBUG, "from email address : [$from]");
+    return $self->respond(501, "could not parse your mail from command") 
+      unless $from =~ /^<.*>$/;
+
+    if ($from eq "<>" or $from =~ m/\[undefined\]/ or $from eq "<#@[]>") {
+      $from = Qpsmtpd::Address->new("<>");
+    } 
+    else {
+      $from = (Qpsmtpd::Address->parse($from))[0];
+    }
+    return $self->respond(501, "could not parse your mail from command") unless $from;
+
+    $self->run_hooks("mail", $from, %$param);
+}
+
+sub mail_respond {
+    my ($self, $rc, $msg, $args) = @_;
+    my ($from, $param) = @$args;
+    if ($rc == DONE) {
+      return 1;
+    }
+    elsif ($rc == DENY) {
+      $msg->[0] ||= $from->format . ', denied';
+      $self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)");
+      $self->respond(550, @$msg);
+    }
+    elsif ($rc == DENYSOFT) {
+      $msg->[0] ||= $from->format . ', temporarily denied';
+      $self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)");
+      $self->respond(450, @$msg);
+    }
+    elsif ($rc == DENY_DISCONNECT) {
+      $msg->[0] ||= $from->format . ', denied';
+      $self->log(LOGINFO, "deny mail from " . $from->format . " (@$msg)");
+      $self->respond(550, @$msg);
+      $self->disconnect;
+    }
+    elsif ($rc == DENYSOFT_DISCONNECT) {
+      $msg->[0] ||= $from->format . ', temporarily denied';
+      $self->log(LOGINFO, "denysoft mail from " . $from->format . " (@$msg)");
+      $self->respond(421, @$msg);
+      $self->disconnect;
+    }
+    else { # includes OK
+      $self->log(LOGDEBUG, "getting mail from ".$from->format);
+      $self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!");
+      $self->transaction->sender($from);
+    }
+}
+
+sub rcpt {
+  my ($self, $line) = @_;
+  $self->run_hooks("rcpt_parse", $line);
+}
+
+sub rcpt_parse_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  my ($line) = @$args;
+  my ($ok, $rcpt, @param) = Qpsmtpd::Command->parse("rcpt", $line, $msg->[0]);
+  return $self->respond(501, $rcpt || "Syntax error in command")
+    unless ($ok == OK);
+  return $self->respond(503, "Use MAIL before RCPT") unless $self->transaction->sender;
+
+  my %param;
+  foreach (@param) {
+    my ($k,$v) = split /=/, $_, 2;
+    $param{lc $k} = $v;
+  }
+  # to support addresses without <> we now require a plugin
+  # hooking "rcpt_pre" to 
+  #   return (OK, "<$rcpt>"); 
+  # (... or anything else parseable by Qpsmtpd::Address ;-))
+  # this means, a plugin can decide to (pre-)accept
+  # addresses like <user@example.com.> or <user@example.com >
+  # by removing the trailing "."/" " from this example...
+  $self->run_hooks("rcpt_pre", $rcpt, \%param);
+}
+
+sub rcpt_pre_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  my ($rcpt, $param) = @$args;
+  if ($rc == OK) {
+    $rcpt = shift @$msg;
+  }
+  $self->log(LOGDEBUG, "to email address : [$rcpt]");
+  return $self->respond(501, "could not parse recipient") 
+    unless $rcpt =~ /^<.*>$/;
+
+  $rcpt = (Qpsmtpd::Address->parse($rcpt))[0];
+
+  return $self->respond(501, "could not parse recipient") 
+    if (!$rcpt or ($rcpt->format eq '<>'));
+
+  $self->run_hooks("rcpt", $rcpt, %$param);
+}
+
+sub rcpt_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  my ($rcpt, $param) = @$args;
+  if ($rc == DONE) {
+    return 1;
+  }
+  elsif ($rc == DENY) {
+    $msg->[0] ||= 'relaying denied';
+    $self->respond(550, @$msg);
+  }
+  elsif ($rc == DENYSOFT) {
+    $msg->[0] ||= 'relaying denied';
+    return $self->respond(450, @$msg);
+  }
+  elsif ($rc == DENY_DISCONNECT) {
+      $msg->[0] ||= 'delivery denied';
+      $self->log(LOGINFO, "delivery denied (@$msg)");
+      $self->respond(550, @$msg);
+      $self->disconnect;
+  }
+  elsif ($rc == DENYSOFT_DISCONNECT) {
+    $msg->[0] ||= 'relaying denied';
+    $self->log(LOGINFO, "delivery denied (@$msg)");
+    $self->respond(421, @$msg);
+    $self->disconnect;
+  }
+  elsif ($rc == OK) {
+    $self->respond(250, $rcpt->format . ", recipient ok");
+    return $self->transaction->add_recipient($rcpt);
+  }
+  else {
+    return $self->respond(450, "No plugin decided if relaying is allowed");
+  }
+  return 0;
+}
+
+sub help {
+  my ($self, @args) = @_;
+  $self->run_hooks("help", @args);
+}
+
+sub help_respond {
+  my ($self, $rc, $msg, $args) = @_;
+
+  return 1 
+    if $rc == DONE;
+
+  if ($rc == DENY) {
+    $msg->[0] ||= "Syntax error, command not recognized";
+    $self->respond(500, @$msg);
+  }
+  else {
+    unless ($msg->[0]) {
+      @$msg = (
+        "This is qpsmtpd " . ($self->config('smtpgreeting') ? '' : $self->version),
+        "See http://smtpd.develooper.com/",
+        'To report bugs or send comments, mail to <ask@develooper.com>.');
+    }
+    $self->respond(214, @$msg);
+  }
+  return 1;
+}
+
+sub noop {
+  my $self = shift;
+  $self->run_hooks("noop");
+}
+
+sub noop_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  return 1 if $rc == DONE;
+
+  if ($rc == DENY || $rc == DENY_DISCONNECT) {
+    $msg->[0] ||= "Stop wasting my time."; # FIXME: better default message?
+    $self->respond(500, @$msg);
+    $self->disconnect if $rc == DENY_DISCONNECT;
+    return 1;
+  }
+
+  $self->respond(250, "OK");
+  return 1;
+}
+
+sub vrfy {
+  my $self = shift;
+
+  # Note, this doesn't support the multiple ambiguous results
+  # documented in RFC2821#3.5.1
+  # I also don't think it provides all the proper result codes.
+
+  $self->run_hooks("vrfy");
+}
+
+sub vrfy_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  if ($rc == DONE) {
+    return 1;
+  }
+  elsif ($rc == DENY) {
+    $msg->[0] ||= "Access Denied";
+    $self->respond(554, @$msg);
+    $self->reset_transaction();
+    return 1;
+  }
+  elsif ($rc == OK) {
+    $msg->[0] ||= "User OK";
+    $self->respond(250, @$msg);
+    return 1;
+  }
+  else { # $rc == DECLINED or anything else
+    $self->respond(252, "Just try sending a mail and we'll see how it turns out ...");
+    return 1;
+  }
+}
+
+sub rset {
+  my $self = shift;
+  $self->reset_transaction;
+  $self->respond(250, "OK");
+}
+
+sub quit {
+  my $self = shift;
+  $self->run_hooks("quit");
+}
+
+sub quit_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  if ($rc != DONE) {
+    $msg->[0] ||= $self->config('me') . " closing connection. Have a wonderful day.";
+    $self->respond(221, @$msg);
+  }
+  $self->disconnect();
+}
+
+sub disconnect {
+  my $self = shift;
+  $self->run_hooks("disconnect");
+  $self->connection->notes(disconnected => 1);
+  $self->reset_transaction;
+}
+
+sub data {
+  my $self = shift;
+  $self->run_hooks("data");
+}
+
+sub data_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  if ($rc == DONE) {
+    return 1;
+  }
+  elsif ($rc == DENY) {
+    $msg->[0] ||= "Message denied";
+    $self->respond(554, @$msg);
+    $self->reset_transaction();
+    return 1;
+  }
+  elsif ($rc == DENYSOFT) {
+    $msg->[0] ||= "Message denied temporarily";
+    $self->respond(451, @$msg);
+    $self->reset_transaction();
+    return 1;
+  } 
+  elsif ($rc == DENY_DISCONNECT) {
+    $msg->[0] ||= "Message denied";
+    $self->respond(554, @$msg);
+    $self->disconnect;
+    return 1;
+  }
+  elsif ($rc == DENYSOFT_DISCONNECT) {
+    $msg->[0] ||= "Message denied temporarily";
+    $self->respond(421, @$msg);
+    $self->disconnect;
+    return 1;
+  }
+  $self->respond(503, "MAIL first"), return 1 unless $self->transaction->sender;
+  $self->respond(503, "RCPT first"), return 1 unless $self->transaction->recipients;
+  $self->respond(354, "go ahead");
+  
+  my $buffer = '';
+  my $size = 0;
+  my $i = 0;
+  my $max_size = ($self->config('databytes'))[0] || 0;  # this should work in scalar context
+  my $blocked = "";
+  my %matches;
+  my $in_header = 1;
+  my $complete = 0;
+
+  $self->log(LOGDEBUG, "max_size: $max_size / size: $size");
+
+  my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE");
+
+  my $timeout = $self->config('timeout');
+  while (defined($_ = $self->getline($timeout))) {
+    $complete++, last if $_ eq ".\r\n";
+    $i++;
+
+    # should probably use \012 and \015 in these checks instead of \r and \n ...
+
+    # Reject messages that have either bare LF or CR. rjkaes noticed a
+    # lot of spam that is malformed in the header.
+
+    ($_ eq ".\n" or $_ eq ".\r")
+        and $self->respond(421, "See http://smtpd.develooper.com/barelf.html")
+        and return $self->disconnect;
+
+    # add a transaction->blocked check back here when we have line by line plugin access...
+    unless (($max_size and $size > $max_size)) {
+      s/\r\n$/\n/;
+      s/^\.\./\./;
+      if ($in_header and m/^$/) {
+        $in_header = 0;
+        my @headers = split /^/m, $buffer;
+
+        # ... need to check that we don't reformat any of the received lines.
+        #
+        # 3.8.2 Received Lines in Gatewaying
+        #   When forwarding a message into or out of the Internet environment, a
+        #   gateway MUST prepend a Received: line, but it MUST NOT alter in any
+        #   way a Received: line that is already in the header.
+
+        $header->extract(\@headers);
+        #$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/");
+
+        $buffer = "";
+
+        $self->transaction->header($header);
+
+        # NOTE: This will not work properly under async.  A
+        # data_headers_end_respond needs to be created.
+        my ($rc, $msg) = $self->run_hooks('data_headers_end');
+        if ($rc == DENY_DISCONNECT) {
+          $self->respond(554, $msg || "Message denied");
+          $self->disconnect;
+          return 1;
+        } elsif ($rc == DENYSOFT_DISCONNECT) {
+          $self->respond(421, $msg || "Message denied temporarily");
+          $self->disconnect;
+          return 1;
+        }
+
+        # Save the start of just the body itself
+        $self->transaction->set_body_start();
+
+      }
+
+      # grab a copy of all of the header lines
+      if ($in_header) {
+        $buffer .= $_;  
+      }
+
+      # copy all lines into the spool file, including the headers
+      # we will create a new header later before sending onwards
+      $self->transaction->body_write($_);
+      $size += length $_;
+    }
+    #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300);
+  }
+
+  $self->log(LOGDEBUG, "max_size: $max_size / size: $size");
+
+  my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP";
+  my $esmtp = substr($smtp,0,1) eq "E";
+  my $authheader = '';
+  my $sslheader = '';
+
+  if (defined $self->connection->notes('tls_enabled')
+      and $self->connection->notes('tls_enabled')) {
+    $smtp .= "S" if $esmtp; # RFC3848
+    $sslheader = "(".$self->connection->notes('tls_socket')->get_cipher()." encrypted) ";
+  }
+
+  if (defined $self->{_auth} and $self->{_auth} == OK) {
+    $smtp .= "A" if $esmtp; # RFC3848
+    $authheader = "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n";
+  }
+
+  $header->add("Received", $self->received_line($smtp, $authheader, $sslheader), 0);
+
+  # if we get here without seeing a terminator, the connection is
+  # probably dead.
+  unless ( $complete ) {
+      $self->respond(451, "Incomplete DATA");
+      $self->reset_transaction; # clean up after ourselves
+      return 1;
+  }
+
+  #$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked);
+  if ($max_size and $size > $max_size) {
+      $self->log(LOGALERT, "Message too big: size: $size (max size: $max_size)");
+      $self->respond(552, "Message too big!"); 
+      $self->reset_transaction; # clean up after ourselves
+      return 1;
+  }
+
+  $self->run_hooks("data_post");
+}
+
+sub received_line {
+  my ($self, $smtp, $authheader, $sslheader) = @_;
+  my ($rc, @received) = $self->run_hooks("received_line", $smtp, $authheader, $sslheader);
+  if ($rc == YIELD) {
+    die "YIELD not supported for received_line hook";
+  }
+  elsif ($rc == OK) {
+    return join("\n", @received);
+  }
+  else { # assume $rc == DECLINED
+    return  "from ".$self->connection->remote_info
+           ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip
+           . ")\n  $authheader  by ".$self->config('me')." (qpsmtpd/".$self->version
+           .") with $sslheader$smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime))
+  }
+}
+
+sub data_post_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  if ($rc == DONE) {
+    return 1;
+  }
+  elsif ($rc == DENY) {
+    $msg->[0] ||= "Message denied";
+    $self->respond(552, @$msg);
+    # DATA is always the end of a "transaction"
+    return $self->reset_transaction;
+  }
+  elsif ($rc == DENYSOFT) {
+    $msg->[0] ||= "Message denied temporarily";
+    $self->respond(452, @$msg);
+    # DATA is always the end of a "transaction"
+    return $self->reset_transaction;
+  } 
+  elsif ($rc == DENY_DISCONNECT) {
+    $msg->[0] ||= "Message denied";
+    $self->respond(552, @$msg);
+    $self->disconnect;
+    return 1;
+  }
+  elsif ($rc == DENYSOFT_DISCONNECT) {
+    $msg->[0] ||= "Message denied temporarily";
+    $self->respond(452, @$msg);
+    $self->disconnect;
+    return 1;
+  }
+  else {
+    $self->queue($self->transaction);
+  }
+}
+
+sub getline {
+  my ($self, $timeout) = @_;
+  
+  alarm $timeout;
+  my $line = <STDIN>; # default implementation
+  alarm 0;
+  return $line;
+}
+
+sub queue {
+  my ($self, $transaction) = @_;
+
+  # First fire any queue_pre hooks
+  $self->run_hooks("queue_pre");
+}
+
+sub queue_pre_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  if ($rc == DONE) {
+    return 1;
+  }
+  elsif ($rc != OK and $rc != DECLINED and $rc != 0 ) {
+    return $self->log(LOGERROR, "pre plugin returned illegal value");
+    return 0;
+  }
+
+  # If we got this far, run the queue hooks
+  $self->run_hooks("queue");
+}
+
+sub queue_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  
+  # reset transaction if we queued the mail
+  $self->reset_transaction;
+  
+  if ($rc == DONE) {
+    return 1;
+  }
+  elsif ($rc == OK) {
+    $msg->[0] ||= 'Queued';
+    $self->respond(250, @$msg);
+  }
+  elsif ($rc == DENY) {
+    $msg->[0] ||= 'Message denied';
+    $self->respond(552, @$msg);
+  }
+  elsif ($rc == DENYSOFT) {
+    $msg->[0] ||= 'Message denied temporarily';
+    $self->respond(452, @$msg);
+  } 
+  else {
+    $msg->[0] ||= 'Queuing declined or disabled; try again later';
+    $self->respond(451, @$msg);
+  }
+  
+  # And finally run any queue_post hooks
+  $self->run_hooks("queue_post");
+}
+
+sub queue_post_respond {
+  my ($self, $rc, $msg, $args) = @_;
+  $self->log(LOGERROR, @$msg) unless ($rc == OK or $rc == 0);
+}
+
+
+1;

lib/Qpsmtpd/SMTP/Prefork.pm

@@ -0,0 +1,30 @@
+package Qpsmtpd::SMTP::Prefork;
+use Qpsmtpd::SMTP;
+use Qpsmtpd::Constants;
+@ISA = qw(Qpsmtpd::SMTP);
+
+sub dispatch {
+  my $self = shift;
+  my ($cmd) = lc shift;
+
+  $self->{_counter}++; 
+
+  if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) {
+    $self->run_hooks("unrecognized_command", $cmd, @_);
+    return 1;
+  }
+  $cmd = $1;
+
+  if (1 or $self->{_commands}->{$cmd} and $self->can($cmd)) {
+    my ($result) = eval { $self->$cmd(@_) };
+    if ($@ =~ /^disconnect_tcpserver/) {
+    	die "disconnect_tcpserver"; 
+    } elsif ($@) {
+      $self->log(LOGERROR, "XX: $@") if $@;
+    }
+    return $result if defined $result;
+    return $self->fault("command '$cmd' failed unexpectedly");
+  }
+
+  return;
+}

lib/Qpsmtpd/TcpServer.pm

@@ -0,0 +1,194 @@
+package Qpsmtpd::TcpServer;
+use Qpsmtpd::SMTP;
+use Qpsmtpd::Constants;
+use Socket;
+
+@ISA = qw(Qpsmtpd::SMTP);
+use strict;
+
+use POSIX ();
+
+my $has_ipv6;
+if (
+    eval {require Socket6;} &&
+    # INET6 prior to 2.01 will not work; sorry.
+    eval {require IO::Socket::INET6; IO::Socket::INET6->VERSION("2.00");}
+    ) {
+    import Socket6;
+    $has_ipv6=1;
+}
+else {
+    $has_ipv6=0;
+}
+
+sub has_ipv6 {
+    return $has_ipv6;
+}
+
+my $first_0;
+
+sub start_connection {
+    my $self = shift;
+
+    my (
+        $remote_host, $remote_info, $remote_ip, $remote_port,
+        $local_ip,    $local_port,  $local_host
+       );
+
+    if ($ENV{TCPREMOTEIP}) {
+	# started from tcpserver (or some other superserver which
+	# exports the TCPREMOTE* variables.
+	$remote_ip   = $ENV{TCPREMOTEIP};
+	$remote_host = $ENV{TCPREMOTEHOST} || "[$remote_ip]";
+	$remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host;
+        $remote_port = $ENV{TCPREMOTEPORT};
+        $local_ip    = $ENV{TCPLOCALIP};
+        $local_port  = $ENV{TCPLOCALPORT};
+        $local_host  = $ENV{TCPLOCALHOST};
+    } else {
+	# Started from inetd or similar.
+	# get info on the remote host from the socket.
+	# ignore ident/tap/...
+	my $hersockaddr    = getpeername(STDIN)
+	    or die "getpeername failed: $0 must be called from tcpserver, (x)inetd or a similar program which passes a socket to stdin";
+	my ($port, $iaddr) = sockaddr_in($hersockaddr);
+	$remote_ip     = inet_ntoa($iaddr);
+	$remote_host    = gethostbyaddr($iaddr, AF_INET) || "[$remote_ip]";
+	$remote_info	= $remote_host;
+    }
+    $self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]");
+
+    # if the local dns resolver doesn't filter it out we might get
+    # ansi escape characters that could make a ps axw do "funny"
+    # things. So to be safe, cut them out.
+    $remote_host =~ tr/a-zA-Z\.\-0-9\[\]//cd;
+
+    $first_0 = $0 unless $first_0;
+    my $now = POSIX::strftime("%H:%M:%S %Y-%m-%d", localtime);
+    $0 = "$first_0 [$remote_ip : $remote_host : $now]";
+
+    $self->SUPER::connection->start(remote_info => $remote_info,
+                                    remote_ip   => $remote_ip,
+                                    remote_host => $remote_host,
+                                    remote_port => $remote_port,
+                                    local_ip    => $local_ip,
+                                    local_port  => $local_port,
+                                    local_host  => $local_host,
+				    @_);
+}
+
+sub run {
+    my ($self, $client) = @_;
+
+    # Set local client_socket to passed client object for testing socket state on writes
+    $self->{__client_socket} = $client;
+
+    $self->load_plugins unless $self->{hooks};
+
+    my $rc = $self->start_conversation;
+    return if $rc != DONE;
+
+    # this should really be the loop and read_input should just get one line; I think
+    $self->read_input;
+}
+
+sub read_input {
+  my $self = shift;
+
+  my $timeout =
+    $self->config('timeoutsmtpd')   # qmail smtpd control file
+      || $self->config('timeout')   # qpsmtpd control file
+        || 1200;                    # default value
+
+  alarm $timeout;
+  while (<STDIN>) {
+    alarm 0;
+    $_ =~ s/\r?\n$//s; # advanced chomp
+    $self->log(LOGINFO, "dispatching $_");
+    $self->connection->notes('original_string', $_);
+    defined $self->dispatch(split / +/, $_, 2)
+      or $self->respond(502, "command unrecognized: '$_'");
+    alarm $timeout;
+  }
+  alarm(0);
+  return if $self->connection->notes('disconnected');
+  $self->reset_transaction;
+  $self->run_hooks('disconnect');
+  $self->connection->notes(disconnected => 1);
+}
+
+sub respond {
+  my ($self, $code, @messages) = @_;
+  my $buf = '';
+
+  if ( !$self->check_socket() ) {
+    $self->log(LOGERROR, "Lost connection to client, cannot send response.");
+    return(0);
+  }
+
+  while (my $msg = shift @messages) {
+    my $line = $code . (@messages?"-":" ").$msg;
+    $self->log(LOGINFO, $line);
+    $buf .= "$line\r\n";
+  }
+  print $buf or ($self->log(LOGERROR, "Could not print [$buf]: $!"), return 0);
+  return 1;
+}
+
+sub disconnect {
+  my $self = shift;
+  $self->log(LOGINFO,"click, disconnecting");
+  $self->SUPER::disconnect(@_);
+  $self->run_hooks("post-connection");
+  $self->connection->reset;
+  exit;
+}
+
+# local/remote port and ip address
+sub lrpip {
+  my ($server, $client, $hisaddr) = @_;
+
+  my ($port, $iaddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($hisaddr)) : (sockaddr_in6($hisaddr));
+  my $localsockaddr = getsockname($client);
+  my ($lport, $laddr) = ($server->sockdomain == AF_INET) ? (sockaddr_in($localsockaddr)) : (sockaddr_in6($localsockaddr));
+
+  my $nto_iaddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($iaddr)) : (inet_ntop(AF_INET6(), $iaddr));
+  my $nto_laddr = ($server->sockdomain == AF_INET) ? (inet_ntoa($laddr)) : (inet_ntop(AF_INET6(), $laddr));
+  $nto_iaddr =~ s/::ffff://;
+  $nto_laddr =~ s/::ffff://;
+
+  return ($port, $iaddr, $lport, $laddr, $nto_iaddr, $nto_laddr);
+}
+
+sub tcpenv {
+  my ($nto_laddr, $nto_iaddr, $no_rdns) = @_;
+
+  my $TCPLOCALIP  = $nto_laddr;
+  my $TCPREMOTEIP = $nto_iaddr;
+
+  if ($no_rdns) {
+    return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEIP ? "[$ENV{TCPREMOTEIP}]" : "[noip!]");
+  }
+  my $res = new Net::DNS::Resolver;
+  $res->tcp_timeout(3);
+  $res->udp_timeout(3);
+  my $query = $res->query($nto_iaddr);
+  my $TCPREMOTEHOST;
+  if($query) {
+    foreach my $rr ($query->answer) {
+      next unless $rr->type eq "PTR";
+      $TCPREMOTEHOST = $rr->ptrdname;
+    }
+  }
+  return ($TCPLOCALIP, $TCPREMOTEIP, $TCPREMOTEHOST || "Unknown");
+}
+
+sub check_socket() {
+  my $self = shift;
+
+  return 1 if ( $self->{__client_socket}->connected );
+
+  return 0;
+}
+
+1;

lib/Qpsmtpd/TcpServer/Prefork.pm

@@ -0,0 +1,79 @@
+package Qpsmtpd::TcpServer::Prefork;
+use Qpsmtpd::TcpServer;
+use Qpsmtpd::SMTP::Prefork;
+use Qpsmtpd::Constants;
+
+@ISA = qw(Qpsmtpd::SMTP::Prefork Qpsmtpd::TcpServer);
+
+my $first_0; 
+
+sub start_connection {
+    my $self = shift;
+
+    #reset info
+    $self->{_connection} = Qpsmtpd::Connection->new(); #reset connection
+    $self->reset_transaction;
+    $self->SUPER::start_connection(@_);
+}
+
+sub read_input {
+  my $self = shift;
+
+  my $timeout =
+    $self->config('timeoutsmtpd')   # qmail smtpd control file
+      || $self->config('timeout')   # qpsmtpd control file
+        || 1200;                    # default value
+
+  alarm $timeout;
+  eval {
+    while (<STDIN>) {
+      alarm 0;
+      $_ =~ s/\r?\n$//s; # advanced chomp
+      $self->log(LOGINFO, "dispatching $_");
+      $self->connection->notes('original_string', $_);
+      defined $self->dispatch(split / +/, $_, 2)
+        or $self->respond(502, "command unrecognized: '$_'");
+      alarm $timeout;
+    }
+    unless ($self->connection->notes('disconnected')) {
+      $self->reset_transaction;
+      $self->run_hooks('disconnect');
+      $self->connection->notes(disconnected => 1);
+    }
+  };
+  if ($@ =~ /^disconnect_tcpserver/) {
+  	die "disconnect_tcpserver";
+  } else {
+  	$self->run_hooks("post-connection");
+	$self->connection->reset;
+  	die "died while reading from STDIN (probably broken sender) - $@";
+  }
+  alarm(0);
+}
+
+sub respond {
+  my ($self, $code, @messages) = @_;
+
+  if ( !$self->check_socket() ) {
+    $self->log(LOGERROR, "Lost connection to client, cannot send response.");
+    return(0);
+  }
+
+  while (my $msg = shift @messages) {
+    my $line = $code . (@messages?"-":" ").$msg;
+    $self->log(LOGINFO, $line);
+    print "$line\r\n" or ($self->log(LOGERROR, "Could not print [$line]: $!"), return 0);
+  }
+  return 1;
+}
+
+sub disconnect {
+  my $self = shift;
+  $self->log(LOGINFO,"click, disconnecting");
+  $self->SUPER::disconnect(@_);
+  $self->run_hooks("post-connection");
+  $self->connection->reset;
+  die "disconnect_tcpserver";
+}
+
+1;

lib/Qpsmtpd/Transaction.pm

@@ -0,0 +1,399 @@
+package Qpsmtpd::Transaction;
+use Qpsmtpd;
+@ISA = qw(Qpsmtpd);
+use strict;
+use Qpsmtpd::Utils;
+use Qpsmtpd::Constants;
+use Socket qw(inet_aton);
+use Sys::Hostname;
+use Time::HiRes qw(gettimeofday);
+
+use IO::File qw(O_RDWR O_CREAT);
+
+sub new { start(@_) }
+
+sub start {
+  my $proto = shift;
+  my $class = ref($proto) || $proto;
+  my %args = @_;
+  
+  my $self = { _rcpt => [], started => time, };
+  bless ($self, $class);
+  return $self;
+}
+
+sub add_recipient {
+    my ($self, $rcpt) = @_;
+    push @{$self->{_recipients}}, $rcpt if $rcpt;
+}
+
+sub remove_recipient {
+  my ($self,$rcpt) = @_;
+  $self->{_recipients} = [grep {$_->address ne $rcpt->address}
+                               @{$self->{_recipients} || []}] if $rcpt;
+}
+
+sub recipients {
+  my $self = shift;
+  @_ and $self->{_recipients} = [@_];
+  ($self->{_recipients} ? @{$self->{_recipients}} : ());
+}
+
+sub sender {
+  my $self = shift;
+  @_ and $self->{_sender} = shift;
+  $self->{_sender};
+}
+
+sub header {
+  my $self = shift;
+  @_ and $self->{_header} = shift;
+  $self->{_header};
+}
+
+# blocked() will return when we actually can do something useful with it...
+#sub blocked {
+#  my $self = shift;
+#  carp 'Use of transaction->blocked is deprecated;'
+#       . 'tell ask@develooper.com if you have a reason to use it';
+#  @_ and $self->{_blocked} = shift;
+#  $self->{_blocked};
+#}
+
+sub notes {
+  my ($self,$key) = (shift,shift);
+  # Check for any additional arguments passed by the caller -- including undef
+  return $self->{_notes}->{$key} unless @_;
+  return $self->{_notes}->{$key} = shift;
+}
+
+sub set_body_start {
+    my $self = shift;
+    $self->{_body_start} = $self->body_current_pos;
+    if ($self->{_body_file}) {
+               $self->{_header_size} = $self->{_body_start};
+    }
+    else {
+        $self->{_header_size} = 0;
+        if ($self->{_body_array}) {
+            foreach my $line (@{ $self->{_body_array} }) {
+                $self->{_header_size} += length($line);
+            }
+        }
+   }
+}
+
+sub body_start {
+  my $self = shift;
+  @_ and die "body_start now read only";
+  $self->{_body_start};
+}
+
+sub body_current_pos {
+    my $self = shift;
+    if ($self->{_body_file}) {
+        return tell($self->{_body_file});
+    }
+    return $self->{_body_current_pos} || 0;
+}
+
+sub body_filename {
+  my $self = shift;
+  $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;
+  if ($self->{_body_file}) {
+    #warn("body_write to file\n");
+    # go to the end of the file
+    seek($self->{_body_file},0,2)
+      unless $self->{_body_file_writing};
+    $self->{_body_file_writing} = 1;
+    $self->{_body_file}->print(ref $data eq "SCALAR" ? $$data : $data)
+      and $self->{_body_size} += length (ref $data eq "SCALAR" ? $$data : $data);
+  }
+  else {
+    #warn("body_write to array\n");
+    $self->{_body_array} ||= [];
+    my $ref = ref($data) eq "SCALAR" ? $data : \$data;
+    pos($$ref) = 0;
+    while ($$ref =~ m/\G(.*?\n)/gc) {
+      push @{ $self->{_body_array} }, $1;
+      $self->{_body_size} += length($1);
+      ++$self->{_body_current_pos};
+    }
+    if ($$ref =~ m/\G(.+)\z/gc) {
+      push @{ $self->{_body_array} }, $1;
+      $self->{_body_size} += length($1);
+      ++$self->{_body_current_pos};
+    }
+    $self->body_spool if ( $self->{_body_size} >= $self->size_threshold() );
+  }
+}
+
+sub body_size { # depreceated, use data_size() instead
+  my $self = shift;
+  $self->log(LOGWARN, "WARNING: body_size() is depreceated, use data_size() instead");
+  $self->{_body_size} || 0;
+}
+
+sub data_size {
+  shift->{_body_size} || 0;
+}
+
+sub body_length {
+  my $self = shift;
+  $self->{_body_size}   or return 0;
+  $self->{_header_size} or return 0;
+  return $self->{_body_size} - $self->{_header_size};
+}
+
+sub body_resetpos {
+  my $self = shift;
+  
+  if ($self->{_body_file}) {
+    my $start = $self->{_body_start} || 0;
+    seek($self->{_body_file}, $start, 0);
+    $self->{_body_file_writing} = 0;
+  }
+  else {
+    $self->{_body_current_pos} = $self->{_body_start};
+  }
+  
+  1;
+}
+
+sub body_getline {
+  my $self = shift;
+  if ($self->{_body_file}) {
+    my $start = $self->{_body_start} || 0;
+    seek($self->{_body_file}, $start,0)
+      if $self->{_body_file_writing};
+    $self->{_body_file_writing} = 0;
+    my $line = $self->{_body_file}->getline;
+    return $line;
+  }
+  else {
+    return unless $self->{_body_array};
+    $self->{_body_current_pos} ||= 0;
+    my $line = $self->{_body_array}->[$self->{_body_current_pos}];
+    $self->{_body_current_pos}++;
+    return $line;
+  }
+}
+
+sub body_as_string {
+    my $self = shift;
+    $self->body_resetpos;
+    local $/;
+    my $str = '';
+    while (defined(my $line = $self->body_getline)) {
+        $str .= $line;
+    }
+    return $str;
+}
+
+sub body_fh {
+  return shift->{_body_file};
+}
+
+sub dup_body_fh {
+  my ($self) = @_;
+  open(my $fh, '<&=', $self->body_fh);
+  return $fh;
+}
+
+sub DESTROY {
+  my $self = shift;
+  # would we save some disk flushing if we unlinked the file before
+  # closing it?
+
+  undef $self->{_body_file} if $self->{_body_file};
+  if ($self->{_filename} and -e $self->{_filename}) {
+    unlink $self->{_filename} or $self->log(LOGERROR, "Could not unlink ", $self->{_filename}, ": $!");
+  }
+
+  # These may not exist
+  if ( $self->{_temp_files} ) {
+    $self->log(LOGDEBUG, "Cleaning up temporary transaction files");
+    foreach my $file ( @{$self->{_temp_files}} ) {
+      next unless -e $file;
+      unlink $file or $self->log(LOGERROR,
+       "Could not unlink temporary file", $file, ": $!");
+    }
+  }
+  # Ditto
+  if ( $self->{_temp_dirs} ) {
+    eval {use File::Path};
+    $self->log(LOGDEBUG, "Cleaning up temporary directories");
+    foreach my $dir ( @{$self->{_temp_dirs}} ) {
+      rmtree($dir) or $self->log(LOGERROR, 
+        "Could not unlink temporary dir", $dir, ": $!");
+    }
+  }
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+Qpsmtpd::Transaction - single SMTP session transaction data
+
+=head1 SYNOPSIS
+
+  foreach my $recip ($transaction->recipients) {
+    print "T", $recip->address, "\0";
+  }
+
+=head1 DESCRIPTION
+
+Qpsmtpd::Transaction maintains a single SMTP session's data, including
+the envelope details and the mail header and body.
+
+The docs below cover using the C<$transaction> object from within plugins
+rather than constructing a C<Qpsmtpd::Transaction> object, because the
+latter is done for you by qpsmtpd.
+
+=head1 API
+
+=head2 add_recipient($recipient)
+
+This adds a new recipient (as in RCPT TO) to the envelope of the mail.
+
+The C<$recipient> is a C<Qpsmtpd::Address> object. See L<Qpsmtpd::Address>
+for more details.
+
+=head2 remove_recipient($recipient)
+
+This removes a recipient (as in RCPT TO) from the envelope of the mail.
+
+The C<$recipient> is a C<Qpsmtpd::Address> object. See L<Qpsmtpd::Address>
+for more details.
+
+=head2 recipients( )
+
+This returns a list of the current recipients in the envelope.
+
+Each recipient returned is a C<Qpsmtpd::Address> object.
+
+This method is also a setter. Pass in a list of recipients to change
+the recipient list to an entirely new list. Note that the recipients
+you pass in B<MUST> be C<Qpsmtpd::Address> objects.
+
+=head2 sender( [ ADDRESS ] )
+
+Get or set the sender (MAIL FROM) address in the envelope.
+
+The sender is a C<Qpsmtpd::Address> object.
+
+=head2 header( [ HEADER ] )
+
+Get or set the header of the email.
+
+The header is a <Mail::Header> object, which gives you access to all
+the individual headers using a simple API. e.g.:
+
+  my $headers = $transaction->header();
+  my $msgid = $headers->get('Message-Id');
+  my $subject = $headers->get('Subject');
+
+=head2 notes( $key [, $value ] )
+
+Get or set a note on the transaction. This is a piece of data that you wish
+to attach to the transaction and read somewhere else. For example you can
+use this to pass data between plugins.
+
+Note though that these notes will be lost when a transaction ends, for
+example on a C<RSET> or after C<DATA> completes, so you might want to
+use the notes field in the C<Qpsmtpd::Connection> object instead.
+
+=head2 body_filename ( )
+
+Returns the temporary filename used to store the message contents; useful for
+virus scanners so that an additional copy doesn't need to be made.
+
+Calling C<body_filename()> also forces spooling to disk. A message is not 
+spooled to disk if it's size is smaller than 
+I<$self-E<gt>config("size_threshold")>, default threshold is 0, the sample
+config file sets this to 10000.
+
+=head2 body_write( $data )
+
+Write data to the end of the email.
+
+C<$data> can be either a plain scalar, or a reference to a scalar.
+
+=head2 body_size( )
+
+B<Deprecated>, Use I<data_size()> instead.
+
+=head2 data_size( )
+
+Get the current size of the email. Note that this is not the size of the 
+message that will be queued, it is the size of what the client sent after
+the C<DATA> command. If you need the size that will be queued, use
+
+ my $msg_len = length($transaction->header->as_string) 
+   + $transaction->body_length;
+
+The line above is of course only valid in I<hook_queue( )>, as other plugins
+may add headers and qpsmtpd will add it's I<Received:> header.
+
+=head2 body_length( )
+
+Get the current length of the body of the email. This length includes the
+empty line between the headers and the body. Until the client has sent 
+some data of the body of the message (i.e. headers are finished and client
+sent the empty line) this will return 0.
+
+=head2 body_resetpos( )
+
+Resets the body filehandle to the start of the file (via C<seek()>).
+
+Use this function before every time you wish to process the entire
+body of the email to ensure that some other plugin has not moved the
+file pointer.
+
+=head2 body_getline( )
+
+Returns a single line of data from the body of the email.
+
+=head2 body_fh( )
+
+Returns the file handle to the temporary file of the email. This will return
+undef if the file is not opened (yet). In I<hook_data( )> or later you can 
+force spooling to disk by calling I<$transaction-E<gt>body_filename>. 
+
+=head2 dup_body_fh( )
+
+Returns a dup()'d file handle to the temporary file of the email. This can be
+useful if an external module may call close() on the filehandle that is passed
+to it.  This should only be used for reads, as writing to a dup'd filehandle
+may have unintended consequences.
+
+=head1 SEE ALSO
+
+L<Mail::Header>, L<Qpsmtpd::Address>, L<Qpsmtpd::Connection>
+
+=cut

lib/Qpsmtpd/Utils.pm

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

log/run

@@ -0,0 +1,5 @@
+#! /bin/sh
+export LOGDIR=./main
+mkdir -p $LOGDIR
+exec multilog t s1000000 n20 $LOGDIR
+

packaging/rpm/Makefile

@@ -0,0 +1,182 @@
+# -- generic Makefile for building RPM-based packages out of source
+#    code control systems (git, cvs, svn)
+
+SCM_TYPE := git
+SCM_PATH := ../../
+#CVSROOT := $(shell cat 2>/dev/null src/CVS/Root)
+#SVN_PATH := $(shell svn info ${SCM_PATH} 2>/dev/null | awk '/^URL:/{print $$2}')
+#SVN_REV := $(shell svn info ${SVN_PATH} 2>/dev/null | awk '/^Last Changed Rev:/{print $$4}')
+
+PACKAGE := $(shell cat PACKAGE)
+VERSION := $(shell cat VERSION)
+RELEASE := $(shell cat RELEASE)
+BASE_VER := ${VERSION}-${RELEASE}
+CURRENT_PACKAGE := $(PACKAGE)-$(BASE_VER)
+TARBALL := $(CURRENT_PACKAGE).tar
+
+DIRNAME := $(shell echo $${PWD})
+DIRBASE := $(shell basename $${PWD})
+
+
+.SUFFIXES:
+.PHONY: clean mrclean distclean prepclean all default
+.PHONY: rpm rpmdist buildrpm buildrpmdist
+.PHONY: buildtarball buildtargz
+.PHONY: builddir distdir prepbuildtarball
+.PHONY: cvs-export git-export svn-export test-export
+.PHONY: cvs-clean git-clean svn-clean test-clean
+.PHONY: update
+
+default: rpmdist
+
+# -- the "rpmdist" target will build out of the SCM, but will
+#    use the user's default build settings (which in many cases
+#    is exposed as an RPM repository)
+#
+#rpmdist: buildrpmdist distclean
+rpmdist: buildrpmdist
+
+buildrpmdist: buildtargz
+	@rpmbuild \
+	  --define "_package ${PACKAGE}" \
+	  --define "_version ${VERSION}" \
+	  --define "_release ${RELEASE}" \
+	  -ta ./build/$(TARBALL).gz
+
+# -- the "srpmdist" target will build an SRPM out of the SCM, but
+#    will use the user's default build settings (which in many
+#    cases is exposed as an RPM repository)
+#
+srpmdist: buildsrpmdist
+
+buildsrpmdist: buildtargz
+	@rpmbuild \
+	  --define "_package ${PACKAGE}" \
+	  --define "_version ${VERSION}" \
+	  --define "_release ${RELEASE}" \
+	  -ts --nodeps ./build/$(TARBALL).gz
+
+# -- the "rpm" target will build out of the SCM, but will leave
+#    the resulting package in the relative ./build/ directory
+#
+rpm: buildrpm $(SCM_TYPE)-clean
+
+buildrpm: buildtargz
+	@echo ${PACKAGE} ${VERSION} ${RELEASE}
+	@rpmbuild \
+	  --define "_rpmdir ./build/" \
+	  --define "_sourcedir ./build/" \
+	  --define "_srcrpmdir ./build/" \
+	  --define "_package ${PACKAGE}" \
+	  --define "_version ${VERSION}" \
+	  --define "_release ${RELEASE}" \
+	  -ta ./build/$(TARBALL).gz
+
+# -- the "srpm" target will build an SRPM out of the SCM, but
+#    will leave the resulting package in the relative ./build/
+#    directory
+#
+srpm: buildsrpm $(SCM_TYPE)-clean
+
+buildsrpm: buildtargz
+	@echo ${PACKAGE} ${VERSION} ${RELEASE}
+	@rpmbuild \
+	  --define "_rpmdir ./build/" \
+	  --define "_sourcedir ./build/" \
+	  --define "_srcrpmdir ./build/" \
+	  --define "_package ${PACKAGE}" \
+	  --define "_version ${VERSION}" \
+	  --define "_release ${RELEASE}" \
+	  -ts --nodeps ./build/$(TARBALL).gz
+
+buildtarball: prepbuildtarball
+	@tar \
+	  --create \
+	  --directory ./build/ \
+	  --file      ./build/$(TARBALL) \
+	  ${CURRENT_PACKAGE}
+
+buildtargz: buildtarball
+	@gzip -c < ./build/$(TARBALL) > ./build/$(TARBALL).gz
+
+prepbuildtarball: $(SCM_TYPE)-export
+	${MAKE} update \
+	  && cp ${PACKAGE}.spec ./build/${CURRENT_PACKAGE} \
+	  && cp files/* ./build/
+
+test-clean:
+	@cd .. \
+	  && rm "$(CURRENT_PACKAGE)"
+
+test-export: builddir
+	@cd .. \
+	  && ln -snvf $(DIRBASE) $(CURRENT_PACKAGE) \
+	  && tar \
+	    --create \
+	    --dereference \
+	    --to-stdout \
+	    --exclude "*.git*" \
+	    --exclude "*.svn*" \
+	    --exclude "*/CVS/*" \
+	    --exclude "$(CURRENT_PACKAGE)/build/*" \
+	      $(CURRENT_PACKAGE) \
+	  | tar \
+	    --extract \
+	    --directory $(CURRENT_PACKAGE)/build/ \
+	    --file -
+
+git-export: builddir prepclean
+	(cd $(SCM_PATH) ; git archive --format=tar --prefix=$(CURRENT_PACKAGE)/ HEAD) \
+	  | tar \
+	    --extract \
+	    --directory ./build/ \
+	    --file -
+
+git-clean:
+	@:
+
+cvs-export: builddir prepclean
+	@cd ./build/ \
+	  && echo CURRENT_PACKAGE: ${CURRENT_PACKAGE} \
+	  && echo CVSROOT: ${CVSROOT} \
+	  && CVSROOT=${CVSROOT} cvs export -r HEAD -d$(CURRENT_PACKAGE) ${PACKAGE}
+
+cvs-clean:
+	@:
+
+svn-export: builddir prepclean
+	@cd ./build/ \
+	  && svn export $(SVN_PATH) $(CURRENT_PACKAGE)
+
+svn-clean:
+	@:
+
+builddir:
+	@mkdir -p ./build
+
+distdir:
+	@mkdir -p ./dist
+
+prepclean:
+	@rm -rf ./build/$(CURRENT_PACKAGE)*
+
+clean:
+	@rm -rf ./build/* ./dist/* 2>/dev/null || :
+
+mrclean: clean
+
+distclean: clean $(SCM_TYPE)-clean
+	@rmdir ./build/ ./dist/ 2>/dev/null || :
+
+# -- recursive Makefile calls (during build phase)
+#
+update: $(PACKAGE).spec VERSION RELEASE
+
+$(PACKAGE).spec: VERSION RELEASE $(PACKAGE).spec.in
+	@sed \
+	  -e "s|@PACKAGE@|$(PACKAGE)|" \
+	  -e "s|@VERSION@|$(VERSION)|" \
+	  -e "s|@RELEASE@|$(RELEASE)|" \
+	  < $(PACKAGE).spec.in > $@
+
+# -- end of Makefile

packaging/rpm/PACKAGE

@@ -0,0 +1 @@
+qpsmtpd

packaging/rpm/RELEASE

@@ -0,0 +1 @@
+0.1

packaging/rpm/VERSION

@@ -0,0 +1 @@
+0.82

packaging/rpm/files/README.selinux

@@ -0,0 +1,10 @@
+If you run qpsmtpd-apache on a box with SELinux enabled, you'll need to
+allow apache to listen to your SMTP port, typically port 25.
+
+The following command allows apache to listen on port 25:
+
+    semanage port -m -t http_port_t -p tcp 25
+
+Use the -d option to remove this permission:
+
+    semanage port -d -t http_port_t -p tcp 25

packaging/rpm/files/in.qpsmtpd

@@ -0,0 +1,3 @@
+#!/bin/sh
+export QPSMTPD_CONFIG=/etc/qpsmtpd
+exec /usr/bin/qpsmtpd 2> /dev/null

packaging/rpm/files/qpsmtpd-forkserver.rc

@@ -0,0 +1,122 @@
+#! /bin/bash
+#
+# qpsmtpd-forkserver          Start/Stop the qpsmtpd forking server
+#
+# chkconfig: 2345 90 60
+# description: qpsmtpd is a flexible smtpd daemon written in Perl. \
+#              Apart from the core SMTP features, all functionality is \
+#              implemented in small "extension plugins" using the easy \
+#              to use object oriented plugin API.
+# processname: qpsmtpd-forkserver
+# config: /etc/qpsmtpd
+# pidfile: /var/run/qpsmtpd-forkserver.pid
+
+
+# Source function library.
+. /etc/init.d/functions
+. /etc/sysconfig/qpsmtpd-forkserver
+
+RETVAL=0
+
+# See how we were called.
+  
+prog="qpsmtpd-forkserver"
+
+start() {
+	# cleanup environment a bit.
+	unset PERL_UNICODE
+	unset LANG
+	unset LC_TIME
+	unset LC_ALL
+	unset BASH_ENV
+	unset ENV
+	unset CDPATH
+	unset IFS
+
+	echo -n $"Starting $prog: "
+	trap "" 1
+	daemon $prog --detach $QPSMTPD_OPTIONS
+	RETVAL=$?
+	echo
+	[ $RETVAL -eq 0 ] && touch /var/lock/subsys/$prog
+	return $RETVAL
+}
+
+stop() {
+	echo -n $"Stopping $prog: "
+	killproc $prog
+	RETVAL=$?
+	echo
+	[ $RETVAL -eq 0 ] && rm -f /var/lock/subsys/$prog
+	return $RETVAL
+}	
+
+# functions status() uses pidof, which doesn't work with (?) scripts
+qpstatus() {
+	local base=${1##*/}
+	local pid
+
+	# Test syntax.
+	if [ "$#" = 0 ] ; then
+		echo $"Usage: status {program}"
+		return 1
+	fi
+
+	# Use "/var/run/*.pid" file for pid
+	if [ -f /var/run/${base}.pid ] ; then
+	    read pid < /var/run/${base}.pid
+	    if [ -n "$pid" ]; then
+            /bin/ps -p $pid >/dev/null
+            if [ $? -eq 0 ]; then
+                echo $"${base} (pid $pid) is running..."
+                return 0
+            else                
+	            echo $"${base} dead but pid file exists"
+	            return 1
+            fi
+	    fi
+	fi
+	# See if /var/lock/subsys/${base} exists
+	if [ -f /var/lock/subsys/${base} ]; then
+		echo $"${base} dead but subsys locked"
+		return 2
+	fi
+	echo $"${base} is stopped"
+	return 3
+}
+
+restart() {
+  	stop
+	start
+}	
+
+reload() {
+  	stop
+	start
+}	
+
+case "$1" in
+  start)
+  	start
+	;;
+  stop)
+  	stop
+	;;
+  restart)
+  	restart
+	;;
+  reload)
+  	reload
+	;;
+  status)
+  	qpstatus qpsmtpd-forkserver
+	;;
+  condrestart)
+  	[ -f /var/lock/subsys/$prog ] && restart || :
+	;;
+  *)
+	echo $"Usage: $0 {start|stop|status|reload|restart|condrestart}"
+	exit 1
+esac
+
+exit $?

packaging/rpm/files/qpsmtpd-forkserver.sysconfig

@@ -0,0 +1,3 @@
+QPSMTPD_OPTIONS="-p 25 -l 127.0.0.1 --pid-file /var/run/qpsmtpd-forkserver.pid"
+export QPSMTPD_CONFIG=/etc/qpsmtpd
+export HOME=~smtpd

packaging/rpm/files/qpsmtpd-plugin-file_connection

@@ -0,0 +1,184 @@
+#!/usr/bin/perl
+# $Id: file 478 2005-07-19 07:40:16Z aqua $
+
+=head1 NAME
+
+file_connection - Simple per session log-to-file logging for qpsmtpd
+
+=head1 DESCRIPTION
+
+The 'file_connection' logging plugin for qpsmtpd records qpsmtpd log messages into a
+file (or a named pipe, if you prefer.)
+
+The file is reopened for each connection. To facilitate automatic
+logfile switching the filename can contain strftime conversion
+specifiers, which are expanded immediately before opening the file. This
+ensures that a single connection is never split across logfiles.
+
+The list of supported conversion specifiers depends on the strftime
+implementation of your C library. See strftime(3) for details.
+Additionally, %i exands to a (hopefully) unique session-id.
+
+
+=head1 CONFIGURATION
+
+To enable the logging plugin, add a line of this form to the qpsmtpd plugins
+configuration file:
+
+=over
+
+logging/file_connection [loglevel I<level>] I<path>
+
+For example:
+
+logging/file_connection loglevel LOGINFO /var/log/qpsmtpd/%Y-%m-%d
+
+=back
+
+Multiple instances of the plugin can be configured by appending :I<N> for any
+integer(s) I<N>, to log to multiple files simultaneously, e.g. to log critical
+errors and normally verbose logs elsewhere.
+
+The following optional configuration setting can be supplied:
+
+=over
+
+=item loglevel I<loglevel>
+
+The internal log level below which messages will be logged.  The I<loglevel>
+given should be chosen from this list.  Priorities count downward (for example,
+if LOGWARN were selected, LOGERROR, LOGCRIT and LOGEMERG messages would be
+logged as well):
+
+=over
+
+=item B<LOGDEBUG>
+
+=item B<LOGINFO>
+
+=item B<LOGNOTICE>
+
+=item B<LOGWARN>
+
+=item B<LOGERROR>
+
+=item B<LOGCRIT>
+
+=item B<LOGALERT>
+
+=item B<LOGEMERG>
+
+=back
+
+=back
+
+
+The chosen I<path> should be writable by the user running qpsmtpd; it will be
+created it did not already exist, and appended to otherwise.
+
+=head1 AUTHOR
+
+Peter J. Holzer <hjp@hjp.at>, based on a plugin by 
+Devin Carraway <qpsmtpd@devin.com>
+
+=head1 LICENSE
+
+Copyright (c) 2005, Devin Carraway.
+
+This plugin is licensed under the same terms as the qpsmtpd package itself.
+Please see the LICENSE file included with qpsmtpd for details.
+
+=cut
+
+use strict;
+use warnings;
+
+use IO::File;
+#use Sys::Hostname;
+use POSIX qw(strftime);
+
+sub register {
+    my ($self, $qp, @args) = @_;
+    my %args;
+
+    $self->{_loglevel} = LOGWARN;
+
+    while (1) {
+    	last if !@args;
+    	if (lc $args[0] eq 'loglevel') {
+            shift @args;
+            my $ll = shift @args;
+            if (!defined $ll) {
+                warn "Malformed arguments to logging/file_connection plugin";
+                return;
+            }
+            if ($ll =~ /^(\d+)$/) {
+                $self->{_loglevel} = $1;
+            }
+            elsif ($ll =~ /^(LOG\w+)$/) {
+                $self->{_loglevel} = log_level($1);
+                defined $self->{_loglevel} or $self->{_loglevel} = LOGWARN;
+            }
+        }
+        else { last }
+    }
+
+    unless (@args && $args[0]) {
+        warn "Malformed arguments to syslog plugin";
+        return;
+    }
+
+    $self->{_logfile} = join(' ', @args);
+    $self->{_log_session_id_prefix} = sprintf("%08x%04x", time(), $$);
+    $self->{_log_session_id_counter} = 0;
+
+    $self->register_hook('logging', 'write_log');
+    $self->register_hook('pre-connection', 'open_log');
+    $self->open_log($qp);
+}
+
+sub open_log {
+    my ($self, $qp) = @_;
+    my $output = $self->{_logfile};
+    $self->{_log_session_id} =
+        $self->{_log_session_id_prefix} . "." .
+        ++$self->{_log_session_id_counter};
+
+    $output =~ s/%i/$self->{_log_session_id}/;
+    $output = strftime($output, localtime);
+    #print STDERR "open_log: output=$output, uid=$>\n";
+    if ($output =~ /^\s*\|(.*)/) {
+        unless ($self->{_f} = new IO::File "|$1") {
+            warn "Error opening log output to command $1: $!";
+            return;
+        }
+    } elsif ($output =~ /^(.*)/) { # detaint
+        unless ($self->{_f} = new IO::File ">>$1") {
+            warn "Error opening log output to path $1: $!";
+            return;
+        }
+    }
+    $self->{_f}->autoflush(1);
+
+    return DECLINED;
+}
+
+sub write_log {
+    my ($self, $txn, $trace, $hook, $plugin, @log) = @_;
+
+    return DECLINED if $trace > $self->{_loglevel};
+    return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
+    $self->open_log unless($self->{_f});
+
+    my $f = $self->{_f};
+    print STDERR "no open file\n" unless (defined $f);
+    print $f join(" ",
+                  strftime("%Y-%m-%dT%H:%M:%S%z", localtime), $self->{_log_session_id},
+                  (defined $plugin ? " $plugin plugin:" :
+                   defined $hook   ? " running plugin ($hook):"  : ""),
+                  @log), "\n";
+    return DECLINED;
+}
+
+# vi: tabstop=4 shiftwidth=4 expandtab:
+

packaging/rpm/files/qpsmtpd-xinetd

@@ -0,0 +1,19 @@
+# default: on
+# description: The telnet server serves telnet sessions; it uses \
+#	unencrypted username/password pairs for authentication.
+service smtp
+{
+	flags		= REUSE
+	socket_type	= stream        
+	wait		= no
+	user		= smtpd
+	groups		= yes
+	server		= /usr/sbin/in.qpsmtpd
+	log_on_failure	+= USERID
+	disable		= yes
+	rlimit_as	= 128M
+	instances	= 40
+	per_source	= 10
+	cps		= 50 10
+}
+

packaging/rpm/files/qpsmtpd.conf

@@ -0,0 +1,16 @@
+Listen 0.0.0.0:25 smtp
+AcceptFilter smtp none
+## "smtp" and the AcceptFilter are required for Linux, FreeBSD
+## with apache >= 2.1.5, for others it doesn't hurt. See also
+## http://httpd.apache.org/docs/2.2/mod/core.html#acceptfilter
+## and http://httpd.apache.org/docs/2.2/mod/mpm_common.html#listen
+
+<Perl>
+    use Apache::Qpsmtpd;
+    $ENV{QPSMTPD_CONFIG} = "/etc/qpsmtpd";
+</Perl>
+
+<VirtualHost _default_:25>
+    PerlModule Apache::Qpsmtpd
+    PerlProcessConnectionHandler Apache::Qpsmtpd
+</VirtualHost>

packaging/rpm/qpsmtpd.spec.in

@@ -0,0 +1,335 @@
+Name:           %{_package}
+Version:        %{_version}
+Release:        %{_release}
+
+Summary: qpsmtpd + qpsmtpd-apache + qpsmtpd-async
+License: MIT
+Group: System Environment/Daemons
+URL: http://smtpd.develooper.com/
+BuildRoot: %{_builddir}/%{name}-%{version}-%{release}-root
+BuildRequires: perl >= 0:5.00503
+BuildArchitectures: noarch
+Requires: perl(Mail::Header), perl(Net::DNS) perl(Net::IP) perl(IPC::Shareable)
+Requires(pre): coreutils, shadow-utils, perl
+
+Source0: %{name}-%{version}-%{release}.tar.gz
+Source1: qpsmtpd-forkserver.rc
+Source2: qpsmtpd-forkserver.sysconfig
+Source3: qpsmtpd-plugin-file_connection
+Source4: qpsmtpd-xinetd
+Source5: in.qpsmtpd
+Source6: qpsmtpd.conf
+Source7: README.selinux
+
+%description
+qpsmtpd is a flexible smtpd daemon written in Perl. Apart from the core
+SMTP features, all functionality is implemented in small "extension
+plugins" using the easy to use object oriented plugin API.
+
+qpsmtpd was originally written as a drop-in qmail-smtpd replacement, but
+now it also includes a smtp forward and a postfix "backend".
+
+%package apache
+Requires: perl(mod_perl2)
+Summary: mod_perl-2 connection handler for qpsmtpd
+Group: System Environment/Daemons
+
+%package async
+Summary: qpsmtpd using async I/O in a single process
+Group: System Environment/Daemons
+
+%description apache
+
+This module implements a mod_perl/apache 2.0 connection handler
+that turns Apache into an SMTP server using Qpsmtpd.
+
+%description async
+This package contains the Qpsmtpd::PollServer module, which allows
+qpsmtd to handle many connections in a single process and the 
+qpsmpd-async which uses it.
+
+%prep
+%setup -q -n %{name}-%{version}-%{release}
+
+%build
+CFLAGS="$RPM_OPT_FLAGS" perl Makefile.PL INSTALLSITELIB=%{_prefix}/lib/perl5/site_perl
+make
+
+%clean
+rm -rf $RPM_BUILD_ROOT
+%install
+
+rm -rf $RPM_BUILD_ROOT
+eval `perl '-V:installarchlib'`
+mkdir -p $RPM_BUILD_ROOT/$installarchlib
+if grep -q DESTDIR Makefile
+then
+        make DESTDIR=$RPM_BUILD_ROOT
+        find blib/lib -name '*.pm.*' -exec rm -f {} \;
+        make DESTDIR=$RPM_BUILD_ROOT install
+
+else
+        make PREFIX=$RPM_BUILD_ROOT/usr
+        find blib/lib -name '*.pm.*' -exec rm -f {} \;
+        make PREFIX=$RPM_BUILD_ROOT/usr install
+fi
+mkdir -p ${RPM_BUILD_ROOT}%{_datadir}/%{name}
+rm -f ${RPM_BUILD_ROOT}%{_datadir}/%{name}/plugins/*.*
+cp -r plugins ${RPM_BUILD_ROOT}%{_datadir}/%{name}/plugins
+mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}
+rm -f ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/*.*
+cp -r config.sample/* ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/
+echo %{_datadir}/%{name}/plugins > ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/plugin_dirs
+echo %{_localstatedir}/spool/qpsmtpd > ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/spool_dir
+echo logging/file_connection loglevel LOGINFO %{_localstatedir}/log/qpsmtpd/%Y-%m-%d > ${RPM_BUILD_ROOT}%{_sysconfdir}/%{name}/logging
+mkdir -p ${RPM_BUILD_ROOT}%{_initrddir}
+cp %{SOURCE1} ${RPM_BUILD_ROOT}%{_initrddir}/qpsmtpd-forkserver
+mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/sysconfig
+cp %{SOURCE2} ${RPM_BUILD_ROOT}%{_sysconfdir}/sysconfig/qpsmtpd-forkserver
+cp %{SOURCE3} ${RPM_BUILD_ROOT}%{_datadir}/%{name}/plugins/logging/file_connection
+mkdir -p ${RPM_BUILD_ROOT}%{_localstatedir}/spool/qpsmtpd
+mkdir -p ${RPM_BUILD_ROOT}%{_localstatedir}/log/qpsmtpd
+mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/xinetd.d
+cp %{SOURCE4} ${RPM_BUILD_ROOT}%{_sysconfdir}/xinetd.d/smtp
+mkdir -p ${RPM_BUILD_ROOT}%{_sbindir}
+cp %{SOURCE5} ${RPM_BUILD_ROOT}%{_sbindir}/in.smtp
+mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/httpd/conf.d
+cp %{SOURCE6} ${RPM_BUILD_ROOT}%{_sysconfdir}/httpd/conf.d
+mkdir -p $RPM_BUILD_ROOT%{_docdir}/%{name}-apache-%{version}
+cp %{SOURCE7} $RPM_BUILD_ROOT%{_docdir}/%{name}-apache-%{version}
+
+[ -x /usr/lib/rpm/brp-compress ] && /usr/lib/rpm/brp-compress
+
+find ${RPM_BUILD_ROOT}%{_prefix} \( -name perllocal.pod -o -name .packlist \) -exec rm {} \;
+find ${RPM_BUILD_ROOT}%{_prefix} -type f -print | \
+        sed "s@^$RPM_BUILD_ROOT@@g"     | \
+        grep -v [Aa]sync                | \
+        grep -v packaging               | \
+        grep -v README.selinux          | \
+        grep -v /Apache                 | \
+        grep -v /Danga                  | \
+        grep -v Qpsmtpd/ConfigServer.pm | \
+        grep -v Qpsmtpd/PollServer.pm   > %{name}-%{version}-%{release}-filelist
+if [ "$(cat %{name}-%{version}-%{release}-filelist)X" = "X" ] ; then
+    echo "ERROR: EMPTY FILE LIST"
+    exit -1
+fi
+
+%files -f %{name}-%{version}-%{release}-filelist
+%defattr(-,root,root)
+%doc CREDITS Changes LICENSE README README.plugins STATUS
+%{_initrddir}/qpsmtpd-forkserver
+%config(noreplace) %{_sysconfdir}/qpsmtpd/*
+%config(noreplace) %{_sysconfdir}/xinetd.d/smtp
+%config(noreplace) %{_sysconfdir}/sysconfig/qpsmtpd-forkserver
+%attr(2750,qpsmtpd,clamav) %dir %{_localstatedir}/spool/qpsmtpd
+%attr(0750,smtpd,smtpd) %dir %{_localstatedir}/log/qpsmtpd
+
+%files apache
+%defattr(-,root,root)
+%{_prefix}/lib/perl5/site_perl/Apache/Qpsmtpd.pm
+%{_mandir}/man3/Apache::Qpsmtpd.3pm.gz
+%config(noreplace) %{_sysconfdir}/httpd/conf.d/*
+%doc %{_docdir}/%{name}-apache-%{version}/README.selinux
+
+%files async
+%defattr(-,root,root)
+%{_bindir}/qpsmtpd-async
+%{_prefix}/lib/perl5/site_perl/Danga/Client.pm
+%{_prefix}/lib/perl5/site_perl/Danga/TimeoutSocket.pm
+%{_prefix}/lib/perl5/site_perl/Qpsmtpd/ConfigServer.pm
+%{_prefix}/lib/perl5/site_perl/Qpsmtpd/Plugin/Async/DNSBLBase.pm
+%{_prefix}/lib/perl5/site_perl/Qpsmtpd/PollServer.pm
+%{_mandir}/man1/qpsmtpd-async.1.gz
+%{_datadir}/%{name}/plugins/async/*
+
+%pre
+if ! id smtpd >/dev/null 2>&1
+then
+    # need to create smtpd user.
+    if perl -e 'exit ! defined(getgrnam("postdrop"))'
+    then
+        # if postfix is installed, we will probably use
+        # queue/postfix, which will need this:
+        supp="-G postdrop"
+    fi
+    useradd -r -M -s /bin/false $supp smtpd
+fi
+
+%changelog
+* Sun Jul 12 2009 <rpmbuild@robinbowes.com> 0.82-0.1
+- Update to latest release
+- don't add qpsmtpd to start-up by default
+- add apache config file to qpsmtpd-apache package
+- remove all patches
+- use rpm macros for dirs
+- use a filelist for main package instead of a long list of files
+
+* Tue Jul 15 2008 <rpmbuild@robinbowes.com> 0.43-0.7
+- Removed SelectServer.pm from .spec file
+
+* Tue Mar 18 2008 <rpmbuild@robinbowes.com> 0.43-0.6
+- moved config files back to /etc/qpsmtpd following some changes
+  to the qpsmtpd src
+
+* Tue Mar 18 2008 <rpmbuild@robinbowes.com> 0.43-0.5
+- moved config files to /etc/qpsmtpd/config
+
+* Tue Mar 18 2008 <rpmbuild@robinbowes.com> 0.43-0.4
+- Moved qpsmtpd-async to /usr/bin
+- Added qpsmtpd-async man page to async package
+- Added async smtproute plugin to async package
+  
+* Wed Mar 12 2008 <rpmbuild@robinbowes.com> 0.43-0.3
+- Makefile.PL now updated in svn, so remove hack
+
+* Wed Mar 12 2008 <rpmbuild@robinbowes.com> 0.43-0.2
+- Added qpsmtpd-prefork to qpsmtpd RPM, inc. hack to work round
+  deficiency in Makefile.PL
+
+* Mon Mar 10 2008 <rpmbuild@robinbowes.com> 0.43-0.1
+- Updated to work with Makefile to build from svn
+
+* Wed Sep 12 2007 <rpmbuild@robinbowes.com> 0.40-2.0
+- Updated to build trunk-r790
+
+* Tue Jun 12 2007 <hjp@hjp.at> 0.40-1.0
+- updated to 0.40 - no code change.
+
+* Thu Jun 07 2007 <hjp@hjp.at> 0.40-0.2
+- unset environment variables which are normally tainted in perl.
+- updated to 0.40rc1
+- added dependency on Net::IP (needed by some plugins)
+
+* Sat May 05 2007 <hjp@hjp.at> 0.33-0.5
+- moved environment cleanup into start() function, otherwise
+  LANG just gets reinitialized.
+
+* Sat May 05 2007 <hjp@hjp.at> 0.33-0.4
+- split qpsmtpd-async into a separate package to avoid dependency
+  on ParaDNS.
+
+* Sat May 05 2007 <hjp@hjp.at> 0.33-0.3
+- also unset LANG, LC_ALL and LC_TIME in startup script to prevent
+  locale specific Received headers (bug reported by Dominik Meyer)
+
+* Sun Feb 25 2007 <hjp@hjp.at> 0.33-0.2
+- 0.3x branch has been merged back to trunk. 
+  Got current snapshot (r715) from trunk.
+
+* Sun Feb 25 2007 <hjp@hjp.at> 0.33-0.1
+- Start forkserver via "daemon" (Gavin Carr)
+- Fixed 'service qpsmtpd-forkserver status' (Gavin Carr)
+- Changed policy for config files to noreplace (Gavin Carr)
+
+* Sun Nov 05 2006 <hjp@hjp.at> 0.33-0.0
+- Upgraded to current snapshot from 0.3x branch (which should become
+  0.33 soon-ish)
+- included xinetd-support again.
+
+* Sat Mar 18 2006 <hjp@hjp.at> 0.32-2
+- fix dnsbl to check whether answer fits query.
+- randomize Net::DNS ids for qpsmtpd-forkserver child processes.
+
+* Wed Mar 08 2006 <hjp@hjp.at> 0.32-1
+- New upstream 0.32
+- rc-file unsets PERL_UNICODE (bug #38397)
+
+* Sat Jan 28 2006 <hjp@hjp.at> 0.31.1-3
+- Use ${SOURCE*} macros to refer to source files
+- Avoid invoking rpm and other cleanup in pre section
+- Invoke chkconfig in post.
+- (Thanks to Josko Plazonic for the reporting these problems and
+  suggesting fixes)
+
+* Tue Nov 30 2005 <hjp@hjp.at> 0.31.1-2
+- Revision 170 of plugins/loggin/file_connection:
+  Return DECLINED from open_log.
+  Open log in write_log if it isn't already open.
+
+* Tue Nov 29 2005 <hjp@hjp.at> 0.31.1-1
+- Commented out queue plugins from sample config
+- Added dependencies
+- Create smtpd user if it doesn't exist
+- Added /var/log/qpsmtpd and /var/spool/qpsmtpd
+
+* Sat Nov 26 2005 <hjp@hjp.at>
+- Added file_connection plugin
+- Startup file for qpsmtpd-forkserver now uses --detach and assumes that
+  a suitable logging module is configured (file_connection by default)
+
+* Wed Nov 23 2005 <hjp@hjp.at>
+- Forkserver drops privileges before loading plugins now.
+
+* Sun Nov 20 2005 <hjp@hjp.at>
+- New upstream 0.31.1
+
+* Mon Nov 14 2005 <hjp@hjp.at> 0.31-8
+- New upstream 0.31rc3.
+- pre-connection patch slightly simplified since upstream fixed one of
+  the bugs.
+
+* Tue Aug 23 2005 <hjp@hjp.at>
+- forced INSTALLSITELIB=/usr/lib/perl5/site_perl as suggested by 
+  Charlie Brady.
+
+* Sat Aug 20 2005 <hjp@hjp.at> 0.31-7
+- RC2 from upstream.
+- Removed patches which aren't applied from spec file.
+
+* Fri Jul 22 2005 <hjp@hjp.at> 0.31-6
+- New upstream snapshot from 0.31 branch: svn revision 509.
+
+* Sun Jul 17 2005 <hjp@hjp.at> 0.31-5
+- include only /etc/init.d/qpsmtpd-forkserver, not /etc/init.d
+  it conflicts with old initscripts packages.
+
+* Sun Jul 17 2005 <hjp@hjp.at> 0.31-4
+- removed tabs from forkserver 
+
+* Sun Jul 17 2005 <hjp@hjp.at> 0.31-3
+- added startup script for forkserver
+- changed BuildArchitectures to noarch.
+
+* Sat Jul 16 2005 <hjp@hjp.at> 0.31-2
+- pre-connection hook is now actually called, not just defined.
+
+* Fri Jul 15 2005 <hjp@hjp.at> 0.31-1
+- merged with 0.31. Most of my patches are now in the official release.
+- merged Gavin's per-user-config patch with my dirs patch, since the
+  latter needs a way to turn off logging.
+- added /etc/qpsmtpd/plugin_dir to package.
+
+* Mon Jun 13 2005 <hjp@hjp.at> 0.29-6
+- fixed removal of patch backup files
+- fixed option --pid-file
+
+* Sun Jun 12 2005 <hjp@hjp.at>
+- avoid installing patch backup files
+- split Apache::Qpsmtpd into separate package to avoid dependency hell.
+- fixed URL
+- changed group to Daemons.
+- Fixed installation for newer versions of ExtUtils::MakeMaker
+
+* Wed Jun  1 2005 <hjp@hjp.at> 0.29-5
+- Really don't reap children in signal handler.
+
+* Tue May 31 2005 <hjp@hjp.at> 0.29-4
+- Return 421 for DENYSOFT_DISCONNECT
+- Don't reap children in signal handler.
+
+* Thu May 19 2005 <hjp@hjp.at> 0.29-3
+- removed code to accept paths without <>.
+
+* Thu May 19 2005 <hjp@hjp.at> 0.29-2
+- added QPSMTPD_CONFIG env variable and plugin_dir config.
+- added supplemental groups and support for pid file
+- added shared_connect hook
+- changed log level for SMTP dialog from DEBUG to INFO
+
+* Thu Apr 21 2005 hjp@hjp.at
+- added plugins, /etc and docs.
+
+* Mon Apr 18 2005 hjp@hjp.at
+- Specfile autogenerated
+

plugins/async/check_earlytalker

@@ -0,0 +1,134 @@
+#!perl -w
+
+=head1 NAME
+
+check_earlytalker - Check that the client doesn't talk before we send the SMTP banner
+
+=head1 DESCRIPTION
+
+Checks to see if the remote host starts talking before we've issued a 2xx
+greeting.  If so, we're likely looking at a direct-to-MX spam agent which
+pipelines its entire SMTP conversation, and will happily dump an entire spam
+into our mail log even if later tests deny acceptance.
+
+Depending on configuration, clients which behave in this way are either
+immediately disconnected with a deny or denysoft code, or else are issued this
+on all mail/rcpt commands in the transaction.
+
+=head1 CONFIGURATION
+
+=over 4
+
+=item wait [integer]
+
+The number of seconds to delay the initial greeting to see if the connecting
+host speaks first.  The default is 1.  Do not select a value that is too high,
+or you may be unable to receive mail from MTAs with short SMTP connect or
+greeting timeouts -- these are known to range as low as 30 seconds, and may
+in some cases be configured lower by mailserver admins.  Network transit time
+must also be allowed for.
+
+=item action [string: deny, denysoft, log]
+
+What to do when matching an early-talker -- the options are I<deny>,
+I<denysoft> or I<log>.
+
+If I<log> is specified, the connection will be allowed to proceed as normal,
+and only a warning will be logged.
+
+The default is I<denysoft>.
+
+=item defer-reject [boolean]
+
+When an early-talker is detected, if this option is set to a true value, the
+SMTP greeting will be issued as usual, but all RCPT/MAIL commands will be
+issued a deny or denysoft (depending on the value of I<action>).  The default
+is to react at the SMTP greeting stage by issuing the apropriate response code
+and terminating the SMTP connection.
+
+=item check-at [string: connect, data]
+
+Defines when to check for early talkers, either at connect time (pre-greet pause)
+or at DATA time (pause before sending "354 go ahead").
+
+The default is I<connect>.
+
+Note that defer-reject has no meaning if check-at is I<data>.
+
+=back
+
+=cut
+
+my $MSG = 'Connecting host started transmitting before SMTP greeting';
+
+sub register {
+  my ($self, $qp, @args) = @_;
+
+  if (@args % 2) {
+	$self->log(LOGERROR, "Unrecognized/mismatched arguments");
+	return undef;
+  }
+  $self->{_args} = {
+  	'wait' => 1,
+	'action' => 'denysoft',
+	'defer-reject' => 0,
+	'check-at' => 'connect',
+	@args,
+  };
+  print STDERR "Check at: ", $self->{_args}{'check-at'}, "\n";
+  $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_poll');
+  $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_post');
+  if ($self->{_args}{'check-at'} eq 'connect') {
+    $self->register_hook('mail', 'hook_mail')
+      if $self->{_args}->{'defer-reject'};
+  }
+  1;
+}
+
+sub check_talker_poll {
+  my ($self, $transaction) = @_;
+
+  my $qp = $self->qp;
+  my $conn = $qp->connection;
+  my $check_until = time + $self->{_args}{'wait'};
+  $qp->AddTimer(1, sub { read_now($qp, $conn, $check_until, $self->{_args}{'check-at'}) });
+  return YIELD;
+}
+
+sub read_now {
+  my ($qp, $conn, $until, $phase) = @_;
+
+  if ($qp->has_data) {
+    $qp->log(LOGNOTICE, 'remote host started talking after $phase before we responded');
+    $qp->clear_data if $phase eq 'data';
+    $conn->notes('earlytalker', 1);
+    $qp->run_continuation;
+  }
+  elsif (time >= $until) {
+    # no early talking
+    $qp->run_continuation;
+  }
+  else {
+    $qp->AddTimer(1, sub { read_now($qp, $conn, $until, $phase) });
+  }
+}
+
+sub check_talker_post {
+  my ($self, $transaction) = @_;
+
+  return DECLINED unless $self->connection->notes('earlytalker');
+  return DECLINED if $self->{'defer-reject'};
+  return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny';
+  return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft';
+  return DECLINED; # assume action eq 'log'
+}
+
+sub hook_mail {
+  my ($self, $transaction) = @_;
+
+  return DECLINED unless $self->connection->notes('earlytalker');
+  return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny';
+  return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft';
+  return DECLINED;
+}
+

plugins/async/dns_whitelist_soft

@@ -0,0 +1,88 @@
+#!perl -w
+
+use Qpsmtpd::Plugin::Async::DNSBLBase;
+
+sub init {
+    my $self = shift;
+    my $class = ref $self;
+
+    no strict 'refs';
+    push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
+}
+
+sub hook_connect {
+    my ($self, $transaction) = @_;
+    my $class = ref $self;
+
+    my %whitelist_zones =
+      map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('whitelist_zones');
+
+    return DECLINED unless %whitelist_zones;
+
+    my $remote_ip = $self->connection->remote_ip;
+    my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
+
+    # type TXT lookup only
+    return DECLINED
+      unless $class->lookup($self->qp, [],
+                            [map { "$reversed_ip.$_" } keys %whitelist_zones],
+                           );
+
+    return YIELD;
+}
+
+sub process_txt_result {
+    my ($class, $qp, $result, $query) = @_;
+
+    my $connection = $qp->connection;
+    $connection->notes('whitelisthost', $result)
+      unless $connection->notes('whitelisthost');
+}
+
+sub hook_rcpt {
+    my ($self, $transaction, $rcpt) = @_;
+    my $connection = $self->qp->connection;
+
+    if (my $note = $connection->notes('whitelisthost')) {
+        my $ip = $connection->remote_ip;
+        $self->log(LOGNOTICE, "Host $ip is whitelisted: $note");
+    }
+    return DECLINED;
+}
+
+=head1 NAME
+
+dns_whitelist_soft - dns-based whitelist override for other qpsmtpd plugins
+
+=head1 DESCRIPTION
+
+The dns_whitelist_soft plugin allows selected host to be whitelisted as
+exceptions to later plugin processing.  It is most suitable for multisite
+installations, so that the whitelist is stored in one location and available
+from all.
+
+=head1 CONFIGURATION
+
+To enable the plugin, add it to the ~qpsmtpd/config/plugins file as usual.
+It should precede any plugins whose rejections you wish to override.  You may
+have to alter those plugins to check the appropriate notes field.
+
+Several configuration files are supported, corresponding to different
+parts of the SMTP conversation:
+
+=over 4
+
+=item whitelist_zones
+
+Any IP address listed in the whitelist_zones file is queried using
+the connecting MTA's IP address.  Any A or TXT answer means that the
+remote HOST address can be selectively exempted at other stages by plugins
+testing for a 'whitelisthost' connection note.
+
+=back
+
+NOTE: in contrast to the non-async version, the other 'connect' hooks
+fired after the 'connect' hook of this plugin will see the 'whitelisthost'
+connection note, if set by this plugin.
+
+=cut

plugins/async/dnsbl

@@ -0,0 +1,202 @@
+#!perl -w
+
+use Qpsmtpd::Plugin::Async::DNSBLBase;
+
+sub init {
+    my ($self, $qp, $denial) = @_;
+    my $class = ref $self;
+
+    {
+        no strict 'refs';
+        push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
+    }
+
+    if (defined $denial and $denial =~ /^disconnect$/i) {
+        $self->{_dnsbl}->{DENY} = DENY_DISCONNECT;
+    }
+    else {
+        $self->{_dnsbl}->{DENY} = DENY;
+    }
+}
+
+sub hook_connect {
+    my ($self, $transaction) = @_;
+    my $class = ref $self;
+
+    my $remote_ip = $self->connection->remote_ip;
+
+    my $allow =
+      grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) }
+      $self->qp->config('dnsbl_allow');
+    return DECLINED if $allow;
+
+    my %dnsbl_zones =
+      map { (split /:/, $_, 2)[0, 1] } $self->qp->config('dnsbl_zones');
+    return DECLINED unless %dnsbl_zones;
+
+    my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
+
+    my @A_zones   = grep { defined($dnsbl_zones{$_}) } keys %dnsbl_zones;
+    my @TXT_zones = grep { !defined($dnsbl_zones{$_}) } keys %dnsbl_zones;
+
+    if (@A_zones) {
+
+        # message templates for responding to the client
+        $self->connection->notes(
+            dnsbl_templates => {
+                map {
+                    +"$reversed_ip.$_" => $dnsbl_zones{$_}
+                  } @A_zones
+            }
+        );
+    }
+
+    return DECLINED
+      unless $class->lookup($self->qp,
+                            [map { "$reversed_ip.$_" } @A_zones],
+                            [map { "$reversed_ip.$_" } @TXT_zones],
+                           );
+
+    return YIELD;
+}
+
+sub process_a_result {
+    my ($class, $qp, $result, $query) = @_;
+
+    my $conn = $qp->connection;
+    return if $class->connection->notes('dnsbl');
+
+    my $templates = $class->connection->notes('dnsbl_templates');
+    my $ip        = $conn->remote_ip;
+
+    my $template = $templates->{$query};
+    $template =~ s/%IP%/$ip/g;
+
+    $class->connection->notes('dnsbl', $template);
+}
+
+sub process_txt_result {
+    my ($class, $qp, $result, $query) = @_;
+
+    my $conn = $class->connection;
+    $conn->notes('dnsbl', $result) unless $conn->notes('dnsbl');
+}
+
+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 '') {
+        my $result    = $ENV{'RBLSMTPD'};
+        my $remote_ip = $self->connection->remote_ip;
+        $result =~ s/%IP%/$remote_ip/g;
+        return (DENY, join(" ", $self->qp->config('dnsbl_rejectmsg'), $result));
+    }
+
+    my $note = $self->connection->notes('dnsbl');
+    return (DENY, $note) if $note;
+    return DECLINED;
+}
+
+=head1 NAME
+
+dnsbl - handle DNS BlackList lookups
+
+=head1 DESCRIPTION
+
+Plugin that checks the IP address of the incoming connection against
+a configurable set of RBL services.
+
+=head1 Configuration files
+
+This plugin uses the following configuration files. All of these are optional.
+However, not specifying dnsbl_zones is like not using the plugin at all.
+
+=over 4
+
+=item dnsbl_zones
+
+Normal ip based dns blocking lists ("RBLs") which contain TXT records are
+specified simply as:
+
+  relays.ordb.org
+  spamsources.fabel.dk
+
+To configure RBL services which do not contain TXT records in the DNS,
+but only A records (e.g. the RBL+ at http://www.mail-abuse.org), specify your
+own error message to return in the SMTP conversation after a colon e.g.
+
+  rbl-plus.mail-abuse.org:You are listed at - http://http://www.mail-abuse.org/cgi-bin/lookup?%IP%
+
+The string %IP% will be replaced with the IP address of incoming connection.
+Thus a fully specified file could be:
+
+  sbl-xbl.spamhaus.org
+  list.dsbl.org
+  rbl-plus.mail-abuse.ja.net:Listed by rbl-plus.mail-abuse.ja.net - see <URL:http://www.mail-abuse.org/cgi-bin/lookup?%IP%>
+  relays.ordb.org
+
+=item dnsbl_allow
+
+List of allowed ip addresses that bypass RBL checking. Format is one entry per line,
+with either a full IP address or a truncated IP address with a period at the end.
+For example:
+
+  192.168.1.1
+  172.16.33.
+
+NB the environment variable RBLSMTPD is considered before this file is 
+referenced. See below.
+
+=item dnsbl_rejectmsg
+
+A textual message that is sent to the sender on an RBL failure. The TXT record
+from the RBL list is also sent, but this file can be used to indicate what
+action the sender should take.
+
+For example:
+
+   If you think you have been blocked in error, then please forward
+   this entire error message to your ISP so that they can fix their problems.
+   The next line often contains a URL that can be visited for more information.
+
+=back
+
+=head1 Environment Variables
+
+=head2 RBLSMTPD
+
+The environment variable RBLSMTPD is supported and mimics the behaviour of
+Dan Bernstein's rblsmtpd. The exception to this is the '-' char at the 
+start of RBLSMTPD which is used to force a hard error in Dan's rblsmtpd.
+NB I don't really see the benefit
+of using a soft error for a site in an RBL list. This just complicates
+things as it takes 7 days (or whatever default period) before a user
+gets an error email back. In the meantime they are complaining that their
+emails are being "lost" :(
+
+=over 4
+
+=item RBLSMTPD is set and non-empty
+
+The contents are used as the SMTP conversation error.
+Use this for forcibly blocking sites you don't like
+
+=item RBLSMTPD is set, but empty
+
+In this case no RBL checks are made.
+This can be used for local addresses.
+
+=item RBLSMTPD is not set
+
+All RBL checks will be made.
+This is the setting for remote sites that you want to check against RBL.
+
+=back
+
+=head1 Revisions
+
+See: http://cvs.perl.org/viewcvs/qpsmtpd/plugins/dnsbl
+
+=cut

plugins/async/queue/smtp-forward

@@ -0,0 +1,400 @@
+#!perl -w
+
+=head1 NAME
+
+smtp-forward
+
+=head1 DESCRIPTION
+
+This plugin forwards the mail via SMTP to a specified server, rather than
+delivering the email locally.
+
+=head1 CONFIG
+
+It takes one required parameter, the IP address or hostname to forward to. 
+
+  async/queue/smtp-forward 10.2.2.2
+
+Optionally you can also add a port:
+
+  async/queue/smtp-forward 10.2.2.2 9025
+
+=cut
+
+use Qpsmtpd::Constants;
+
+sub register {
+    my ($self, $qp) = @_;
+    
+    $self->register_hook(queue => "start_queue");
+    $self->register_hook(queue => "finish_queue");
+}
+
+sub init {
+    my ($self, $qp, @args) = @_;
+
+    if (@args > 0) {
+        if ($args[0] =~ /^([\.\w_-]+)$/) {
+            $self->{_smtp_server} = $1;
+        }
+        else {
+            die "Bad data in smtp server: $args[0]";
+        }
+        $self->{_smtp_port} = 25;
+        if (@args > 1 and $args[1] =~ /^(\d+)$/) {
+            $self->{_smtp_port} = $1;
+        }
+    
+        $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 2);
+    }
+    else {
+        die("No SMTP server specified in smtp-forward config");
+    }
+
+}
+
+sub start_queue {
+    my ($self, $transaction) = @_;
+    
+    my $qp = $self->qp;
+    my $SERVER = $self->{_smtp_server};
+    my $PORT   = $self->{_smtp_port};
+    $self->log(LOGINFO, "forwarding to $SERVER:$PORT");
+    
+    $transaction->notes('async_sender', 
+        AsyncSMTPSender->new($SERVER, $PORT, $qp, $self, $transaction)
+    );
+    
+    return YIELD;
+}
+
+sub finish_queue {
+    my ($self, $transaction) = @_;
+    
+    my $sender = $transaction->notes('async_sender');
+    $transaction->notes('async_sender', undef);
+    
+    my ($rc, $msg) = $sender->results;
+    
+    return $rc, $msg;
+}
+
+package AsyncSMTPSender;
+
+use IO::Socket;
+
+use base qw(Danga::Socket);
+use fields qw(
+    qp
+    pkg
+    tran
+    state
+    rcode
+    rmsg
+    buf
+    command
+    resp
+    to
+    );
+
+use constant ST_CONNECTING => 0;
+use constant ST_CONNECTED  => 1;
+use constant ST_COMMANDS   => 2;
+use constant ST_DATA       => 3;
+
+use Qpsmtpd::Constants;
+
+sub new {
+    my ($self, $server, $port, $qp, $pkg, $transaction) = @_;
+    $self = fields::new($self) unless ref $self;
+    
+    my $sock = IO::Socket::INET->new(
+        PeerAddr => $server,
+        PeerPort => $port,
+        Blocking  => 0,
+    ) or die "Error connecting to server $server:$port : $!\n";
+
+    IO::Handle::blocking($sock, 0);
+    binmode($sock, ':raw');
+    
+    $self->{qp} = $qp;
+    $self->{pkg} = $pkg;
+    $self->{tran} = $transaction;
+    $self->{state} = ST_CONNECTING;
+    $self->{rcode} = DECLINED;
+    $self->{command} = 'connect';
+    $self->{buf} = '';
+    $self->{resp} = [];
+    # copy the recipients so we can pop them off one by one
+    $self->{to} = [ $transaction->recipients ];
+    
+    $self->SUPER::new($sock);
+    # Watch for write first, this is when the TCP session is established.
+    $self->watch_write(1);
+
+    return $self;
+}
+
+sub results {
+    my AsyncSMTPSender $self = shift;
+    return ( $self->{rcode}, $self->{rmsg} );
+}
+
+sub log {
+    my AsyncSMTPSender $self = shift;
+    $self->{qp}->log(@_);
+}
+
+sub cont {
+    my AsyncSMTPSender $self = shift;
+    $self->{qp}->run_continuation;
+}
+
+sub command {
+    my AsyncSMTPSender $self = shift;
+    my ($command, $params) = @_;
+    $params ||= '';
+    
+    $self->log(LOGDEBUG, ">> $command $params");
+    
+    $self->write(($command =~ m/ / ? "$command:" : $command)
+      . ($params ? " $params" : "") . "\r\n");
+    $self->watch_read(1);
+    $self->{command} = ($command =~ /(\S+)/)[0];
+}
+
+sub handle_response {
+    my AsyncSMTPSender $self = shift;
+    
+    my $method = "cmd_" . lc($self->{command});
+    
+    $self->$method(@_);
+}
+
+sub cmd_connect {
+    my AsyncSMTPSender $self = shift;
+    my ($code, $response) = @_;
+    
+    if ($code != 220) {
+        $self->{rmsg} = "Error on connect: @$response";
+        $self->close;
+        $self->cont;
+    }
+    else {
+        my $host = $self->{qp}->config('me');
+        print "HELOing with $host\n";
+        $self->command((join '', @$response) =~ m/ ESMTP/ ? "EHLO" : "HELO", $host);
+    }
+}
+
+sub cmd_helo {
+    my AsyncSMTPSender $self = shift;
+    my ($code, $response) = @_;
+    
+    if ($code != 250) {
+        $self->{rmsg} = "Error on HELO: @$response";
+        $self->close;
+        $self->cont;
+    }
+    else {
+        $self->command("MAIL", "FROM:" . $self->{tran}->sender->format);
+    }
+}
+
+sub cmd_ehlo {
+    my AsyncSMTPSender $self = shift;
+    my ($code, $response) = @_;
+    
+    if ($code != 250) {
+        $self->{rmsg} = "Error on EHLO: @$response";
+        $self->close;
+        $self->cont;
+    }
+    else {
+        $self->command("MAIL", "FROM:" . $self->{tran}->sender->format);
+    }
+}
+
+sub cmd_mail {
+    my AsyncSMTPSender $self = shift;
+    my ($code, $response) = @_;
+    
+    if ($code != 250) {
+        $self->{rmsg} = "Error on MAIL FROM: @$response";
+        $self->close;
+        $self->cont;
+    }
+    else {
+        $self->command("RCPT", "TO:" . shift(@{$self->{to}})->format);
+    }
+}
+
+sub cmd_rcpt {
+    my AsyncSMTPSender $self = shift;
+    my ($code, $response) = @_;
+    
+    if ($code != 250) {
+        $self->{rmsg} = "Error on RCPT TO: @$response";
+        $self->close;
+        $self->cont;
+    }
+    else {
+        if (@{$self->{to}}) {
+            $self->command("RCPT", "TO:" . shift(@{$self->{to}})->format);
+        }
+        else {
+            $self->command("DATA");
+        }
+    }
+}
+
+sub cmd_data {
+    my AsyncSMTPSender $self = shift;
+    my ($code, $response) = @_;
+    
+    if ($code != 354) {
+        $self->{rmsg} = "Error on DATA: @$response";
+        $self->close;
+        $self->cont;
+    }
+    else {
+        # $self->{state} = ST_DATA;
+        $self->datasend($self->{tran}->header->as_string);
+        $self->{tran}->body_resetpos;
+        my $write_buf = '';
+        while (my $line = $self->{tran}->body_getline) {
+            $line =~ s/\r?\n/\r\n/;
+            $write_buf .= $line;
+            if (length($write_buf) >= 131072) { # 128KB, arbitrary value
+                $self->log(LOGDEBUG, ">> $write_buf");
+                $self->datasend($write_buf);
+                $write_buf = '';
+            }
+        }
+        if (length($write_buf)) {
+            $self->log(LOGDEBUG, ">> $write_buf");
+            $self->datasend($write_buf);
+        }
+        $self->write(".\r\n");
+        $self->{command} = "DATAEND";
+    }
+}
+
+sub cmd_dataend {
+    my AsyncSMTPSender $self = shift;
+    my ($code, $response) = @_;
+    
+    if ($code != 250) {
+        $self->{rmsg} = "Error after DATA: @$response";
+        $self->close;
+        $self->cont;
+    }
+    else {
+        $self->command("QUIT");
+    }
+}
+
+sub cmd_quit {
+    my AsyncSMTPSender $self = shift;
+    my ($code, $response) = @_;
+    
+    $self->{rcode} = OK;
+    $self->{rmsg} = "Queued!";
+    $self->close;
+    $self->cont;
+}
+
+sub datasend {
+    my AsyncSMTPSender $self = shift;
+    my ($data) = @_;
+    $data =~ s/^\./../mg;
+    $self->write(\$data);
+}
+
+sub event_read {
+    my AsyncSMTPSender $self = shift;
+    
+    if ($self->{state} == ST_CONNECTED) {
+        $self->{state} = ST_COMMANDS;
+    }
+
+    if ($self->{state} == ST_COMMANDS) {
+        my $in = $self->read(1024);
+        if (!$in) {
+            # XXX: connection closed
+            $self->close("lost connection");
+            return;
+        }
+    
+        my @lines = split /\r?\n/, $self->{buf} . $$in, -1;
+        $self->{buf} = delete $lines[-1];
+    
+        for(@lines) {
+            if (my ($code, $cont, $rest) = /^([0-9]{3})([ -])(.*)/) {
+                $self->log(LOGDEBUG, "<< $code$cont$rest");
+                push @{$self->{resp}}, $rest;
+
+                if($cont eq ' ') {
+                    $self->handle_response($code, $self->{resp});
+                    $self->{resp} = [];
+                }
+            }
+            else {
+                $self->log(LOGERROR, "Unrecognised SMTP response line: $_");
+                $self->{rmsg} = "Error from upstream SMTP server";
+                $self->close;
+                $self->cont;
+            }
+        }
+    }
+    else {
+        $self->log(LOGERROR, "SMTP Session occurred out of order");
+        $self->close;
+        $self->cont;
+    }
+}
+
+sub event_write {
+    my AsyncSMTPSender $self = shift;
+
+    if ($self->{state} == ST_CONNECTING) {
+        $self->watch_write(0);
+        $self->{state} = ST_CONNECTED;
+        $self->watch_read(1);
+    }
+    elsif (0 && $self->{state} == ST_DATA) {
+        # send more data
+        if (my $line = $self->{tran}->body_getline) {
+            $self->log(LOGDEBUG, ">> $line");
+            $line =~ s/\r?\n/\r\n/;
+            $self->datasend($line);
+        }
+        else {
+            # no more data.
+            $self->log(LOGINFO, "No more data");
+            $self->watch_write(0);
+            $self->{state} = ST_COMMANDS;
+        }
+    }
+    else {
+        $self->write(undef);
+    }
+}
+
+sub event_err {
+    my ($self) = @_;
+    eval { $self->read(1); }; # gives us the correct error in errno
+    $self->{rmsg} = "Read error from remote server: $!";
+    #print "lost connection: $!\n";
+    $self->close;
+    $self->cont;
+}
+
+sub event_hup {
+    my ($self) = @_;
+    eval { $self->read(1); }; # gives us the correct error in errno
+    $self->{rmsg} = "HUP error from remote server: $!";
+    #print "lost connection: $!\n";
+    $self->close;
+    $self->cont;
+}

plugins/async/require_resolvable_fromhost

@@ -0,0 +1,181 @@
+#!perl -w
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
+use Qpsmtpd::DSN;
+use Qpsmtpd::TcpServer;
+
+#use ParaDNS;  # moved into register
+use Socket;
+
+my %invalid  = ();
+my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6();
+
+sub register {
+    my ( $self, $qp ) = @_;
+    
+    foreach my $i ( $self->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;
+        }
+    }
+
+    eval 'use ParaDNS';
+    if ( $@ ) {
+        warn "could not load ParaDNS, plugin disabled";
+        return DECLINED;
+    };
+    $self->register_hook( mail => 'hook_mail_start' );
+    $self->register_hook( mail => 'hook_mail_done' );
+}
+
+sub hook_mail_start {
+    my ( $self, $transaction, $sender ) = @_;
+    
+    return DECLINED
+      if ($self->connection->notes('whitelisthost'));
+
+    if ( $sender ne '<>' ) {
+
+        unless ( $sender->host ) {
+            # default of addr_bad_from_system is DENY, we use DENYSOFT here to
+            # get the same behaviour as without Qpsmtpd::DSN...
+            return Qpsmtpd::DSN->addr_bad_from_system( DENYSOFT,
+                "FQDN required in the envelope sender" );
+        }
+
+        return DECLINED if $sender->host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
+
+        unless ($self->check_dns( $sender->host )) {
+            return Qpsmtpd::DSN->temp_resolver_failed(
+                "Could not resolve " . $sender->host );
+        }
+
+        return YIELD;
+    }
+
+    return DECLINED;
+}
+
+sub hook_mail_done {
+    my ( $self, $transaction, $sender ) = @_;
+    
+    return DECLINED
+      if ( $self->connection->notes('whitelisthost') );
+
+    if ( $sender ne "<>" && !$transaction->notes('resolvable_fromhost') ) {
+        # default of temp_resolver_failed is DENYSOFT
+        return Qpsmtpd::DSN->temp_resolver_failed(
+            "Could not resolve " . $sender->host );
+    }
+    return DECLINED;
+}
+
+sub check_dns {
+    my ( $self, $host ) = @_;
+    my @host_answers;
+
+    my $qp = $self->qp;
+    $qp->input_sock->pause_read;
+    
+    my $a_records = [];
+    my $num_queries = 1;    # queries in progress
+    my $mx_found = 0;
+
+    ParaDNS->new(
+        callback  => sub {
+            my $mx = shift;
+            return if $mx =~ /^[A-Z]+$/; # error
+
+            my $addr = $mx->[0];
+            $mx_found = 1;
+
+            $num_queries++;
+            ParaDNS->new(
+                callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; },
+                finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) },
+                host     => $addr,
+                type     => 'A',
+            );
+
+            if ($has_ipv6) {
+                $num_queries++;
+                ParaDNS->new(
+                    callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; },
+                    finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) },
+                    host     => $addr,
+                    type     => 'AAAA',
+                );
+            }
+        },
+        finished  => sub {
+
+            unless ($mx_found) {
+
+                $num_queries++;
+                ParaDNS->new(
+                    callback  => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; },
+                    finished  => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) },
+                    host      => $host,
+                    type      => 'A',
+                );
+
+                if ($has_ipv6) {
+                    $num_queries++;
+                    ParaDNS->new(
+                        callback  => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; },
+                        finished  => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) },
+                        host      => $host,
+                        type      => 'AAAA',
+                   );
+                }
+
+            }
+
+            $num_queries--;
+            $self->finish_up($qp, $a_records, $num_queries);
+        },
+        host      => $host,
+        type      => 'MX',
+    ) or $qp->input_sock->continue_read, return;
+
+    return 1;
+}
+
+sub finish_up {
+    my ($self, $qp, $a_records, $num_queries) = @_;
+
+    return if defined $qp->transaction->notes('resolvable_fromhost');
+
+    foreach my $addr (@$a_records) {
+        if (is_valid($addr)) {
+            $qp->transaction->notes('resolvable_fromhost', 1);
+            $qp->input_sock->continue_read;
+            $qp->run_continuation;
+            return;
+        }
+    }
+    
+    unless ($num_queries) {
+        # all queries returned no valid response
+        $qp->transaction->notes('resolvable_fromhost', 0);
+        $qp->input_sock->continue_read;
+        $qp->run_continuation;
+    }
+}
+
+sub is_valid {
+    my $ip = shift;
+    my ( $net, $mask );
+    foreach $net ( keys %invalid ) {
+        $mask = $invalid{$net};
+        $mask = pack "B32", "1" x ($mask) . "0" x ( 32 - $mask );
+        return 0
+          if join( ".", unpack( "C4", inet_aton($ip) & $mask ) ) eq $net;
+    }
+    return 1;
+}

plugins/async/rhsbl

@@ -0,0 +1,92 @@
+#!perl -w
+
+use Qpsmtpd::Plugin::Async::DNSBLBase;
+
+sub init {
+    my $self = shift;
+    my $class = ref $self;
+
+    no strict 'refs';
+    push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
+}
+
+sub hook_mail {
+    my ($self, $transaction, $sender) = @_;
+    my $class = ref $self;
+
+    return DECLINED if $sender->format eq '<>';
+
+    my %rhsbl_zones =
+      map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('rhsbl_zones');
+    return DECLINED unless %rhsbl_zones;
+
+    my $sender_host = $sender->host;
+
+    my @A_zones   = grep { defined($rhsbl_zones{$_}) } keys %rhsbl_zones;
+    my @TXT_zones = grep { !defined($rhsbl_zones{$_}) } keys %rhsbl_zones;
+
+    if (@A_zones) {
+
+        # message templates for responding to the client
+        $transaction->notes(rhsbl_templates =>
+                     {map { +"$sender_host.$_" => $rhsbl_zones{$_} } @A_zones});
+    }
+
+    return DECLINED
+      unless $class->lookup($self->qp,
+                            [map { "$sender_host.$_" } @A_zones],
+                            [map { "$sender_host.$_" } @TXT_zones],
+                           );
+
+    return YIELD;
+}
+
+sub process_a_result {
+    my ($class, $qp, $result, $query) = @_;
+
+    my $transaction = $qp->transaction;
+    $transaction->notes('rhsbl',
+                        $transaction->notes('rhsbl_templates')->{$query})
+      unless $transaction->notes('rhsbl');
+}
+
+sub process_txt_result {
+    my ($class, $qp, $result, $query) = @_;
+
+    my $transaction = $qp->transaction;
+    $transaction->notes('rhsbl', $result) unless $transaction->notes('rhsbl');
+}
+
+sub hook_rcpt {
+    my ($self, $transaction, $rcpt) = @_;
+    my $host = $transaction->sender->host;
+
+    my $note = $transaction->notes('rhsbl');
+    return (DENY, "Mail from $host rejected because it $note") if $note;
+    return DECLINED;
+}
+
+=head1 NAME
+
+rhsbl - handle RHSBL lookups
+
+=head1 DESCRIPTION
+
+Pluging that checks the host part of the sender's address against a
+configurable set of RBL services.
+
+=head1 CONFIGURATION
+
+This plugin reads the lists to use from the rhsbl_zones configuration
+file. Normal domain based dns blocking lists ("RBLs") which contain TXT
+records are specified simply as:
+
+  dsn.rfc-ignorant.org
+
+To configure RBL services which do not contain TXT records in the DNS,
+but only A records, specify, after a whitespace, your own error message
+to return in the SMTP conversation e.g.
+
+  abuse.rfc-ignorant.org does not support abuse@domain
+
+=cut

plugins/async/uribl

@@ -0,0 +1,142 @@
+#!perl -w
+
+use Qpsmtpd::Plugin::Async::DNSBLBase;
+
+use strict;
+use warnings;
+
+sub init {
+    my ($self, $qp, %args) = @_;
+    my $class = ref $self;
+
+    $self->isa_plugin("uribl");
+    {
+        no strict 'refs';
+        push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
+    }
+
+    $self->SUPER::init($qp, %args);
+}
+
+sub register {
+    my $self = shift;
+
+    $self->register_hook('data_post', 'start_data_post');
+    $self->register_hook('data_post', 'finish_data_post');
+}
+
+sub start_data_post {
+    my ($self, $transaction) = @_;
+    my $class = ref $self;
+
+    my @names;
+
+    my $queries = $self->lookup_start($transaction, sub {
+        my ($self, $name) = @_;
+        push @names, $name;
+    });
+
+    my @hosts;
+    foreach my $z (keys %{$self->{uribl_zones}}) {
+        push @hosts, map { "$_.$z" } @names;
+    }
+
+    $transaction->notes(uribl_results => {});
+    $transaction->notes(uribl_zones => $self->{uribl_zones});
+
+    return DECLINED
+        unless @hosts && $class->lookup($self->qp, [ @hosts ], [ @hosts ]);
+
+    return YIELD;
+}
+
+sub finish_data_post {
+    my ($self, $transaction) = @_;
+
+    my $matches = $self->collect_results($transaction);
+    for (@$matches) {
+        $self->log(LOGWARN, $_->{desc});
+        if ($_->{action} eq 'add-header') {
+            $transaction->header->add('X-URIBL-Match', $_->{desc});
+        } elsif ($_->{action} eq 'deny') {
+            return (DENY, $_->{desc});
+        } elsif ($_->{action} eq 'denysoft') {
+            return (DENYSOFT, $_->{desc});
+        }
+    }
+    return DECLINED;
+}
+
+sub init_resolver { }
+
+sub process_a_result {
+    my ($class, $qp, $result, $query) = @_;
+
+    my $transaction = $qp->transaction;
+    my $results = $transaction->notes('uribl_results');
+    my $zones = $transaction->notes('uribl_zones');
+
+    foreach my $z (keys %$zones) {
+        if ($query =~ /^(.*)\.$z$/) {
+            my $name = $1;
+            $results->{$z}->{$name}->{a} = $result;
+        }
+    }
+}
+
+sub process_txt_result {
+    my ($class, $qp, $result, $query) = @_;
+
+    my $transaction = $qp->transaction;
+    my $results = $transaction->notes('uribl_results');
+    my $zones = $transaction->notes('uribl_zones');
+
+    foreach my $z (keys %$zones) {
+        if ($query =~ /^(.*)\.$z$/) {
+            my $name = $1;
+            $results->{$z}->{$name}->{txt} = $result;
+        }
+    }
+}
+
+sub collect_results {
+    my ($self, $transaction) = @_;
+
+    my $results = $transaction->notes('uribl_results');
+
+    my @matches;
+    foreach my $z (keys %$results) {
+        foreach my $n (keys %{$results->{$z}}) {
+            if (exists $results->{$z}->{$n}->{a}) {
+                if ($self->evaluate($z, $results->{$z}->{$n}->{a})) {
+                    $self->log(LOGDEBUG, "match $n in $z");
+                    push @matches, {
+                        action => $self->{uribl_zones}->{$z}->{action},
+                        desc => "$n in $z: " .
+                            ($results->{$z}->{$n}->{txt} || $results->{$z}->{$n}->{a}),
+                    };
+                }
+            }
+        }
+    }
+
+    return \@matches;
+}
+
+=head1 NAME
+
+uribl - URIBL blocking plugin for qpsmtpd
+
+=head1 DESCRIPTION
+
+This plugin implements DNSBL lookups for URIs found in spam, such as that
+implemented by SURBL (see E<lt>http://surbl.org/E<gt>).  Incoming messages are
+scanned for URIs, which are then checked against one or more URIBLs in a
+fashion similar to DNSBL systems.
+
+=head1 CONFIGURATION
+
+See the documentation of the non-async version. The timeout config option is
+ignored, the ParaDNS timeout is used instead.
+
+=cut

plugins/auth/auth_checkpassword

@@ -0,0 +1,192 @@
+#!perl -w
+
+=head1 NAME
+
+auth_checkpassword - Authenticate against a DJB style checkpassword program
+
+=head1 DESCRIPTION
+
+This plugin authenticates users against a DJB style checkpassword
+program. Unlike previous checkpassword implementations, this plugin
+expects qpsmtpd to be running as the qpsmtpd user. Privilege
+escalation can be attained by running the checkpassword binary setuid
+or with sudo.
+
+=head1 CONFIGURATION
+
+Configure the path to your checkpassword binary. You can configure this in
+config/plugins by defining the checkpw and true arguments as follows:
+
+ auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /bin/true
+
+or by editing the config file config/smtpauth-checkpassword:
+
+ echo "/usr/local/vpopmail/bin/vchkpw /bin/true" > ~qpsmtpd/config/smtpauth-checkpassword
+
+vchkpw is the checkpassword program provided by vpopmail. Substitute
+your own checkpassword app as appropriate.
+
+If you are using vchkpw and this plugin is being executed by a user ID
+other than 89 or 0 (as is the default), and the vchkpw binary is not
+setuid (as is the default), this plugin will automatically prepend the
+vchkpw command with sudo. If that is the case, you must configure sudo
+by adding these two lines to your sudoers file:
+
+  Defaults:qpsmtpd	closefrom_override
+  qpsmtpd  ALL = (ALL) NOPASSWD: /usr/local/vpopmail/bin/vchkpw
+
+The closefrom_override option is necessary because, by default, sudo
+appropriates the first 3 file descriptors. Those descriptors are
+necessary to communicate with the checkpassword program. If you run
+qpsmtpd as some other user, adjust the sudo lines approriately.
+
+Using sudo is preferable to enabling setuid on the vchkpw binary. If
+you reinstall vpopmail and the setuid bit is lost, this plugin will be
+broken.
+
+=head1 SEE ALSO
+
+If you are using this plugin with vpopmail, please read the VPOPMAIL
+section in docs/authentication.pod
+
+=head1 DIAGNOSTICS
+
+Is the path in the config/smtpauth-checkpassword correct?
+
+Is the path to true in config/smtpauth-checkpassword correct?
+
+Is qpsmtpd running as the qpsmtpd user? If not, did you adjust the
+sudo configuration appropriately?
+
+If you are not using sudo, did you remember to make the vchkpw binary
+setuid (chmod 4711 ~vpopmail/bin/vchkpw)?
+
+While writing this plugin, I first wrote myself a little test script,
+which helped me identify the sudo closefrom_override issue. Here is
+that script:
+
+   #!/usr/bin/perl
+   use strict;
+   my $sudo = "/usr/local/bin/sudo";
+   $sudo .= " -C4 -u vpopmail";
+   my $vchkpw = "/usr/local/vpopmail/bin/vchkpw";
+   my $true   = "/bin/true";
+
+   open(CPW,"|$sudo $vchkpw $true 3<&0");
+   printf(CPW "%s\0%s\0Y123456\0",'user@example.com','pa55word');
+   close(CPW);
+
+   my $status = $?;
+   print "FAIL\n" and exit if ( $status != 0 );
+   print "OK\n";
+
+Save that script to vchkpw.pl and then run it as the same user that
+qpsmtpd runs as:
+
+  setuidgid qpsmtpd perl vchkpw.pl
+
+If you aren't using sudo, then remove $sudo from the open line.
+
+=head1 ACKNOWLEDGEMENTS
+
+based upon authcheckpassword by Michael Holzt
+and adapted by Johan Almqvist 2006-01-18
+
+=head1 AUTHOR
+
+Matt Simerson <msimerson@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2010 Matt Simerson
+
+This plugin is licensed under the same terms as the qpsmtpd package itself.
+Please see the LICENSE file included with qpsmtpd for details.
+
+=cut
+
+sub register {
+    my ($self, $qp, %args ) = @_;
+
+    my ($checkpw, $true) = $self->get_checkpw( \%args );
+    return DECLINED if ! $checkpw || ! $true;
+
+    $self->connection->notes('auth_checkpassword_bin', $checkpw);
+    $self->connection->notes('auth_checkpassword_true', $true);
+
+    $self->register_hook('auth-plain', 'auth_checkpassword');
+    $self->register_hook('auth-login', 'auth_checkpassword');
+}
+
+sub auth_checkpassword {
+    my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
+      @_;
+
+    my $binary = $self->connection->notes('auth_checkpassword_bin');
+    my $true = $self->connection->notes('auth_checkpassword_true');
+    chomp ($binary, $true);
+
+    my $sudo = get_sudo($binary);
+
+    $self->log(LOGDEBUG, "auth_checkpassword: $sudo $binary $true 3<&0");
+    open(CPW, "|$sudo $binary $true 3<&0");
+    printf(CPW "%s\0%s\0Y123456\0", $user, $passClear);
+    close(CPW);
+
+    my $status = $?;
+
+    if ($status != 0) {
+        $self->log(LOGNOTICE, "authentication failed ($status)");
+        return (DECLINED);
+    };
+
+    $self->connection->notes('authuser', $user);
+    return (OK, "auth_checkpassword");
+}
+
+sub get_checkpw {
+    my ($self, $args) = @_;
+
+    my ($checkpw) = $args->{checkpw} =~ /^(.*)$/ if $args->{checkpw}; # untaint
+    my ($true)    = $args->{true} =~ /^(.*)$/ if $args->{true};       # untaint
+
+    return ( $checkpw, $true )
+        if ( $checkpw && $true && -x $checkpw && -x $true );
+
+    my $missing_config = "disabled due to invalid configuration. See 'perldoc plugins/auth/auth_checkpassword' for how to configure.";
+
+    if ( ! $self->qp->config('smtpauth-checkpassword') ) {
+        $self->log(LOGERROR, $missing_config );
+        return;
+    };
+
+    $self->log(LOGNOTICE, "reading config from smtpauth-checkpassword");
+    my $config = $self->qp->config("smtpauth-checkpassword");
+    ($checkpw, $true) = $config =~ /^(\S+)\s+(\S+)\s*$/;
+
+    if ( ! $checkpw || ! $true || ! -x $checkpw || ! -x $true ) {
+        $self->log(LOGERROR, $missing_config );
+        return;
+    };
+    return ($checkpw, $true);
+};
+
+sub get_sudo {
+    my $binary = shift;
+
+    return '' if $> == 0;                            # running as root
+    return '' if $> == 89 && $binary =~ /vchkpw$/;   # running as vpopmail
+
+    my $mode = (stat($binary))[2];
+    $mode = sprintf "%lo", $mode & 07777;
+    return '' if $mode eq '4711';                    # $binary is setuid
+
+    my $sudo = `which sudo` || '/usr/local/bin/sudo';
+    return '' if ! -x $sudo;
+
+    $sudo .= ' -C4';    # prevent sudo from clobbering file descriptor 3
+
+    return $sudo if $binary !~ /vchkpw$/;
+    return "$sudo -u vpopmail";
+}
+

plugins/auth/auth_cvm_unix_local

@@ -0,0 +1,130 @@
+#!perl -w
+
+=head1 NAME
+
+auth_cvm_unix_local - SMTP AUTH LOGIN module using 
+Bruce Guenther's Credential Validation Module (CVM) 
+    http://untroubled.org/cvm/
+
+=head1 SYNOPSIS
+
+In config/plugins:
+
+  auth/auth_cvm_unix_local \
+	cvm_socket /var/lib/cvm/cvm-unix-local.socket	\
+	enable_smtp no \
+	enable_ssmtp yes
+
+=head1 BUGS
+
+- Should probably handle auth-cram-md5 as well. However, this requires
+access to the plain text password. We could store a separate database
+of passwords purely for SMTP AUTH, for example as an optional 
+SMTPAuthPassword property of an account in the esmith::AccountsDB;
+
+=head1 DESCRIPTION
+
+This plugin implements an authentication plugin using Bruce Guenther's
+Credential Validation Module (http://untroubled.org/cvm).
+
+=head1 AUTHOR
+
+Copyright 2005 Gordon Rowell <gordonr@gormand.com.au>
+
+This software is free software and may be distributed under the same
+terms as qpsmtpd itself.
+
+=head1 VERSION
+
+Version $Id: auth_cvm_unix_local,v 1.1 2005/06/09 22:50:06 gordonr Exp gordonr $
+
+=cut
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
+
+use Socket;
+use constant SMTP_PORT => getservbyname("smtp", "tcp") || 25;
+use constant SSMTP_PORT => getservbyname("ssmtp", "tcp") || 465;
+
+sub register {
+    my ( $self, $qp, %arg ) = @_;
+
+    unless ($arg{cvm_socket}) {
+        $self->log(LOGERROR, "skip: requires cvm_socket argument");
+        return 0;
+    };
+
+    $self->{_args} = { %arg };
+    $self->{_enable_smtp} = $arg{enable_smtp} || 'no';
+    $self->{_enable_ssmtp} = $arg{enable_ssmtp} || 'yes';
+
+    my $port = $ENV{PORT} || SMTP_PORT;
+
+    return 0 if ($port == SMTP_PORT && $arg{enable_smtp} ne 'yes');
+    return 0 if ($port == SSMTP_PORT && $arg{enable_ssmtp} ne 'yes');
+
+    if ($arg{cvm_socket} =~ /^([\w\/.-]+)$/) {
+        $self->{_cvm_socket} = $1;
+    }
+
+    unless (-S $self->{_cvm_socket}) {
+        $self->log(LOGERROR, "skip: cvm_socket missing or not usable");
+        return 0;
+    }
+
+    $self->register_hook("auth-plain", "authcvm_plain");
+    $self->register_hook("auth-login", "authcvm_plain");
+#    $self->register_hook("auth-cram-md5", "authcvm_hash");
+}
+
+sub authcvm_plain {
+    my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
+      @_;
+
+    socket(SOCK, PF_UNIX, SOCK_STREAM, 0) or do {
+        $self->log(LOGERROR, "skip: socket creation attempt for: $user");
+        return (DENY, "authcvm");
+    };
+
+# DENY, really? Should this plugin return a DENY when it cannot connect
+# to the cvs socket? I'd expect such a failure to return DECLINED, so
+# any other auth plugins could take a stab at authenticating the user
+
+    connect(SOCK, sockaddr_un($self->{_cvm_socket})) or do {
+        $self->log(LOGERROR, "skip: socket connection attempt for: $user");
+        return (DENY, "authcvm");
+    };
+
+    my $o = select(SOCK); $| = 1; select($o);
+
+    my ($u, $host) = split(/\@/, $user);
+    $host ||= "localhost";
+
+    print SOCK "\001$u\000$host\000$passClear\000\000";
+
+    shutdown SOCK, 1;   # tell remote we're finished
+
+    my $ret = <SOCK>;
+    my ($s) = unpack ("C", $ret);
+
+    if ( ! defined $s ) {
+        $self->log(LOGERROR, "skip: no response from cvm for $user");
+        return (DECLINED);
+    };
+
+    if ( $s == 0 ) {
+        $self->log(LOGINFO, "pass: authentication for: $user");
+        return (OK, "auth success for $user");
+    };
+
+    if ( $s == 100 ) {
+        $self->log(LOGINFO, "fail: authentication failure for: $user");
+        return (DENY, 'auth failure (100)');
+    };
+
+    $self->log(LOGERROR, "skip: unknown response from cvm for $user");
+    return (DECLINED, "unknown result code ($s)");
+}

plugins/auth/auth_flat_file

@@ -0,0 +1,83 @@
+#!perl -w
+
+=head1 NAME
+
+auth_flat_file - simple CRAM MD5 auth plugin using a flat password file
+
+=head1 SYNOPSIS
+
+in config/plugins:
+
+  auth/auth_flat_file
+
+in config/flat_auth_pw
+
+  username1:password1
+  username2:password2
+  ...
+
+=head1 DESCRIPTION
+
+This plugin implements a very simple authentication plugin using a flat password
+file containing username and password separated by colons.
+
+Note that this plugin enforces the use of a full email address (including
+@domain) as the username. There's no particular reason for this so feel free
+to modify the code to suit your setup.
+
+The password is stored on disk unencrypted, however authentication uses a HMAC
+algorithm so no password is transfered in the clear.
+
+=cut
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Auth;
+use Qpsmtpd::Constants;
+
+sub register {
+    my ( $self, $qp ) = @_;
+
+    $self->register_hook('auth-plain',    'auth_flat_file');
+    $self->register_hook('auth-login',    'auth_flat_file');
+    $self->register_hook('auth-cram-md5', 'auth_flat_file');
+}
+
+sub auth_flat_file {
+    my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
+      @_;
+
+    if ( ! defined $passClear && ! defined $passHash ) {
+        $self->log(LOGINFO, "fail: missing password");
+        return ( DENY, "authflat - missing password" );
+    }
+
+    my ( $pw_name, $pw_domain ) = split '@', lc($user);
+
+    unless ( defined $pw_domain ) {
+        $self->log(LOGINFO, "fail: missing domain");
+        return DECLINED;
+    }
+
+    my ($auth_line) = grep {/^$pw_name\@$pw_domain:/} $self->qp->config('flat_auth_pw');
+
+    if ( ! defined $auth_line) {
+        $self->log(LOGINFO, "fail: no such user: $user");
+        return DECLINED;
+    }
+
+    my ($auth_user, $auth_pass) = split(/:/, $auth_line, 2);
+
+    # at this point we can assume the user name matched
+    return Qpsmtpd::Auth::validate_password( $self,
+            src_clear     => $auth_pass,
+            src_crypt     => undef,
+            attempt_clear => $passClear,
+            attempt_hash  => $passHash,
+            method        => $method,
+            ticket        => $ticket,
+            deny          => DENY,
+        );
+}
+

plugins/auth/auth_ldap_bind

@@ -0,0 +1,197 @@
+#!perl -w
+
+=head1 NAME
+
+auth_ldap_bind - Authenticate user via an LDAP bind
+
+=head1 DESCRIPTION
+
+This plugin authenticates users against an LDAP Directory.  The plugin
+first performs a lookup for an entry matching the connecting user.  This
+lookup uses the 'ldap_auth_filter_attr' attribute to match the connecting
+user to their LDAP DN.  Once the plugin has found the user's DN, the plugin
+will attempt to bind to the Directory as that DN with the password that has
+been supplied.
+
+=head1 CONFIGURATION
+
+Configuration items can be held in either the 'ldap' configuration file, or as
+arguments to the plugin.
+
+Configuration items in the 'ldap' configuration file
+are set one per line, starting the line with the configuration item key,
+followed by a space, then the values associated with the configuration item.
+
+Configuration items given as arguments to the plugin are keys and values
+separated by spaces.  Be sure to quote any values that have spaces in them.
+
+The only configuration item which is required is 'ldap_base'.  This tells the
+plugin what your base DN is.  The plugin will not work until it has been
+configured.
+
+The configuration items 'ldap_host' and 'ldap_port' specify the host and port
+at which your Directory server may be contacted.  If these are not specified,
+the plugin will use port '389' on 'localhost'.
+
+The configuration item 'ldap_timeout' specifies how long the plugin should
+wait for a response from your Directory server.  By default, the value is 5
+seconds.
+
+The configuration item 'ldap_auth_filter_attr' specifies how the plugin should
+find the user in your Directory.  By default, the plugin will look up the user
+based on the 'uid' attribute.
+
+=head1 NOTES
+
+Each auth requires an initial lookup to find the user's DN.  Ideally, the
+plugin would simply bind as the user without the need for this lookup (see
+FUTURE DIRECTION below).
+
+This plugin requires that the Directory allow anonymous bind (see FUTURE
+DIRECTION below).
+
+=head1 FUTURE DIRECTION
+
+A configurable LDAP filter should be made available, to account for users
+who are over quota, have had their accounts disabled, or whatever other
+arbitrary requirements.
+
+A configurable DN template (uid=$USER,ou=$DOMAIN,$BASE).  This would prevent
+the need of the initial user lookup, as the DN is created from the template.
+
+A configurable bind DN, for Directories that do not allow anonymous bind.
+
+Another plugin ('ldap_auth_cleartext'?), to allow retrieval of plain-text
+passwords from the Directory, permitting CRAM-MD5 or other hash algorithm
+authentication.
+
+=head1 AUTHOR
+
+Elliot Foster <elliotf@gratuitous.net>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005 Elliot Foster
+
+This plugin is licensed under the same terms as the qpsmtpd package itself.
+Please see the LICENSE file included with qpsmtpd for details.
+
+=cut
+
+use strict;
+use warnings;
+
+use Net::LDAP qw(:all);
+use Qpsmtpd::Constants;
+
+sub register {
+    my ($self, $qp, @args) = @_;
+
+    $self->register_hook("auth-plain", "authldap");
+    $self->register_hook("auth-login", "authldap");
+
+    # pull config defaults in from file
+    %{$self->{"ldconf"}} =
+      map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('ldap');
+
+    # override ldap config defaults with plugin args
+    for my $ldap_arg (@args) {
+        %{$self->{"ldconf"}} = map { (split /\s+/, $_, 2)[0, 1] } $ldap_arg;
+    }
+
+    # do light validation of ldap_host and ldap_port to satisfy -T
+    my $ldhost = $self->{"ldconf"}->{'ldap_host'};
+    my $ldport = $self->{"ldconf"}->{'ldap_port'};
+    if (($ldhost) && ($ldhost =~ m/^(([a-z0-9]+\.?)+)$/)) {
+        $self->{"ldconf"}->{'ldap_host'} = $1;
+    }
+    else {
+        undef $self->{"ldconf"}->{'ldap_host'};
+    }
+    if (($ldport) && ($ldport =~ m/^(\d+)$/)) {
+        $self->{"ldconf"}->{'ldap_port'} = $1;
+    }
+    else {
+        undef $self->{"ldconf"}->{'ldap_port'};
+    }
+
+    # set any values that are not already
+    $self->{"ldconf"}->{"ldap_host"}             ||= "127.0.0.1";
+    $self->{"ldconf"}->{"ldap_port"}             ||= 389;
+    $self->{"ldconf"}->{"ldap_timeout"}          ||= 5;
+    $self->{"ldconf"}->{"ldap_auth_filter_attr"} ||= "uid";
+}
+
+sub authldap {
+    my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
+      @_;
+    my ($ldhost, $ldport, $ldwait, $ldbase, $ldmattr, $lduserdn, $ldh, $mesg);
+
+    # pull values in from config
+    $ldhost = $self->{"ldconf"}->{"ldap_host"};
+    $ldport = $self->{"ldconf"}->{"ldap_port"};
+    $ldbase = $self->{"ldconf"}->{"ldap_base"};
+
+ # log error here and DECLINE if no baseDN, because a custom baseDN is required:
+    unless ($ldbase) {
+        $self->log(LOGERROR, "skip: please configure ldap_base");
+        return (DECLINED, "authldap - temporary auth error");
+    };
+    $ldwait  = $self->{"ldconf"}->{'ldap_timeout'};
+    $ldmattr = $self->{"ldconf"}->{'ldap_auth_filter_attr'};
+
+    my ($pw_name, $pw_domain) = split "@", lc($user);
+
+    # find dn of user matching supplied username
+    $ldh = Net::LDAP->new($ldhost, port => $ldport, timeout => $ldwait) or do {
+        $self->log(LOGALERT, "skip: error in initial conn");
+        return (DECLINED, "authldap - temporary auth error");
+    };
+
+    # find the user's DN
+    $mesg = $ldh->search(   base      => $ldbase,
+                            scope     => 'sub',
+                            filter    => "$ldmattr=$pw_name",
+                            attrs     => ['uid'],
+                            timeout   => $ldwait,
+                            sizelimit => '1'
+                        ) or do {
+        $self->log(LOGALERT, "skip: err in search for user");
+        return (DECLINED, "authldap - temporary auth error");
+    };
+
+    # deal with errors if they exist
+    if ($mesg->code) {
+        $self->log(LOGALERT, "skip: err " . $mesg->code . " in search for user");
+        return (DECLINED, "authldap - temporary auth error");
+    }
+
+    # unbind, so as to allow a rebind below
+    $ldh->unbind if $ldh;
+
+    # bind against directory as user with password supplied
+    if ( ! $mesg->count || $lduserdn = $mesg->entry->dn ) {
+        $self->log(LOGALERT, "fail: user not found");
+        return (DECLINED, "authldap - wrong username or password");
+    };
+
+    $ldh = Net::LDAP->new($ldhost, port => $ldport, timeout => $ldwait) or do {
+        $self->log(LOGALERT, "skip: err in user conn");
+        return (DECLINED, "authldap - temporary auth error");
+    };
+
+    # here's the whole reason for the script
+    $mesg = $ldh->bind($lduserdn, password => $passClear, timeout => $ldwait);
+    $ldh->unbind if $ldh;
+
+    # deal with errors if they exist, or allow success
+    if ($mesg->code) {
+        $self->log(LOGALERT, "fail: error in user bind");
+        return (DECLINED, "authldap - wrong username or password");
+    }
+
+    $self->log(LOGINFO,  "pass: $user auth success");
+    $self->log(LOGDEBUG, "user: $user, pass: $passClear");
+    return (OK, "authldap");
+}
+

plugins/auth/auth_vpopmail

@@ -0,0 +1,101 @@
+#!perl -w
+
+=head1 NAME
+
+auth_vpopmail - Authenticate against libvpopmail.a
+
+=head1 DESCRIPTION
+
+This plugin authenticates vpopmail users using p5-vpopmail.
+Using CRAM-MD5 requires that vpopmail be built with the
+'--enable-clear-passwd=y' option.
+
+=head1 CONFIGURATION
+
+This module will only work if qpsmtpd is running as the 'vpopmail' user.
+
+CRAM-MD5 authentication will only work with p5-vpopmail 0.09 or higher.
+    http://github.com/sscanlon/vpopmail
+
+Decide which authentication methods you are willing to support and uncomment
+the lines in the register() sub. See the POD for Qspmtpd::Auth for more
+details on the ramifications of supporting various authentication methods.
+
+=head1 SEE ALSO
+
+For an overview of the vpopmail authentication plugins and their merits,
+please read the VPOPMAIL section in docs/authentication.pod
+
+=head1 AUTHOR
+
+Matt Simerson <msimerson@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2010 Matt Simerson
+
+This plugin is licensed under the same terms as the qpsmtpd package itself.
+Please see the LICENSE file included with qpsmtpd for details.
+
+=cut
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Auth;
+use Qpsmtpd::Constants;
+
+#use vpopmail;    # we eval this in $test_vpopmail_module
+
+sub register {
+    my ($self, $qp) = @_;
+
+    return (DECLINED) if ! $self->test_vpopmail_module();
+
+    $self->register_hook("auth-plain", "auth_vpopmail" );
+    $self->register_hook("auth-login", "auth_vpopmail" );
+    $self->register_hook("auth-cram-md5", "auth_vpopmail");
+}
+
+sub auth_vpopmail {
+    my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
+      @_;
+
+    my $pw              = vauth_getpw( split '@', lc($user) );
+    my $pw_clear_passwd = $pw->{pw_clear_passwd};
+    my $pw_passwd       = $pw->{pw_passwd};
+
+    if (!$pw || (!$pw_clear_passwd && !$pw_passwd)) {
+        $self->log(LOGINFO, "fail: invalid user $user");
+        return (DENY, "auth_vpopmail - invalid user");
+        # change DENY to DECLINED to support multiple auth plugins
+    }
+
+    return Qpsmtpd::Auth::validate_password( $self,
+        src_clear     => $pw->{pw_clear_passwd},
+        src_crypt     => $pw->{pw_passwd},
+        attempt_clear => $passClear,
+        attempt_hash  => $passHash,
+        method        => $method,
+        ticket        => $ticket,
+        deny          => DENY,
+    );
+}
+
+sub test_vpopmail_module {
+    my $self = shift;
+# vpopmail will not allow vauth_getpw to succeed unless the requesting user is vpopmail or root.
+# by default, qpsmtpd runs as the user 'qpsmtpd' and does not have permission.
+    eval 'use vpopmail';
+    if ( $@ ) {
+        $self->log(LOGERROR, "skip: is vpopmail perl module installed?");
+        return;
+    };
+
+    my ($domain) = vpopmail::vlistdomains();
+    my $r = vauth_getpw('postmaster', $domain) or do {
+            $self->log(LOGERROR, "skip: could not query vpopmail");
+            return;
+        };
+    return 1;
+}

plugins/auth/auth_vpopmail_sql

@@ -0,0 +1,156 @@
+#!perl -w
+
+=head1 NAME
+
+auth_vpopmail_sql - Authenticate to vpopmail via MySQL
+
+=head1 DESCRIPTION
+
+This plugin authenticates vpopmail users directly against a standard
+vpopmail MySQL database.  It makes the not-unreasonable assumption that
+both pw_name and pw_domain are lowercase only (qmail doesn't actually care).
+If you are using CRAM-MD5, it also requires that vpopmail be built with the
+recommended '--enable-clear-passwd=y' option, because there is no way
+to compare the crypted password.
+
+=head1 CONFIGURATION
+
+ echo "dbi:mysql:dbname=vpopmail;host=127.0.0.1" > config/vpopmail_mysql_dsn
+ echo "vpopmailuser" > config/vpopmail_mysql_user
+ echo "vpoppasswd" > config/vpopmail_mysql_pass
+
+This can be a read-only database user since the plugin does not update the
+last accessed time (yet, see below).
+
+This module supports PLAIN, LOGIN, and CRAM-MD5 authentication methods. You
+can disable undesired methods by editing this module and uncommenting
+the lines in the register() sub.  See the POD for Qspmtpd::Auth for more
+details on the ramifications of supporting various authentication methods.
+
+The remote user must login with a fully qualified e-mail address (i.e. both
+account name and domain), even if they don't normally need to.  This is
+because the vpopmail table has a unique index on pw_name/pw_domain, and this
+module requires that only a single record be returned from the database.
+
+=head1 LIMITATIONS
+
+This authentication modules does not recognize domain aliases. So, if you have
+the domain example.com, with domain aliases for example.org and example.net,
+smtp-auth will only work for $user@example.com. If you have domain aliases,
+consider using another plugin (see SEE ALSO).
+
+=head1 FUTURE DIRECTION
+
+The default MySQL configuration for vpopmail includes a table to log access,
+lastauth, which could conceivably be updated upon sucessful authentication.
+The addition of this feature is left as an exercise for someone who cares. ;)
+
+=head1 SEE ALSO
+
+For an overview of the vpopmail authentication plugins and their merits,
+please read the VPOPMAIL section in docs/authentication.pod
+
+=head1 AUTHOR
+
+John Peacock <jpeacock@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2004 John Peacock
+
+This plugin is licensed under the same terms as the qpsmtpd package itself.
+Please see the LICENSE file included with qpsmtpd for details.
+
+=cut
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Auth;
+use Qpsmtpd::Constants;
+
+#use DBI;  # done in ->register
+
+sub register {
+    my ( $self, $qp ) = @_;
+
+    eval 'use DBI';
+    if ( $@ ) {
+        warn "plugin disabled. is DBI installed?\n";
+        $self->log(LOGERROR, "skip: plugin disabled. is DBI installed?\n");
+        return;
+    };
+
+    $self->register_hook('auth-plain',    'auth_vmysql');
+    $self->register_hook('auth-login',    'auth_vmysql');
+    $self->register_hook('auth-cram-md5', 'auth_vmysql');
+}
+
+sub get_db_handle {
+    my $self = shift;
+
+    my $dsn    = $self->qp->config("vpopmail_mysql_dsn") || "dbi:mysql:dbname=vpopmail;host=127.0.0.1";
+    my $dbuser = $self->qp->config("vpopmail_mysql_user") || "vpopmailuser";
+    my $dbpass = $self->qp->config("vpopmail_mysql_pass") || "vpoppasswd";
+
+    my $dbh = DBI->connect( $dsn, $dbuser, $dbpass ) or do {
+            $self->log(LOGERROR, "skip: db connection failed");
+            return;
+        };
+    $dbh->{ShowErrorStatement} = 1;
+    return $dbh;
+};
+
+sub get_vpopmail_user {
+    my ( $self, $dbh, $user ) = @_;
+
+    my ( $pw_name, $pw_domain ) = split '@', lc($user);
+
+    if ( ! defined $pw_domain ) {
+        $self->log(LOGINFO, "skip: missing domain: " . lc $user );
+        return;
+    };
+
+    $self->log(LOGDEBUG, "auth_vpopmail_sql: $user");
+
+    my $query = "SELECT pw_passwd,pw_clear_passwd
+FROM vpopmail
+  WHERE pw_name = ?
+    AND pw_domain = ?";
+
+    my $sth = $dbh->prepare( $query );
+    $sth->execute( $pw_name, $pw_domain );
+    my $userd_ref = $sth->fetchrow_hashref;
+    $sth->finish;
+    $dbh->disconnect;
+    return $userd_ref;
+};
+
+sub auth_vmysql {
+    my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = @_;
+
+    my $dbh = $self->get_db_handle() or return DECLINED;
+    my $u = $self->get_vpopmail_user($dbh, $user) or return DECLINED;
+
+    # if vpopmail was not built with '--enable-clear-passwd=y'
+    # then pw_clear_passwd may not even exist
+    # my $pw_clear_passwd = $db_user->{'pw_clear_passwd'};
+
+    if ( ! $u->{pw_passwd} && ! $u->{pw_clear_passwd} ) {
+        $self->log(LOGINFO, "fail: no such user");
+        return ( DENY, "auth_vmysql - no such user" );
+    };
+
+    # at this point, the user name has matched
+
+    return Qpsmtpd::Auth::validate_password( $self,
+            src_clear     => $u->{pw_clear_passwd},
+            src_crypt     => $u->{pw_passwd},
+            attempt_clear => $passClear,
+            attempt_hash  => $passHash,
+            method        => $method,
+            ticket        => $ticket,
+            deny          => DENY,
+        );
+}
+

plugins/auth/auth_vpopmaild

@@ -0,0 +1,120 @@
+#!perl -w
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
+use IO::Socket;
+use version; 
+my $VERSION = qv('1.0.3');
+
+sub register {
+    my ($self, $qp, %args) = @_;
+
+    $self->{_vpopmaild_host} = $args{host} || 'localhost';
+    $self->{_vpopmaild_port} = $args{port} || '89';
+
+    $self->register_hook('auth-plain', 'auth_vpopmaild');
+    $self->register_hook('auth-login', 'auth_vpopmaild');
+    #$self->register_hook('auth-cram-md5', 'auth_vpopmaild'); # not supported
+}
+
+sub auth_vpopmaild {
+    my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_;
+
+    if ( ! $passClear ) {
+        $self->log(LOGINFO, "skip: vpopmaild does not support cram-md5");
+        return DECLINED;
+    }
+
+    # create socket
+    my $vpopmaild_socket = IO::Socket::INET->new(
+                            PeerAddr => $self->{_vpopmaild_host},
+                            PeerPort => $self->{_vpopmaild_port},
+                            Proto    => 'tcp',
+                            Type     => SOCK_STREAM
+                           ) or do {
+        $self->log(LOGERROR, "skip: socket connection to vpopmaild failed");
+        return DECLINED;
+    };
+
+    $self->log(LOGDEBUG, "attempting $method");
+
+    # Get server greeting (+OK)
+    my $connect_response = <$vpopmaild_socket>;
+    if ( ! $connect_response ) {
+        $self->log(LOGERROR, "skip: no connection response");
+        close($vpopmaild_socket);
+        return DECLINED;
+    };
+
+    if ( $connect_response !~ /^\+OK/ ) {
+        $self->log(LOGERROR, "skip: bad connection response: $connect_response");
+        close($vpopmaild_socket);
+        return DECLINED;
+    };
+
+    print $vpopmaild_socket "login $user $passClear\n\r"; # send login details
+    my $login_response = <$vpopmaild_socket>;       # get response from server
+    close($vpopmaild_socket);
+
+    if ( ! $login_response ) {
+        $self->log(LOGERROR, "skip: no login response");
+        return DECLINED;
+    };
+
+    # check for successful login (single line (+OK) or multiline (+OK+))
+    if ( $login_response =~ /^\+OK/ ) {
+        $self->log(LOGINFO, "pass: clear");
+        return (OK, 'auth_vpopmaild');
+    };
+
+    chomp $login_response;
+    $self->log(LOGNOTICE, "fail: $login_response");
+    return DECLINED;
+}
+
+__END__
+
+=head1 NAME
+
+auth_vpopmaild - Authenticate to vpopmaild
+
+=head1 DESCRIPTION
+
+Authenticates the user against against vpopmaild [1] daemon.
+
+=head1 CONFIGURATION
+
+Add a line to C<config/plugins> as follows:
+
+auth_vpopmaild
+
+By default, the plugin connects to localhot on port 89. If your vpopmaild
+daemon is running on a different host or port, specify as follows:
+
+auth_vpopmaild host [host] port [port]
+
+=head1 SEE ALSO
+
+For an overview of the vpopmail authentication plugins and their merits,
+please read the VPOPMAIL section in doc/authentication.pod
+
+=head1 LINKS
+
+[1] http://www.qmailwiki.org/Vpopmaild
+
+=head1 AUTHOR
+
+Robin Bowes <robin.bowes@yo61.com>
+
+Matt Simerson (updated response parsing, added logging)
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2010 Robin Bowes
+
+This plugin is licensed under the same terms as the qpsmtpd package itself.
+Please see the LICENSE file included with qpsmtpd for details.
+
+=cut

plugins/auth/authdeny

@@ -0,0 +1,23 @@
+#!perl -w
+
+=head1 NAME
+
+authdeny
+
+=head1 SYNOPSIS
+
+This plugin doesn't actually check anything and will fail any
+user no matter what they type.  It is strictly a proof of concept for
+the Qpsmtpd::Auth module.  Don't run this in production!!!
+
+=cut
+
+sub hook_auth {
+    my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
+      @_;
+
+    $self->log( LOGWARN, "fail: cannot authenticate" );
+
+    return ( DECLINED, "$user is not free to abuse my relay" );
+}
+

plugins/check_badmailfrom

@@ -0,0 +1,159 @@
+#!perl -w
+
+=head1 NAME
+
+check_badmailfrom - checks the badmailfrom config, with per-line reasons
+
+=head1 DESCRIPTION
+
+Reads the "badmailfrom" configuration like qmail-smtpd does.  From the
+qmail-smtpd docs:
+
+"Unacceptable envelope sender addresses. qmail-smtpd will reject every
+recipient address for a message if the envelope sender address is
+listed in badmailfrom. A line in badmailfrom may be of the form
+@host, meaning every address at host."
+
+You may include an optional message after the sender address (leave a space),
+to be used when rejecting the sender.
+
+=head1 CONFIGURATION
+
+=head2 reject
+
+  badmailfrom reject [ 0 | 1 | naughty ]
+
+I<0> will not reject any connections.
+
+I<1> will reject naughty senders.
+
+I<connect> is the most efficient setting. It's also the default.
+
+To reject at any other connection hook, use the I<naughty> setting and the
+B<naughty> plugin.
+
+=head1 PATTERNS
+
+This plugin also supports regular expression matches. This allows
+special patterns to be denied (e.g. FQDN-VERP, percent hack, bangs,
+double ats).
+
+Patterns are stored in the format pattern(\s+)response, where pattern
+is a Perl pattern expression. Don't forget to anchor the pattern
+(front ^ and back $) if you want to restrict it from matching
+anywhere in the string.
+
+ ^streamsendbouncer@.*\.mailengine1\.com$    Your right-hand side VERP doesn't fool me
+ ^return.*@.*\.pidplate\.biz$                I don' want it regardless of subdomain
+ ^admin.*\.ppoonn400\.com$
+
+
+=head1 NOTES
+
+According to the SMTP protocol, we can't reject until after the RCPT
+stage, so store it until later.
+
+
+=head1 AUTHORS
+
+2002 - Jim Winstead - initial author of badmailfrom
+
+2010 - Johan Almqvist <johan-qpsmtpd@almqvist.net> - pattern matching plugin
+
+2012 - Matt Simerson - merging of the two and plugin tests
+
+=cut
+
+sub register {
+    my ($self,$qp) = shift, shift;
+    $self->{_args} = { @_ };
+
+    # preserve legacy "reject during rcpt" behavior
+    $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
+
+    return if ! $self->{_args}{reject};               # reject 0, log only
+    return if   $self->{_args}{reject} eq 'naughty';  # naughty will reject
+
+    $self->register_hook('rcpt', 'rcpt_handler');
+};
+
+sub hook_mail {
+    my ($self, $transaction, $sender, %param) = @_;
+
+    return DECLINED if $self->is_immune();
+
+    my @badmailfrom = $self->qp->config('badmailfrom');
+    if ( defined $self->{_badmailfrom_config} ) {       # testing
+        @badmailfrom = @{$self->{_badmailfrom_config}};
+    };
+
+    return DECLINED if $self->is_immune_sender( $sender, \@badmailfrom );
+
+    my $host = lc $sender->host;
+    my $from = lc($sender->user) . '@' . $host;
+
+    for my $config (@badmailfrom) {
+        $config =~ s/^\s+//g;   # trim leading whitespace
+        my ($bad, $reason) = split /\s+/, $config, 2;
+        next unless $bad;
+        next unless $self->is_match( $from, $bad, $host );
+        $reason ||= "Your envelope sender is in my badmailfrom list";
+        $self->connection->notes('naughty', $reason);
+    }
+    if ( ! $self->connection->notes('naughty') ) {
+        $self->log(LOGINFO, "pass");
+    };
+    return DECLINED;
+}
+
+sub is_match {
+    my ( $self, $from, $bad, $host ) = @_;
+
+    if ( $bad =~ /[\/\^\$\*\+]/ ) {  # it's a regexp
+        $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $from");
+        return 1 if $from =~ /$bad/;
+        return;
+    };
+
+    $bad = lc $bad;
+    if ( $bad !~ m/\@/ ) {
+        $self->log(LOGWARN, "badmailfrom: bad config: no \@ sign in $bad");
+        return;
+    };
+    if ( substr($bad,0,1) eq '@' ) {
+        return 1 if $bad eq "\@$host";
+        return;
+    };
+    return if $bad ne $from;
+    return 1;
+};
+
+sub rcpt_handler {
+    my ($self, $transaction, $rcpt, %param) = @_;
+
+    my $note = $self->connection->notes('naughty') or return (DECLINED);
+
+    $self->log(LOGINFO, "fail, $note");
+    return (DENY, $note);
+}
+
+sub is_immune_sender {
+    my ($self, $sender, $badmf ) = @_;
+
+    if ( ! scalar @$badmf ) {
+        $self->log(LOGDEBUG, 'skip: empty list');
+        return 1;
+    };
+
+    if ( ! $sender || $sender->format eq '<>' ) {
+        $self->log(LOGDEBUG, 'skip: null sender');
+        return 1;
+    };
+
+    if ( ! $sender->host || ! $sender->user ) {
+        $self->log(LOGDEBUG, 'skip: missing user or host');
+        return 1;
+    };
+
+    return;
+};

plugins/check_badmailfromto

@@ -0,0 +1,83 @@
+#!perl -w
+
+=head1 NAME
+
+check_badmailfromto - checks the badmailfromto config
+
+=head1 DESCRIPTION
+
+Much like the similar check_badmailfrom, this plugin references both the
+FROM: and TO: lines, and if they both are present in the badmailfromto
+config file (a tab delimited list of FROM/TO pairs), then the message is
+blocked as if the recipient (TO) didn't exist.  This is specifically designed
+to not give the impression that the sender is blocked (good for cases of
+harassment).
+
+Based heavily on check_badmailfrom.
+
+=cut
+
+use strict;
+use Qpsmtpd::Constants;
+
+sub hook_mail {
+  my ($self, $transaction, $sender, %param) = @_;
+
+    my @badmailfromto = $self->qp->config("badmailfromto");
+    return DECLINED if $self->is_sender_immune( $sender, \@badmailfromto );
+
+  my $host = lc $sender->host;
+  my $from = lc($sender->user) . '@' . $host;
+
+  for my $bad (@badmailfromto) {
+    $bad =~ s/^\s*(\S+).*/$1/;
+    next unless $bad;
+    $bad = lc $bad;
+    if ( $bad !~ m/\@/ ) {
+        $self->log(LOGWARN, 'badmailfromto: bad config, no @ sign in '. $bad);
+        next;
+    };
+    if ( $bad eq $from || (substr($bad,0,1) eq '@' && $bad eq "\@$host") ) {
+        $transaction->notes('badmailfromto', $bad);
+    };
+  }
+  return (DECLINED);
+}
+
+sub hook_rcpt {
+    my ($self, $transaction, $rcpt, %param) = @_;
+    my $recipient = lc($rcpt->user) . '@' . lc($rcpt->host);
+    my $sender = $transaction->notes('badmailfromto') or do {
+        $self->log(LOGDEBUG, "pass: sender not listed");
+        return (DECLINED);
+    };
+
+    foreach ( $self->qp->config("badmailfromto") ) {
+        my ($from, $to) = m/^\s*(\S+)\t(\S+).*/;
+        return (DENY, "mail to $recipient not accepted here")
+            if lc($from) eq $sender && lc($to) eq $recipient;
+    }
+    $self->log(LOGDEBUG, "pass: recipient not listed");
+    return (DECLINED);
+}
+
+sub is_sender_immune {
+    my ($self, $sender, $badmf ) = @_;
+
+    if ( ! scalar @$badmf ) {
+        $self->log(LOGDEBUG, 'skip: empty list');
+        return 1;
+    };
+
+    if ( ! $sender || $sender->format eq '<>' ) {
+        $self->log(LOGDEBUG, 'skip: null sender');
+        return 1;
+    };
+
+    if ( ! $sender->host || ! $sender->user ) {
+        $self->log(LOGDEBUG, 'skip: missing user or host');
+        return 1;
+    };
+
+    return;
+};

plugins/check_badrcptto

@@ -0,0 +1,129 @@
+#!perl -w
+
+=head1 SYNOPSIS
+
+deny connections to recipients in the I<badrcptto> file
+
+like badmailfrom, but for recipient address rather than sender
+
+=head1 CONFIG
+
+Recipients are matched against entries in I<config/badrcptto>. Entries can be
+a complete email address, a host entry that starts with an @ symbol, or a
+regular expression. For regexp pattern matches, see PATTERNS.
+
+=head1 PATTERNS
+
+This allows special patterns to be denied (e.g. percent hack, bangs,
+double ats).
+
+Patterns are stored in the format pattern\sresponse, where pattern
+is a Perl pattern expression. Don't forget to anchor the pattern if
+you want to restrict it from matching anywhere in the string.
+
+qpsmtpd already ensures that the address contains an @, with something
+to the left and right of the @.
+
+=head1 AUTHOR
+
+2002 - original badrcptto plugin - apparently Jim Winstead
+       https://github.com/smtpd/qpsmtpd/commits/master/plugins/check_badrcptto
+
+2005 - pattern feature, (c) Gordon Rowell <gordonr@gormand.com.au>
+
+2012 - merged the two, refactored, added tests - Matt Simerson
+
+=head1 LICENSE
+
+This software is free software and may be distributed under the same
+terms as qpsmtpd itself.
+
+=cut
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
+use Qpsmtpd::DSN;
+
+sub hook_rcpt {
+  my ($self, $transaction, $recipient, %param) = @_;
+
+    return (DECLINED) if $self->is_immune();
+
+    my ($host, $to) = $self->get_host_and_to( $recipient )
+        or return (DECLINED);
+
+    my @badrcptto = $self->qp->config("badrcptto") or do {
+        $self->log(LOGINFO, "skip: empty config");
+        return (DECLINED);
+    };
+
+    for my $line (@badrcptto) {
+        $line =~ s/^\s+//g; # trim leading whitespace
+        my ($bad, $reason) = split /\s+/, $line, 2;
+        next if ! $bad;
+        if ( $self->is_match( $to, lc($bad), $host ) ) {
+            if ( $reason ) {
+                return (DENY, "mail to $bad not accepted here");
+            }
+            else {
+                return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here");
+            }
+        };
+    }
+    $self->log(LOGINFO, 'pass');
+    return (DECLINED);
+}
+
+sub is_match {
+    my ( $self, $to, $bad, $host ) = @_;
+
+    if ( $bad =~ /[\/\^\$\*\+\!\%]/ ) {  # it's a regexp
+        $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $to");
+        if ( $to =~ /$bad/i ) {
+            $self->log(LOGINFO, 'fail: pattern match');
+            return 1;
+        };
+        return;
+    };
+
+    if ( $bad !~ m/\@/ ) {
+        $self->log(LOGERROR, "badrcptto: bad config: no \@ sign in $bad");
+        return;
+    };
+
+    $bad = lc $bad;
+    $to  = lc $to;
+
+    if ( substr($bad,0,1) eq '@' ) {
+        if ( $bad eq "\@$host" ) {
+            $self->log(LOGINFO, 'fail: host match');
+            return 1;
+        };
+        return;
+    };
+
+    if ( $bad eq $to ) {
+        $self->log(LOGINFO, 'fail: rcpt match');
+        return 1;
+    }
+    return;
+};
+
+sub get_host_and_to {
+    my ( $self, $recipient ) = @_;
+
+    if ( ! $recipient ) {
+        $self->log(LOGERROR, 'skip: no recipient!');
+        return;
+    };
+
+    if ( ! $recipient->host || ! $recipient->user ) {
+        $self->log(LOGINFO, 'skip: missing host or user');
+        return;
+    };
+
+    my $host = lc $recipient->host;
+    return ( $host, lc($recipient->user) . '@' . $host );
+};

plugins/check_badrcptto_patterns

@@ -0,0 +1,48 @@
+#!perl -w
+=pod
+
+=head1 SYNOPSIS
+
+This plugin checks the badrcptto_patterns config. This allows
+special patterns to be denied (e.g. percent hack, bangs, 
+double ats).
+
+=head1 CONFIG
+
+config/badrcptto_patterns
+
+Patterns are stored in the format pattern\sresponse, where pattern
+is a Perl pattern expression. Don't forget to anchor the pattern if
+you want to restrict it from matching anywhere in the string.
+
+qpsmtpd already ensures that the address contains an @, with something
+to the left and right of the @.
+
+=head1 AUTHOR
+
+Copyright 2005 Gordon Rowell <gordonr@gormand.com.au>
+
+This software is free software and may be distributed under the same
+terms as qpsmtpd itself.
+
+=cut
+
+sub hook_rcpt
+{
+  my ($self, $transaction, $recipient) = @_;
+
+  return (DECLINED) if $self->qp->connection->relay_client();
+
+  my @badrcptto = $self->qp->config("badrcptto_patterns") or return (DECLINED);
+  my $host = lc $recipient->host;
+  my $to = lc($recipient->user) . '@' . $host;
+
+  for (@badrcptto)
+  {
+      my ($pattern, $response) = split /\s+/, $_, 2;
+
+      return (DENY, $response) if ($to =~ /$pattern/);
+  }
+
+  return (DECLINED);
+}

plugins/check_basicheaders

@@ -0,0 +1,162 @@
+#!perl -w
+
+=head1 NAME
+
+check_basicheaders
+
+=head1 DESCRIPTION
+
+Checks for missing or empty values in the From or Date headers.
+
+Optionally test if the Date header is too many days in the past or future. If
+I<future> or I<past> are not defined, they are not tested.
+
+If the remote IP is whitelisted, header validation is skipped.
+
+=head1 CONFIGURATION
+
+The following optional settings exist:
+
+=head2 future
+
+The number of days in the future beyond which messages are invalid.
+
+  check_basicheaders [ future 1 ]
+
+=head2 past
+
+The number of days in the past beyond which a message is invalid. The Date header is added by the MUA, so there are many valid reasons a message may have an older date in the header. It could have been delayed by the client, the sending server, connectivity problems, recipient server problem, recipient server configuration, etc. The I<past> setting should take those factors into consideration.
+
+I would be surprised if a valid message ever had a date header older than a week.
+
+  check_basicheaders [ past 5 ]
+
+=head2 reject
+
+Determine if the connection is denied. Use the I<reject 0> option when first enabling the plugin, and then watch your logs to see what would have been rejected. When you are no longer concerned that valid messages will be rejected, enable with I<reject 1>.
+
+  check_basicheaders reject [ 0 | 1 ]
+
+Default: 1
+
+=head2 reject_type
+
+Whether to issue a permanent or temporary rejection. The default is permanent.
+
+  check_basicheaders reject_type [ temp | perm ]
+
+Using a temporary rejection is a cautious way to enable rejections. It allows an administrator to watch for a trial period and assure no valid messages are rejected. If a deferral of valid mail is noticed, I<reject 0> can be set to permit the deferred message to be delivered.
+
+Default: perm
+
+=head2 loglevel
+
+Adjust the quantity of logging for this plugin. See docs/logging.pod
+
+=head1 AUTHOR
+
+ 2004 - Written by Jim Winstead Jr.
+
+ 2012 - added logging, named arguments, reject_type, tests - Matt Simerson
+      - deprecate days for I<past> & I<future>. Improved POD
+
+=head1 LICENSE
+
+Released to the public domain, 26 March 2004.
+
+=cut
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
+
+use Date::Parse qw(str2time);
+
+sub register {
+    my ($self, $qp, @args) = @_;
+
+    if ( @args == 1 ) {
+        $self->{_args}{days} = $args[0];
+    }
+    elsif ( @args % 2 ) {
+        $self->log(LOGWARN, "invalid arguments");
+    }
+    else {
+        $self->{_args} = { @args };
+    };
+# provide backwards compatibility with the previous unnamed 'days' argument
+    if ( $self->{_args}{days} ) {
+        if ( ! defined $self->{_args}{future} ) {
+            $self->{_args}{future} = $self->{_args}{days};
+        };
+        if ( ! defined $self->{_args}{past} ) {
+            $self->{_args}{past} = $self->{_args}{days};
+        };
+    };
+# set explicit defaults
+    $self->{_args}{reject_type} ||= 'perm';
+    if ( ! defined $self->{_args}{reject} ) {
+        $self->{_args}{reject} = 1;
+    };
+}
+
+sub hook_data_post {
+    my ($self, $transaction) = @_;
+
+    my $type = $self->get_reject_type();
+
+    if ( $transaction->data_size == 0 ) {
+        $self->log(LOGINFO, "fail: no data");
+        return ($type, "You must send some data first");
+    };
+
+    my $header = $transaction->header or do {
+        $self->log(LOGINFO, "fail: no headers");
+        return ($type, "missing header");
+    };
+
+    return (DECLINED, "immune") if $self->is_immune();
+
+    if ( ! $header->get('From') ) {
+        $self->log(LOGINFO, "fail: no from");
+        return ($type, "We require a valid From header");
+    };
+
+    my $date = $header->get('Date') or do {
+        $self->log(LOGINFO, "fail: no date");
+        return ($type, "We require a valid Date header");
+    };
+    chomp $date;
+
+    my $err_msg = $self->invalid_date_range($date);
+    if ( $err_msg ) {
+        return ($type, $err_msg );
+    };
+
+    return (DECLINED);
+};
+
+sub invalid_date_range {
+    my ($self, $date) = @_;
+
+    my $ts = str2time($date) or do {
+        $self->log(LOGINFO, "skip: date not parseable ($date)");
+        return;
+    };
+
+    my $past = $self->{_args}{past};
+    if ( $past && $ts < time - ($past*24*3600) ) {
+        $self->log(LOGINFO, "fail: date too old ($date)");
+        return "The Date header is too far in the past";
+    };
+
+    my $future = $self->{_args}{future};
+    if ( $future && $ts > time + ($future*24*3600) ) {
+        $self->log(LOGINFO, "fail: date in future ($date)");
+        return "The Date header is too far in the future";
+    };
+
+    $self->log(LOGINFO, "pass");
+    return;
+}

plugins/check_bogus_bounce

@@ -0,0 +1,126 @@
+#!perl -w
+
+=head1 NAME
+
+check_bogus_bounce - Check that a bounce message isn't bogus
+
+=head1 DESCRIPTION
+
+This plugin is designed to reject bogus bounce messages.
+
+In our case a bogus bounce message is defined as a bounce message
+which has more than a single recipient.
+
+=head1 CONFIGURATION
+
+Only a single argument is recognized and is assumed to be the default
+action.  Valid settings are:
+
+=over 8
+
+=item log
+
+Merely log the receipt of the bogus bounce (the default behaviour).
+
+=item deny
+
+Deny with a hard error code.
+
+=item denysoft
+
+Deny with a soft error code.
+
+=back
+
+=cut
+
+=head1 AUTHOR
+
+Steve Kemp
+--
+http://steve.org.uk/Software/qpsmtpd/
+
+=cut
+
+=begin doc
+
+Look for our single expected argument and configure "action" appropriately.
+
+=end doc
+
+=cut
+
+sub register {
+    my ($self, $qp, $arg, @nop) = (@_);
+
+    #
+    #  Default behaviour is to merely log.
+    #
+    $self->{_action} = "log";
+
+    #
+    #  Unless one was specified
+    #
+    if ($arg) {
+        if ($arg =~ /^(log|deny|denysoft)$/i) {
+            $self->{_action} = $arg;
+        }
+        else {
+            die "Invalid argument '$arg' - use one of : log, deny, denysoft";
+        }
+    }
+}
+
+=begin doc
+
+Handle the detection of bounces here.
+
+If we find a match then we'll react with our expected action.
+
+=end doc
+
+=cut
+
+sub hook_data_post {
+    my ($self, $transaction) = (@_);
+
+    #
+    # Find the sender, and return unless it wasn't a bounce.
+    #
+    my $sender = $transaction->sender->address || undef;
+    return DECLINED unless ($sender eq "<>");
+
+    #
+    #  Get the recipients.
+    #
+    my @to = $transaction->recipients || ();
+    return DECLINED unless (scalar @to > 1);
+
+    #
+    #  OK at this point we know:
+    #
+    #   1.  It is a bounce, via the null-envelope.
+    #   2.  It is a bogus bounce, because there are more than one recipients.
+    #
+    if (lc $self->{_action} eq "log") {
+        $self->log(LOGWARN,
+                 $self->plugin_name() . " bogus bounce for :" . join(",", @to));
+    }
+    elsif (lc $self->{_action} eq "deny") {
+        return (DENY,
+                $self->plugin_name() . " determined this to be a bogus bounce");
+    }
+    elsif (lc $self->{_action} eq "denysoft") {
+        return (DENYSOFT,
+                $self->plugin_name() . " determined this to be a bogus bounce");
+    }
+    else {
+        $self->log(LOGWARN,
+                   $self->plugin_name() . " failed to determine action.  bug?");
+    }
+
+    #
+    #  All done; allow this to proceed
+    #
+    return DECLINED;
+}