Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

11 files changed, 1716 insertions, 0 deletions

diff --git a/tcllib/modules/smtpd/ChangeLog b/tcllib/modules/smtpd/ChangeLog
new file mode 100644
index 0000000..90c634c
--- /dev/null
+++ b/tcllib/modules/smtpd/ChangeLog
@@ -0,0 +1,191 @@
+2013-02-01  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.15 ========================
+	* 
+
+2011-12-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.14 ========================
+	* 
+
+2011-04-11  Andreas Kupries  <andreask@activestate.com>
+
+	* smtpd.man: [RFE 3247765]: Added option to configure the
+	* smtpd.tcl: smtpd greeting/banner. Bumped to version 1.5
+	* pkgIndex.tcl
+
+2011-01-24  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.13 ========================
+	* 
+
+2009-12-07  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.12 ========================
+	* 
+
+2008-12-12  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.11.1 ========================
+	* 
+
+2008-10-16  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.11 ========================
+	* 
+
+2007-09-12  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.10 ========================
+	* 
+
+2007-03-21  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* smtpd.man: Fixed all warnings due to use of now deprecated
+	  commands. Added a section about how to give feedback.
+
+2006-10-03  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.9 ========================
+	* 
+
+2005-10-06  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.8 ========================
+	* 
+
+2005-06-21  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* smtpd.tcl: bug #1224575 - as per RFC2821:3.7 we must accept null
+	return path addresses. The programmers validate_sender proc can
+	then decide to accept or reject such a submission.
+
+2005-06-14  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* smtpd.tcl: The -deliver options should accept a script prefix
+	not just a command. Set version to 1.4.0
+
+2004-10-05  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.7 ========================
+	* 
+
+2004-06-26  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* smtpd.tcl: Implemented RFC3207 - Secure SMTP over TLS. This adds
+	a number of configuration options and a new command (available if
+	the tls package is provided and -usetls is set to true.) Also
+	implemented the SMTP HELP command and switched to using the logger
+	package from tcllib.
+	* /examples/smtpd/tk_smtpdTLS: New demo server to show off the 
+	TLS features added here.
+
+2004-06-18  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* pkgIndex.tcl:  Incremented version to 1.2.2
+	* smtpd.man:
+	* smtpd.tcl:
+
+	* smtpd.tcl (::smtpd::gmtoffset): Fixed bug #934134. The TZ
+	calculation was inverted and failed to cope with times spanning
+	midnight.
+	* smtpd.tcl (::smtpd::HELO): Shortened the response to a single
+	line which is a more common smtpd response and may help with
+	simple clients.
+
+2004-05-23  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.6.1 ========================
+	* 
+
+2004-02-15  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.6 ========================
+	* 
+
+2003-05-05  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.4 ========================
+	* 
+
+2003-04-10  Andreas Kupries  <andreask@activestate.com>
+
+	* smtpd.tcl: Fixed bug #614591.
+
+2003-01-25  Pat Thoyts <patthoyts@users.sourceforge.net>
+
+	* smtpd.tcl: Fix bug #674333: require Tcl version 8.3+
+	 (the mime package requires 8.3 therefore so do we.)
+	
+2003-01-16  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* smtpd.man: More semantic markup, less visual one.
+
+2003-01-02  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* smtpd.tcl: Added exception catching to all channel comms.
+	  Added some ESMTP option handling (rudimentary).
+	  Added SMTP Transparency handling. (RFC 2821: 4.5.2)
+	  Improved error messages for DATA command.
+
+2002-10-25  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* smtpd.tcl: Implemented request #627960 to propagate the network
+	  interface name into the server messages. Added a catch around
+	  the deliver call and permit the deliver code to return SMTP
+	  failure codes via ::errorCode.
+	
+2002-10-08  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* smtpd.tcl: Implemented feature request #531531. Added
+	  -deliverMIME option to provide mail as a MIME token.
+	* smtpd.man: Updated for the new delivery option.
+	* tk_smtpdMIME: New example using the -deliverMIME option.
+	
+2002-09-25  David N. Welton  <davidw@dedasys.com>
+
+	* smtpd.man: Fixed documentation error in deliver example.
+
+2002-09-19  David N. Welton  <davidw@dedasys.com>
+
+	* smtpd.tcl (smtpd::service): Added Andreas' suggested changes to
+	  avoid a bgerror caused by a broken pipe.
+
+2002-09-16  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* smtpd.tcl: fixed bug #609835 to cope with multiple addresses in
+	  MAIL and RCPT commands without raising exception.
+
+2002-04-10  Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+	* smtpd.man: Added doctools manpage.
+
+2001-12-10  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* smtpd.tcl (smtpd::gmtoffset): Fixed for cases where the hour
+	  offset is invalid.
+
+2001-11-19  Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+	* Moved example.tcl to the standard location in
+	  'tcllib/examples/smtpd'. Also renamed it to "tk_smtpd".
+
+2001-11-06  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* smtpd.tcl: Tcl SMTP server package.
+	* smtpd.n: Manual page for the Tcl SMTP server.
+	* example.tcl: Simple demo of server use and authentication.
+
diff --git a/tcllib/modules/smtpd/clients/README b/tcllib/modules/smtpd/clients/README
new file mode 100644
index 0000000..d472066
--- /dev/null
+++ b/tcllib/modules/smtpd/clients/README
@@ -0,0 +1,13 @@
+These files are mail sending test scripts written in various scripting
+languages. The purpose of these is to check that our SMTPd
+inter-operates successfully with everyone else's SMTP client software.
+
+Feel free to add a test script for your favourite other language - or to
+improve the usage of any of the current languages.
+
+mail-test.pl  - Perl test script
+mail-test.py  - Python test
+mail-test.rb  - Ruby test
+mail-test.php - PHP test (requires some php.ini configuration)
+php.ini       - PHP ini file (default for Windows installations) 
+mail-test.tcl - and of course, a Tcl client!
diff --git a/tcllib/modules/smtpd/clients/mail-test.php b/tcllib/modules/smtpd/clients/mail-test.php
new file mode 100644
index 0000000..5940c56
--- /dev/null
+++ b/tcllib/modules/smtpd/clients/mail-test.php
@@ -0,0 +1,21 @@
+<?
+  # Send a message from PHP (check the php.ini for the 
+  # server, port and default sender details)
+
+  $sndr = 'php-test-script@localhost';
+  $rcpt = 'tcllib-test@localhost';
+
+  $subject = "Testing from PHP";
+
+  $hdrs  = "MIME-Version: 1.0\r\n";
+  $hdrs .= "Content-type: text/plain; charset=iso-8859-1\r\n";
+  $hdrs .= "From: PHP Script <" . $sndr . ">";
+
+  $body  = "This is a sample message send from PHP.\r\n";
+  $body .= "As always, let us check the transparency function:\r\n";
+  $body .= ". <-- there should be a dot there.\r\n";
+  $body .= "Bye";
+
+  mail($rcpt, $subject, $body, $hdrs);
+
+?>
diff --git a/tcllib/modules/smtpd/clients/mail-test.pl b/tcllib/modules/smtpd/clients/mail-test.pl
new file mode 100644
index 0000000..54c4a09
--- /dev/null
+++ b/tcllib/modules/smtpd/clients/mail-test.pl
@@ -0,0 +1,121 @@
+# mail-test.pl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sf.net>
+#
+# Send some mail from Perl.
+#
+# This sends two messages, one valid and one without a recipient using the
+# SMTP protocol.
+#
+# usage: ./mail-test.pl smtpd-host ?smtpd-port?
+#
+# -------------------------------------------------------------------------
+
+use diagnostics;
+use strict;
+
+use Net::SMTP;
+use Sys::Hostname;
+
+my ($smtp_smart_host, $smtp_smart_port) = (shift, shift);
+
+$smtp_smart_host = 'localhost' if (!$smtp_smart_host);
+$smtp_smart_port = 25 if (!$smtp_smart_port);
+
+my $smtp_default_from = 'postmaster@' . hostname();
+my $smtp_timeout = 120;
+my $smtp_log_mail = 0;
+my $smtp_debug = 1;
+
+my $sender_address = 'perl-test-script@' . hostname() . '';
+my $recipient_address = 'tcl-smtpd@' . $smtp_smart_host . '';
+my $from_address = 'Perl Test Script <perl-test-script@' . hostname() . '>';
+my $ro_address = 'Tcl Server <tcl-smtpd@' . $smtp_smart_host . '>';
+
+print "Sending valid message\n";
+test_ok();
+print "Sending invalid message\n";
+test_no_rcpt();
+
+sub test_no_rcpt {
+  my $header = 'From: ' . $sender_address . "\n";
+  $header .= 'Subject: perl test' . "\n";
+  my $message = <<EOF;
+This is a sample message in no particular format, sent by Perl's
+Net::SMTP package.
+Let's check the transparency code with a sentance ending on the next line
+. Like this!
+EOF
+
+  Sendmail($header . "\n" . $message . "\n");
+}
+
+sub test_ok {
+  my $header = 'From: ' . $sender_address . "\n";
+  $header .= 'To: ' . $recipient_address . "\n";
+  $header .= 'Subject: perl test' . "\n";
+  my $message = <<EOF;
+This is a sample message in no particular format, sent by Perl's
+Net::SMTP package.
+Let's check the transparency code with a sentance ending on the next line
+. Like this!
+EOF
+
+  Sendmail($header . "\n" . $message . "\n");
+}
+
+# -------------------------------------------------------------------------
+# Sendmail replacement (replaces exec'ing /usr/lib/sendmail...)
+#
+# Just call this function with the entire mail (headers and body together).
+# The recipient and sender addresses are extracted from the mail text.
+# -------------------------------------------------------------------------
+
+sub Sendmail {
+    my ($msg) = (@_);
+    my @rcpts = ();
+    my $from = $smtp_default_from;
+    
+    # Process the message headers to identify the recipient list.
+    my @msg = split(/^$/m, $msg);
+    my $header = $msg[0];
+    $header =~ s/\n\s+/ /g;  # fix continuation lines
+    
+    my @lines = split(/^/m, $header);
+    chomp(@lines);
+    foreach my $line (@lines) {
+        my ($key, $value) = split(/:\s*/, $line, 2);
+        if ($key =~ /To|CC|BCC/i ) {
+            push(@rcpts, $value);
+        }
+        if ($key =~ /From/i) {
+            $from = $value;
+        }
+    }
+    
+    my $smtp = Net::SMTP->new($smtp_smart_host,
+                              Hello => hostname(),
+                              Port  => $smtp_smart_port,
+                              Timeout => $smtp_timeout,
+                              Debug => $smtp_debug)
+        || die "SMTP failed to connect: $!";
+
+    $smtp->mail($from, (Size=>length($msg), Bits=>'8'));
+    $smtp->to(@rcpts);
+    if ($smtp->data()) {        # start sending data;
+      $smtp->datasend($msg);    # send the message
+      $smtp->dataend();         # finished sending data
+    } else {
+      $smtp->reset();
+    }
+    $smtp->quit;                # end of session
+
+    if ( $smtp_log_mail ) {
+        if ( open(MAILLOG, ">> data/maillog") ) {
+            print MAILLOG "From $from at ", localtime() . "\n";
+            print MAILLOG "To: " . join(@rcpts, ',') . "\n";
+            print MAILLOG $msg . "\n\n";
+            close(MAILLOG);
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
diff --git a/tcllib/modules/smtpd/clients/mail-test.py b/tcllib/modules/smtpd/clients/mail-test.py
new file mode 100644
index 0000000..d50c98b
--- /dev/null
+++ b/tcllib/modules/smtpd/clients/mail-test.py
@@ -0,0 +1,53 @@
+# Python mail sample
+
+import sys, smtplib
+
+
+class SMTPTest:
+    def __init__(self, interface='localhost', port=25):
+        self.svr = smtplib.SMTP(interface, port)
+        self.svr.set_debuglevel(1)
+
+    def sendmail(self, sender, recipient, message):
+        try:
+            self.svr.sendmail(sender, recipient, message)
+        except:
+            print "oops"
+
+    def quit(self):
+        self.svr.quit()
+
+def test():
+    sndr = "python-script-test@localhost"
+    rcpt = "tcllib-test@localhost"
+    mesg = """From: Python Mailer <python-script@localhost>
+To: Tcllib Tester <tcllib-test@localhost>
+Date: Fri Dec 20 14:20:49 2002
+Subject: test from python
+
+This is a sample message from Python.
+Hope it's OK
+Check transparency:
+. <- there should be one dot here.
+Done
+"""
+    # Connect
+    svr = SMTPTest('localhost')
+
+    # Try normal message
+    svr.sendmail(sndr, rcpt, mesg)
+    
+    # should fail: invalid recipient.
+    svr.sendmail(sndr, "", mesg)
+    
+    # should fail: NULL recipient only valid for sender
+    svr.sendmail(sndr, "<>", mesg)
+
+    # should be ok: null sender (permitted for daemon responses)
+    svr.sendmail("<>", rcpt, mesg)
+
+    svr.quit()
+
+
+if __name__ == '__main__':
+    test()
diff --git a/tcllib/modules/smtpd/clients/mail-test.rb b/tcllib/modules/smtpd/clients/mail-test.rb
new file mode 100644
index 0000000..6a81152
--- /dev/null
+++ b/tcllib/modules/smtpd/clients/mail-test.rb
@@ -0,0 +1,16 @@
+require 'net/smtp'
+
+sndr = 'ruby-test-script@localhost'
+rcpt = 'tcllib-test@localhost'
+msg = 'From: Ruby <ruby-test-script@localhost>
+To: SMTPD <tcllib-test@localhost>
+Subject: Testing from Ruby
+
+This is a sample message send from Ruby.
+As always, let us check the transparency function:
+. <-- there should be a dot there.
+Bye'
+
+Net::SMTP.start('localhost', 25) do |smtp|
+  smtp.send_mail msg, sndr, rcpt
+end
diff --git a/tcllib/modules/smtpd/clients/mail-test.tcl b/tcllib/modules/smtpd/clients/mail-test.tcl
new file mode 100644
index 0000000..358cb83
--- /dev/null
+++ b/tcllib/modules/smtpd/clients/mail-test.tcl
@@ -0,0 +1,15 @@
+package require mime
+package require smtp
+
+set sndr "tcl-test-script@localhost"
+set rcpt "tcllib-test@localhost"
+set msg "This is a sample message send from Tcl.\nAs\
+always, let us check the transparency function:\n. <-- there\
+should be a dot there.\nBye"
+
+set tok [mime::initialize -canonical text/plain -encoding 7bit -string $msg]
+mime::setheader $tok Subject "Testing from Tcl"
+smtp::sendmessage $tok -servers localhost \
+    -header [list To $rcpt] \
+    -header [list From $sndr]
+
diff --git a/tcllib/modules/smtpd/clients/php.ini b/tcllib/modules/smtpd/clients/php.ini
new file mode 100644
index 0000000..9a840be
--- /dev/null
+++ b/tcllib/modules/smtpd/clients/php.ini
@@ -0,0 +1,56 @@
+[PHP]
+engine = On
+short_open_tag = On
+asp_tags = Off
+precision    =  14
+y2k_compliance = Off
+output_buffering = 4096
+output_handler =
+zlib.output_compression = Off
+implicit_flush = Off
+allow_call_time_pass_reference = Off
+safe_mode = Off
+safe_mode_gid = Off
+safe_mode_include_dir =								
+safe_mode_exec_dir =
+safe_mode_allowed_env_vars = PHP_
+safe_mode_protected_env_vars = LD_LIBRARY_PATH
+disable_functions =
+expose_php = On
+max_execution_time = 30     ; Maximum execution time of each script, in seconds
+memory_limit = 8M      ; Maximum amount of memory a script may consume (8MB)
+error_reporting  =  E_ALL
+display_errors = Off
+display_startup_errors = Off
+log_errors = On
+track_errors = Off
+warn_plus_overloading = Off
+variables_order = "GPCS"
+register_globals = Off
+register_argc_argv = Off
+post_max_size = 8M
+gpc_order = "GPC"
+magic_quotes_gpc = Off
+magic_quotes_runtime = Off    
+magic_quotes_sybase = Off
+auto_prepend_file =
+auto_append_file =
+default_mimetype = "text/html"
+doc_root =
+user_dir =
+extension_dir = ./
+enable_dl = On
+file_uploads = On
+upload_max_filesize = 2M
+allow_url_fopen = On
+[mail function]
+; Win32 only
+SMTP = localhost
+sendmail_from = postmaster@localhost
+
+; For Unix only.  You may supply arguments as well (default: "sendmail -t -i").
+;sendmail_path =
+
+; Local Variables:
+; tab-width: 4
+; End:
diff --git a/tcllib/modules/smtpd/pkgIndex.tcl b/tcllib/modules/smtpd/pkgIndex.tcl
new file mode 100644
index 0000000..f1c4fb8
--- /dev/null
+++ b/tcllib/modules/smtpd/pkgIndex.tcl
@@ -0,0 +1,12 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script.  It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands.  When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+if {![package vsatisfies [package provide Tcl] 8.3]} {return}
+package ifneeded smtpd 1.5 [list source [file join $dir smtpd.tcl]]
diff --git a/tcllib/modules/smtpd/smtpd.man b/tcllib/modules/smtpd/smtpd.man
new file mode 100644
index 0000000..b6680ef
--- /dev/null
+++ b/tcllib/modules/smtpd/smtpd.man
@@ -0,0 +1,294 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin smtpd n 1.5]
+[keywords {rfc 821}]
+[keywords {rfc 2821}]
+[keywords services]
+[keywords smtp]
+[keywords smtpd]
+[keywords socket]
+[keywords vwait]
+[copyright {Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[moddesc   {Tcl SMTP Server Package}]
+[titledesc {Tcl SMTP server implementation}]
+[category  Networking]
+[require Tcl 8.3]
+[require smtpd [opt 1.5]]
+[description]
+[para]
+
+The [package smtpd] package provides a simple Tcl-only server library
+for the Simple Mail Transfer Protocol as described in
+
+RFC  821 ([uri http://www.rfc-editor.org/rfc/rfc821.txt]) and
+RFC 2821 ([uri http://www.rfc-editor.org/rfc/rfc2821.txt]).
+
+By default the server will bind to the default network address and the
+standard SMTP port (25).
+
+[para]
+
+This package was designed to permit testing of Mail User Agent code
+from a developers workstation. [emph "It does not attempt to deliver \
+mail to your mailbox." ] Instead users of this package are expected to
+write a procedure that will be called when mail arrives. Once this
+procedure returns, the server has nothing further to do with the mail.
+
+[section SECURITY]
+
+On Unix platforms binding to the SMTP port requires root privileges. I
+would not recommend running any script-based server as root unless
+there is some method for dropping root privileges immediately after
+the socket is bound. Under Windows platforms, it is not necessary to
+have root or administrator privileges to bind low numbered
+sockets. However, security on these platforms is weak anyway.
+
+[para]
+
+In short, this code should probably not be used as a permanently
+running Mail Transfer Agent on an Internet connected server, even
+though we are careful not to evaluate remote user input. There are
+many other well tested and security audited programs that can be used
+as mail servers for internet connected hosts.
+
+[include ../common-text/tls-security-notes.inc]
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::smtpd::start] [opt [arg myaddr]] [opt [arg port]]]
+
+Start the service listening on [arg port] or the default port 25. If
+[arg myaddr] is given as a domain-style name or numerical
+dotted-quad IP address then the server socket will be bound to that
+network interface. By default the server is bound to all network
+interfaces. For example:
+
+[para]
+
+[example {
+  set sock [::smtpd::start [info hostname] 0]
+}]
+
+[para]
+
+will bind to the hosts internet interface on the first available port.
+
+[para]
+
+At present the package only supports a single instance of a SMTP
+server. This could be changed if required at the cost of making the
+package a little more complicated to read. If there is a good reason
+for running multiple SMTP services then it will only be necessary to
+fix the [var options] array and the [var ::smtpd::stopped] variable
+usage.
+
+[para]
+
+As the server code uses [cmd fileevent](n) handlers to process the
+input on sockets you will need to run the event loop. This means
+either you should be running from within [syscmd wish](1) or you
+should [cmd vwait](n) on the [var ::smtpd::stopped] variable which is
+set when the server is stopped.
+
+[call [cmd ::smtpd::stop]]
+
+Halt the server and release the listening socket. If the server has
+not been started then this command does nothing.
+
+The [var ::smtpd::stopped] variable is set for use with
+
+[cmd vwait](n).
+
+[para]
+
+It should be noted that stopping the server does not disconnect any
+currently active sessions as these are operating over an independent
+channel. Only explicitly tracking and closing these sessions, or
+exiting the server process will close down all the running
+sessions. This is similar to the usual unix daemon practice where the
+server performs a [syscmd fork](2) and the client session continues on
+the child process.
+
+[call [cmd ::smptd::configure] [opt "[arg option] [arg value]"] [opt "[arg option] [arg value] [arg ...]"]]
+
+Set configuration options for the SMTP server. Most values are the
+name of a callback procedure to be called at various points in the
+SMTP protocol. See the [sectref CALLBACKS] section for details of the
+procedures.
+
+[list_begin definitions]
+
+[def "[option -banner] [arg text]"]
+
+Text of a custom banner message. The default banner is "tcllib smtpd 1.5".
+Note that changing the banner does not affect the bracketing text
+in the full greeting, printing status 220, server-address, and timestamp.
+
+[def "[option -validate_host] [arg proc]"]
+
+Callback to authenticate new connections based on the ip-address of
+the client.
+
+[def "[option -validate_sender] [arg proc]"]
+
+Callback to authenticate new connections based on the senders email
+address.
+
+[def "[option -validate_recipient] [arg proc]"]
+
+Callback to validate and authorize a recipient email address
+
+[def "[option -deliverMIME] [arg proc]"]
+
+Callback used to deliver mail as a mime token created by the tcllib
+[package mime] package.
+
+[def "[option -deliver] [arg proc]"]
+
+Callback used to deliver email. This option has no effect if
+the [option -deliverMIME] option has been set.
+
+[list_end]
+
+[call [cmd ::smtpd::cget] [opt [arg option]]]
+
+If no [arg option] is specified the command will return a list of all
+options and their current values. If an option is specified it will
+return the value of that option.
+
+[list_end]
+
+[section CALLBACKS]
+
+[list_begin definitions]
+[def "[cmd validate_host] callback"]
+
+This procedure is called with the clients ip address as soon as a
+connection request has been accepted and before any protocol commands
+are processed. If you wish to deny access to a specific host then an
+error should be returned by this callback. For example:
+
+[para]
+[example {
+ proc validate_host {ipnum} {
+    if {[string match "192.168.1.*" $ipnum]} {
+       error "go away!"
+    }
+ }
+}]
+[para]
+
+If access is denied the client will receive a standard message that
+includes the text of your error, such as:
+
+[para]
+[example {
+ 550 Access denied: I hate you.
+}]
+[para]
+
+As per the SMTP protocol, the connection is not closed but we wait for
+the client to send a QUIT command. Any other commands cause a
+
+[const {503 Bad Sequence}] error.
+
+[def "[cmd validate_sender] callback"]
+
+The validate_sender callback is called with the senders mail address
+during processing of a MAIL command to allow you to accept or reject
+mail based upon the declared sender. To reject mail you should throw
+an error. For example, to reject mail from user "denied":
+
+[para]
+[example {
+ proc validate_sender {address} {
+    eval array set addr [mime::parseaddress $address]
+    if {[string match "denied" $addr(local)]} {
+         error "mailbox $addr(local) denied"
+    }
+    return
+ }
+}]
+
+[para]
+
+The content of any error message will not be passed back to the client.
+
+[def "[cmd validate_recipient] callback"]
+
+The validate_recipient callback is similar to the validate_sender
+callback and permits you to verify a local mailbox and accept mail for
+a local user address during RCPT command handling. To reject mail,
+throw an error as above. The error message is ignored.
+
+[def "[cmd deliverMIME] callback"]]
+
+The deliverMIME callback is called once a mail message has been
+successfully passed to the server. A mime token is constructed from
+the sender, recipients and data and the users procedure it called with
+this single argument. When the call returns, the mime token is cleaned
+up so if the user wishes to preserve the data she must make a copy.
+
+[para]
+[example {
+ proc deliverMIME {token} {
+     set sender [lindex [mime::getheader $token From] 0]
+     set recipients [lindex [mime::getheader $token To] 0]
+     set mail "From $sender [clock format [clock seconds]]"
+     append mail "\n" [mime::buildmessage $token]
+     puts $mail
+ }
+}]
+
+[def "[cmd deliver] callback"]
+
+The deliver callback is called once a mail message has been
+successfully passed to the server and there is no -deliverMIME option
+set. The procedure is called with the sender, a list of recipients and
+the text of the mail as a list of lines. For example:
+
+[para]
+[example {
+ proc deliver {sender recipients data} {
+    set mail "From $sender \
+               [clock format [clock seconds]]"
+    append mail "\n" [join $data "\n"]
+    puts "$mail"
+ }
+}]
+[para]
+
+Note that the DATA command will return an error if no sender or
+recipient has yet been defined.
+
+[list_end]
+
+[section VARIABLES]
+
+[list_begin definitions]
+
+[def [var ::smtpd::stopped]]
+
+This variable is set to [const true] during the [cmd ::smtpd::stop]
+command to permit the use of the [cmd vwait](n) command.
+
+[comment ::smtpd::postmaster]
+[comment {The e-mail address of the person that is the contact for the server.}]
+
+[list_end]
+
+[section AUTHOR]
+
+Written by Pat Thoyts [uri mailto:patthoyts@users.sourceforge.net].
+
+[section LICENSE]
+
+This software is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file
+[file license.terms] for more details.
+
+[vset CATEGORY smtpd]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/smtpd/smtpd.tcl b/tcllib/modules/smtpd/smtpd.tcl
new file mode 100644
index 0000000..96b2d9e
--- /dev/null
+++ b/tcllib/modules/smtpd/smtpd.tcl
@@ -0,0 +1,924 @@
+# smtpd.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# This provides a minimal implementation of the Simple Mail Tranfer Protocol
+# as per RFC821 and RFC2821 (http://www.normos.org/ietf/rfc/rfc821.txt) and
+# is designed for use during local testing of SMTP client software.
+#
+# -------------------------------------------------------------------------
+# This software is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+# or FITNESS FOR A PARTICULAR PURPOSE.  See the file 'license.terms' for
+# more details.
+# -------------------------------------------------------------------------
+# @mdgen EXCLUDE: clients/mail-test.tcl
+
+package require Tcl 8.3;                # tcl minimum version
+package require logger;                 # tcllib 1.3
+package require mime;                   # tcllib
+
+package provide smtpd 1.5
+
+namespace eval ::smtpd {
+    variable version [package present smtpd]
+    variable stopped
+
+    namespace export start stop configure
+
+    variable commands
+    if {![info exists commands]} {
+        set commands {EHLO HELO MAIL RCPT DATA RSET NOOP QUIT HELP}
+        # non-minimal commands HELP VRFY EXPN VERB ETRN DSN 
+    }
+
+    variable extensions
+    if {! [info exists extensions]} {
+        array set extensions {
+            8BITMIME {}
+            SIZE     0
+        }
+    }
+
+    variable options
+    if {! [info exists options]} {
+        array set options {
+            serveraddr         {}
+            deliverMIME        {}
+            deliver            {}
+            validate_host      {}
+            validate_sender    {}
+            validate_recipient {}
+            usetls             0
+            tlsopts            {}
+        }
+        set options(banner) "tcllib smtpd $version"
+    }
+    variable tlsopts {-cadir -cafile -certfile -cipher 
+        -command -keyfile -password -request -require -ssl2 -ssl3 -tls1}
+
+    variable log
+    if {![info exists log]} {
+        set log [logger::init smtpd]
+        ${log}::setlevel warn
+        proc ${log}::stdoutcmd {level text} {
+            variable service
+            puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\
+                $service $level\] $text"
+        }
+    }
+    
+    variable Help
+    if {![info exists Help]} {
+        array set Help {
+            {}   {{Topics:} {   HELO MAIL DATA RSET NOOP QUIT} 
+                {For more information use "HELP <topic>".}}
+            HELO {{HELO <hostname>} {   Introduce yourself.}}
+            MAIL {{MAIL FROM: <sender> [ <parameters> ]}
+                {   Specify the sender of the message.}
+                {   If using ESMTP there may be additional parameters of the}
+                {   form NAME=VALUE.}}
+            DATA {{DATA} {   Send your mail message.} 
+                {   End with a line containing a single dot.}}
+            RSET {{RSET} {   Reset the session.}}
+            NOOP {{NOOP} {   Command ignored by server.}}
+            QUIT {{QUIT} {   Exit SMTP session}}
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Obtain configuration options for the server.
+#
+proc ::smtpd::cget {option} {
+    variable options
+    variable tlsopts
+    variable log
+    set optname [string trimleft $option -]
+    if { [string equal option -loglevel] } {
+        return [${log}::currentloglevel]
+    } elseif { [info exists options($optname)] } {
+        return $options($optname)
+    } elseif {[lsearch -exact $tlsopts -$optname] != -1} {
+        set ndx [lsearch -exact $options(tlsopts) -$optname]
+        if {$ndx != -1} {
+            return [lindex $options(tlsopts) [incr ndx]]
+        }
+        return {}
+    } else {
+        return -code error "unknown option \"-$optname\": \
+            must be one of -[join [array names options] {, -}]"
+    }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Configure server options. These include validation of hosts or users
+#   and a procedure to handle delivery of incoming mail. The -deliver
+#   procedure must handle mail because the server may release all session
+#   resources once the deliver proc has completed.
+#   An example might be to exec procmail to deliver the mail to users.
+#
+proc ::smtpd::configure {args} {
+    variable options
+    variable commands
+    variable extensions
+    variable log
+    variable tlsopts
+
+    if {[llength $args] == 0} {
+        set r [list -loglevel [${log}::currentloglevel]]
+        foreach {opt value} [array get options] {
+            lappend r -$opt $value
+        }
+        lappend r -
+        return $r
+    }
+
+    while {[string match -* [set option [lindex $args 0]]]} {
+        switch -glob -- $option {
+            -loglevel           {${log}::setlevel [Pop args 1]}
+            -deliverMIME        {set options(deliverMIME) [Pop args 1]}
+            -deliver            {set options(deliver) [Pop args 1]}
+            -validate_host      {set options(validate_host) [Pop args 1]}
+            -validate_sender    {set options(validate_sender) [Pop args 1]}
+            -validate_recipient {set options(validate_recipient) [Pop args 1]}
+            -banner             {set options(banner) [Pop args 1]}
+            -usetls             {
+                set usetls [Pop args 1]
+                if {$usetls && ![catch {package require tls}]} {
+                    set options(usetls) 1
+                    set extensions(STARTTLS) {}
+                    lappend commands STARTTLS
+                }
+            }
+            --                  { Pop args; break }
+            default {
+                set failed 1
+                if {[lsearch $tlsopts $option] != -1} {
+                    set options(tlsopts) \
+                        [concat $options(tlsopts) $option [Pop args 1]]
+                    set failed 0
+                }
+                set msg "unknown option: \"$option\":\
+                           must be one of -deliverMIME, -deliver,\
+                           -validate_host, -validate_recipient,\
+                           -validate_sender or an option suitable\
+                           to tls::init"
+                if {$failed} {
+                    return -code error $msg
+                }
+            }
+        }
+        Pop args
+    }
+    return {}
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Start the server on the given interface and port.
+#
+proc ::smtpd::start {{myaddr {}} {port 25}} {
+    variable options
+    variable stopped
+    
+    if {[info exists options(socket)]} {
+        return -code error \
+            "smtpd service already running on socket $options(socket)"
+    }
+
+    if {$myaddr != {}} {
+        set options(serveraddr) $myaddr
+        set myaddr "-myaddr $myaddr"
+    } else {
+        if {$options(serveraddr) == {}} {
+            set options(serveraddr) [info hostname]
+        }
+    }
+
+    set options(socket) [eval socket \
+                             -server [namespace current]::accept $myaddr $port]
+    set stopped 0
+    Log notice "smtpd service started on $options(socket)"
+    return $options(socket)
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  Stop a running server. Do nothing if the server isn't running.
+#
+proc ::smtpd::stop {} {
+    variable options
+    variable stopped
+    if {[info exists options(socket)]} {
+        close $options(socket)
+        set stopped 1
+        Log notice "smtpd service stopped"
+        unset options(socket)
+    }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Accept a new connection and setup a fileevent handler to process the new
+#   session. Performs a host id validation step before allowing access.
+#
+proc ::smtpd::accept {channel client_addr client_port} {
+    variable options
+    variable version
+    upvar [namespace current]::state_$channel State
+
+    # init state array
+    catch {unset State}
+    initializeState $channel
+    set State(access) allowed
+    set State(client_addr) $client_addr
+    set State(client_port) $client_port
+    set accepted true
+
+    # configure the data channel
+    fconfigure $channel -buffering line -translation crlf -encoding ascii
+    fileevent $channel readable [list [namespace current]::service $channel]
+
+    # check host access permissions
+    if {[cget -validate_host] != {}} {
+        if {[catch {eval [cget -validate_host] $client_addr} msg] } {
+            Log notice "access denied for $client_addr:$client_port: $msg"
+            Puts $channel "550 Access denied: $msg"
+            set State(access) denied
+            set accepted false
+        }
+    }
+    
+    if {$accepted} {
+        # Accept the connection
+        Log notice "connect from $client_addr:$client_port on $channel"
+        Puts $channel "220 $options(serveraddr) $options(banner); [timestamp]"
+    }
+    
+    return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Initialize the channel state array. Called by accept and RSET.
+#
+proc ::smtpd::initializeState {channel} {
+    upvar [namespace current]::state_$channel State
+    set State(indata) 0
+    set State(to) {}
+    set State(from) {}
+    set State(data) {}
+    set State(options) {}
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Access the state of a connected session using the channel name as part
+#   of the state array name. Called with no value, it returns the current
+#   value of the item (or {} if not defined).
+#
+proc ::smtpd::state {channel args} {
+    if {[llength $args] == 0} {
+        return [array get [namespace current]::state_$channel]
+    }
+
+    set arrname [namespace current]::[subst state_$channel]
+
+    if {[llength $args] == 1} {
+        set r {}
+        if {[info exists [subst $arrname]($args)]} {
+            # FRINK: nocheck
+            set r [set [subst $arrname]($args)]
+        }
+        return $r
+    }
+
+    foreach {name value} $args {
+        # FRINK: nocheck
+        set [namespace current]::[subst state_$channel]($name) $value
+    }
+    return {}
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  Pop the nth element off a list. Used in options processing.
+#
+proc ::smtpd::Pop {varname {nth 0}} {
+    upvar $varname args
+    set r [lindex $args $nth]
+    set args [lreplace $args $nth $nth]
+    return $r
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  Wrapper to call our log procedure.
+#
+proc ::smtpd::Log {level text} {
+    variable log
+    ${log}::${level} $text
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Safe puts.
+#   If the client closes the channel, then puts will throw an error. Lets
+#   terminate the session if this occurs.
+proc ::smtpd::Puts {channel args} {
+    if {[catch {uplevel puts $channel $args} msg]} {
+        Log error $msg
+        catch {
+            close $channel
+            # FRINK: nocheck
+            unset -- [namespace current]::state_$channel
+        }
+    }
+    return $msg
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Perform the chat with a connected client. This procedure accepts input on
+#   the connected socket and executes commands according to the state of the
+#   session.
+#
+proc ::smtpd::service {channel} {
+    variable commands
+    variable options
+    upvar [namespace current]::state_$channel State
+
+    if {[eof $channel]} {
+        close $channel
+        return
+    }
+
+    if {[catch {gets $channel cmdline} msg]} {
+        close $channel
+        Log error $msg
+        return
+    }
+
+    if { $cmdline == "" && [eof $channel] } {
+        Log warn "client has closed the channel"
+        return
+    }
+
+    Log debug "received: $cmdline"
+
+    # If we are handling a DATA section, keep looking for the end of data.
+    if {$State(indata)} {
+        if {$cmdline == "."} {
+            set State(indata) 0
+            fconfigure $channel -translation crlf
+            if {[catch {deliver $channel} err]} {
+                # permit delivery handler to return SMTP errors in errorCode
+                if {[regexp {\d{3}} $::errorCode]} {
+                    Puts $channel "$::errorCode $err"
+                } else {
+                    Puts $channel "554 Transaction failed: $err"
+                }
+            } else {
+                Puts $channel "250 [state $channel id]\
+                        Message accepted for delivery"
+            }
+        } else {
+            # RFC 2821 section 4.5.2: Transparency
+            if {[string match {..*} $cmdline]} {
+                set cmdline [string range $cmdline 1 end]
+            }
+            lappend State(data) $cmdline
+        }
+        return
+    }
+
+    # Process SMTP commands (case insensitive)
+    set cmd [string toupper [lindex [split $cmdline] 0]]
+    if {[lsearch $commands $cmd] != -1} {
+        if {[info proc $cmd] == {}} {
+            Puts $channel "500 $cmd not implemented"
+        } else {
+            # If access denied then client can only issue QUIT.
+            if {$State(access) == "denied" && $cmd != "QUIT" } {
+                Puts $channel "503 bad sequence of commands"
+            } else {
+                set r [eval $cmd $channel [list $cmdline]]
+            }
+        }
+    } else {
+        Puts $channel "500 Invalid command"
+    }
+
+    return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  Generate a random ASCII character for use in mail identifiers.
+#
+proc ::smtpd::uidchar {} {
+    set c .
+    while {! [string is alnum $c]} {
+        set n [expr {int(rand() * 74 + 48)}]
+        set c [format %c $n]
+    }
+    return $c
+}
+
+# Description:
+#  Generate a unique random identifier using only ASCII alphanumeric chars.
+#
+proc ::smtpd::uid {} {
+    set r {}
+    for {set cn 0} {$cn < 12} {incr cn} {
+        append r [uidchar]
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Calculate the local offset from GMT in hours for use in the timestamp
+#
+proc ::smtpd::gmtoffset {} {
+    set now [clock seconds]
+    set local [clock format $now -format "%j %H" -gmt false]
+    set zulu  [clock format $now -format "%j %H" -gmt true]
+    set lh [expr {([scan [lindex $local 0] %d] * 24) \
+                      + [scan [lindex $local 1] %d]}]
+    set zh [expr {([scan [lindex $zulu 0] %d] * 24) \
+                      + [scan [lindex $zulu 1] %d]}]
+    set off [expr {$lh - $zh}]
+    set off [format "%+03d00" $off]
+    return $off
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Generate a standard SMTP compliant timestamp. That is a local time but with
+#   the timezone represented as an offset.
+#
+proc ::smtpd::timestamp {} {
+    set ts [clock format [clock seconds] \
+                -format "%a, %d %b %Y %H:%M:%S" -gmt false]
+    append ts " " [gmtoffset]
+    return $ts
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Get the servers ip address (from http://purl.org/mini/tcl/526.html)
+#
+proc ::smtpd::server_ip {} {
+    set me [socket -server xxx -myaddr [info hostname] 0]
+    set ip [lindex [fconfigure $me -sockname] 0]
+    close $me
+    return $ip
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   deliver is called once a mail transaction is completed and there is
+#   no deliver procedure defined
+#   The configured -deliverMIME procedure is called with a MIME token.
+#   If no such callback is defined then try the -deliver option and use
+#   the old API.
+#
+proc ::smtpd::deliver {channel} {
+    set deliverMIME [cget deliverMIME]
+    if { $deliverMIME != {} \
+            && [state $channel from] != {} \
+            && [state $channel to] != {} \
+            && [state $channel data] != {} } {
+        
+        # create a MIME token from the mail message.        
+        set tok [mime::initialize -string \
+                [join [state $channel data] "\n"]]
+#        mime::setheader $tok "From" [state $channel from]
+#        foreach recipient [state $channel to] {
+#            mime::setheader $tok "To" $recipient -mode append
+#        }
+        
+        # catch and rethrow any errors.
+        set err [catch {eval $deliverMIME [list $tok]} msg]
+        mime::finalize $tok -subordinates all
+        if {$err} {
+            Log debug "error in deliver: $msg"
+            return -code error -errorcode $::errorCode \
+                    -errorinfo $::errorInfo $msg
+        }        
+        
+    } else {
+        # Try the old interface
+        deliver_old $channel
+    }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Deliver is called once a mail transaction is completed (defined as the
+#   completion of a DATA command). The configured -deliver procedure is called
+#   with the sender, list of recipients and the text of the mail.
+#
+proc ::smtpd::deliver_old {channel} {
+    set deliver [cget deliver]
+    if { $deliver != {} \
+             && [state $channel from] != {} \
+             && [state $channel to] != {} \
+             && [state $channel data] != {} } {
+        if {[catch {$deliver [state $channel from] \
+                        [state $channel to] \
+                        [state $channel data]} msg]} {
+            Log debug "error in deliver: $msg"
+            return -code error -errorcode $::errorCode \
+                    -errorinfo $::errorInfo $msg
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+proc ::smtpd::split_address {address} {
+    set start [string first < $address]
+    set end [string last > $address]
+    set addr [string range $address $start $end]
+    incr end
+    set opts [string trim [string range $address $end end]]
+    return [list $addr $opts]
+}
+
+# -------------------------------------------------------------------------
+# The SMTP Commands
+# -------------------------------------------------------------------------
+# Description:
+#   Initiate an SMTP session
+# Reference:
+#   RFC2821 4.1.1.1
+#
+proc ::smtpd::HELO {channel line} {
+    variable options
+
+    if {[state $channel domain] != {}} {
+        Puts $channel "503 bad sequence of commands"
+        Log debug "HELO received out of sequence."
+        return
+    }
+
+    set r [regexp -nocase {^HELO\s+([-\w\.]+)\s*$} $line -> domain]
+    if {$r == 0} {
+        Puts $channel "501 Syntax error in parameters or arguments"
+        Log debug "HELO received \"$line\""
+        return
+    }
+    Puts $channel "250 $options(serveraddr) Hello $domain\
+                     \[[state $channel client_addr]\], pleased to meet you"
+    state $channel domain $domain
+    Log debug "HELO on $channel from $domain"
+    return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Initiate an ESMTP session
+# Reference:
+#   RFC2821 4.1.1.1
+proc ::smtpd::EHLO {channel line} {
+    variable options
+    variable extensions
+
+    if {[state $channel domain] != {}} {
+        Puts $channel "503 bad sequence of commands"
+        Log debug "EHLO received out of sequence."
+        return
+    }
+
+    set r [regexp -nocase {^EHLO\s+([-\w\.]+)\s*$} $line -> domain]
+    if {$r == 0} {
+        Puts $channel "501 Syntax error in parameters or arguments"
+        Log debug "EHLO received \"$line\""
+        return
+    }
+    Puts $channel "250-$options(serveraddr) Hello $domain\
+                     \[[state $channel client_addr]\], pleased to meet you"
+    foreach {extn opts} [array get extensions] {
+        Puts $channel [string trimright "250-$extn $opts"]
+    }
+    Puts $channel "250 Ready for mail."
+    state $channel domain $domain
+    Log debug "EHLO on $channel from $domain"
+    return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Reference:
+#   RFC2821 4.1.1.2
+#
+proc ::smtpd::MAIL {channel line} {
+    set r [regexp -nocase {^MAIL FROM:\s*(.*)} $line -> from]
+    if {$r == 0} {
+        Puts $channel "501 Syntax error in parameters or arguments"
+        Log debug "MAIL received \"$line\""
+        return
+    }
+    if {[catch {
+        set from [split_address $from]
+        set opts [lindex $from 1]
+        set from [lindex $from 0]
+        eval array set addr [mime::parseaddress $from]
+        # RFC2821 3.7: we must accept null return path addresses.
+        if {[string equal "<>" $from]} {
+            set addr(error) {}
+        }
+    } msg]} {
+        set addr(error) $msg
+    }
+    if {$addr(error) != {} } {
+        Log debug "MAIL failed $addr(error)"
+        Puts $channel "501 Syntax error in parameters or arguments"
+        return
+    }
+
+    if {[cget -validate_sender] != {}} {
+        if {[catch {eval [cget -validate_sender] $addr(address)}]} {
+            # this user has been denied
+            Log info "MAIL denied user $addr(address)"
+            Puts $channel "553 Requested action not taken:\
+                            mailbox name not allowed"
+            return
+        }
+    }
+
+    Log debug "MAIL FROM: $addr(address)"
+    state $channel from $from
+    state $channel options $opts
+    Puts $channel "250 OK"
+    return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Specify a recipient for this mail. This command may be executed multiple
+#   times to contruct a list of recipients. If a -validate_recipient 
+#   procedure is configured then this is used. An error from the validation
+#   procedure indicates an invalid or unacceptable mailbox.
+# Reference:
+#   RFC2821 4.1.1.3
+# Notes:
+#   The postmaster mailbox MUST be supported. (RFC2821: 4.5.1)
+#
+proc ::smtpd::RCPT {channel line} {
+    set r [regexp -nocase {^RCPT TO:\s*(.*)} $line -> to]
+    if {$r == 0} {
+        Puts $channel "501 Syntax error in parameters or arguments"
+        Log debug "RCPT received \"$line\""
+        return
+    }
+    if {[catch {
+        set to [split_address $to]
+        set opts [lindex $to 1]
+        set to [lindex $to 0]
+        eval array set addr [mime::parseaddress $to]
+    } msg]} {
+        set addr(error) $msg
+    }
+
+    if {$addr(error) != {}} {
+        Log debug "RCPT failed $addr(error)"
+        Puts $channel "501 Syntax error in parameters or arguments"
+        return
+    }
+
+    if {[string match -nocase "postmaster" $addr(local)]} {
+        # we MUST support this recipient somehow as mail.
+        Log notice "RCPT to postmaster"
+    } else {
+        if {[cget -validate_recipient] != {}} {
+            if {[catch {eval [cget -validate_recipient] $addr(address)}]} {
+                # this recipient has been denied
+                Log info "RCPT denied mailbox $addr(address)"
+                Puts $channel "553 Requested action not taken:\
+                            mailbox name not allowed"
+                return
+            }
+        }
+    }
+
+    Log debug "RCPT TO: $addr(address)"
+    set recipients {}
+    catch {set recipients [state $channel to]}
+    lappend recipients $to
+    state $channel to $recipients
+    Puts $channel "250 OK"
+    return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Begin accepting data for the mail payload. A line containing a single 
+#   period marks the end of the data and the server will then deliver the
+#   mail. RCPT and MAIL commands must have been executed before the DATA
+#   command.
+# Reference:
+#   RFC2821 4.1.1.4
+# Notes:
+#   The DATA section is the only part of the protocol permitted to use non-
+#   ASCII characters and non-CRLF line endings and some clients take
+#   advantage of this. Therefore we change the translation option on the
+#   channel and reset it once the DATA command is completed. See the
+#   'service' procedure for the handling of DATA lines.
+#   We also insert trace information as per RFC2821:4.4
+#
+proc ::smtpd::DATA {channel line} {
+    variable version
+    upvar [namespace current]::state_$channel State
+    Log debug "DATA"
+    if { $State(from) == {}} {
+        Puts $channel "503 bad sequence: no sender specified"
+    } elseif { $State(to) == {}} {
+        Puts $channel "503 bad sequence: no recipient specified"
+    } else {
+        Puts $channel "354 Enter mail, end with \".\" on a line by itself"
+        set State(id) [uid]
+        set State(indata) 1
+
+        lappend trace "Return-Path: $State(from)"
+        lappend trace "Received: from [state $channel domain]\
+                   \[[state $channel client_addr]\]"
+        lappend trace "\tby [info hostname] with tcllib smtpd ($version)"
+        if {[info exists State(tls)] && $State(tls)} {
+            catch {
+                array set t [::tls::status $channel]
+                lappend trace "\t(version=TLS1/SSL3 cipher=$t(cipher) bits=$t(sbits) verify=NO)"
+            }
+        }
+        lappend trace "\tid $State(id); [timestamp]"
+        set State(data) $trace
+        fconfigure $channel -translation auto ;# naughty: RFC2821:2.3.7
+    }
+    return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Reset the server state for this connection.
+# Reference:
+#   RFC2821 4.1.1.5
+#
+proc ::smtpd::RSET {channel line} {
+    upvar [namespace current]::state_$channel State
+    Log debug "RSET on $channel"
+    if {[catch {initializeState $channel} msg]} {
+        Log warn "RSET: $msg"
+    }
+    Puts $channel "250 OK"
+    return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Verify the existence of a mailbox on the server
+# Reference:
+#   RFC2821 4.1.1.6
+#
+#proc ::smtpd::VRFY {channel line} {
+#    # VRFY SP String CRLF
+#}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Expand a mailing list.
+# Reference:
+#   RFC2821 4.1.1.7
+#
+#proc ::smtpd::EXPN {channel line} {
+#    # EXPN SP String CRLF
+#}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Return a help message.
+# Reference:
+#   RFC2821 4.1.1.8
+#
+proc ::smtpd::HELP {channel line} {
+    variable Help
+    set cmd {}
+    regexp {^HELP\s*(\w+)?} $line -> cmd
+    if {[info exists Help($cmd)]} {
+        foreach line $Help($cmd) {
+            Puts $channel "214-$line"
+        }
+        Puts $channel "214 End of HELP"
+    } else {
+        Puts $channel "504 HELP topic \"$cmd\" unknown."
+    }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Perform no action.
+# Reference:
+#   RFC2821 4.1.1.9
+#
+proc ::smtpd::NOOP {channel line} {
+    set str {}
+    regexp -nocase {^NOOP (.*)$} -> str
+    Log debug "NOOP: $str"
+    Puts $channel "250 OK"
+    return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Terminate a session and close the transmission channel.
+# Reference:
+#   RFC2821 4.1.1.10
+# Notes:
+#   The server is only permitted to close the channel once it has received 
+#   a QUIT message.
+#
+proc ::smtpd::QUIT {channel line} {
+    variable options
+    upvar [namespace current]::state_$channel State
+
+    Log debug "QUIT on $channel"
+    Puts $channel "221 $options(serveraddr) Service closing transmission channel"
+    close $channel
+        
+    # cleanup the session state array.
+    unset State
+    return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#   Implement support for secure mail transactions using the TLS package.
+# Reference:
+#   RFC3207
+# Notes:
+#
+proc ::smtpd::STARTTLS {channel line} {
+    variable options
+    upvar [namespace current]::state_$channel State
+    
+    Log debug "$line on $channel"
+    if {![string equal $line STARTTLS]} {
+        Puts $channel "501 Syntax error (no parameters allowed)"
+        return
+    }
+
+    if {[lsearch -exact $options(tlsopts) -certfile] == -1
+        || [lsearch -exact $options(tlsopts) -keyfile] == -1} {
+        Puts $channel "454 TLS not available due to temporary reason"
+        return
+    }
+    
+    set import [linsert $options(tlsopts) 0 ::tls::import $channel -server 1]
+    Puts $channel "220 Ready to start TLS"
+    if {[catch $import msg]} {
+        Puts $channel "454 TLS not available due to temporary reason"
+    } else {
+        set State(domain) {};           #  RFC3207:4.2
+        set State(tls) 1
+    }
+    return
+}
+
+# -------------------------------------------------------------------------
+# Logging callback for use with tls - you must specify this when configuring
+# smtpd if you wan to use it.
+#
+proc ::smtpd::tlscallback {option args} {
+    switch -exact -- $option {
+        "error" {
+            foreach {chan msg} $args break
+            Log error "TLS error '$msg'"
+        } 
+        "verify" {
+            foreach {chan depth cert rc err} $args break
+            if {$rc ne "1"} {
+                Log error "TLS verify/$depth Bad cert '$err' (rc=$rc)"
+            } else {
+                array set c $cert
+                Log notice "TLS verify/$depth: $c(subject)"
+            }
+            return $rc
+        }
+        "info" {
+            foreach {chan major minor state msg} $args break
+            if {$msg ne ""} { append state ": $msg" }
+            Log debug "TLS ${major}.${minor} $state"
+        }
+        default  {
+            Log warn "bad option \"$option\" in smtpd::callback"
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# Local variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End: