Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

4 files changed, 367 insertions, 0 deletions

diff --git a/tcllib/examples/smtpd/server-private.key b/tcllib/examples/smtpd/server-private.key
new file mode 100644
index 0000000..bf883fb
--- /dev/null
+++ b/tcllib/examples/smtpd/server-private.key
@@ -0,0 +1,15 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIICWwIBAAKBgQCwWkRvG8lrUN2EGK9yByncv6jFR6GWFnxTgGYOukRrUm1Ai79M
+8YxprSxw1ZbnK0bl51VukRKjLB0w1Be7+EYqVMyOUFsOVVN3kKH+gzYXELrMCL4k
+QWZkdf67OSqBDSe1JklQLvQLeq+Wa1pwaaipJaxeoPXZ4OwLW98Bh2D2PwIDAQAB
+AoGANWlRerlWursGLEDxuj5zLlmZ+w4j4Xoz83Ja9rDxkfOoBTmOGfa6iTMa153J
+E4Cm+3CiDle/5k2xFZ3XBmY+kYiQ8pB2R9sw6WInzlsovwn+DD0uDjXZKMH3U9DP
+kA3wB9z96JufEVIYHW7wknios7OPUi8y9SiVVh2i+Hk8jMECQQDj9+24nHT9V+eH
+9/0EF915L5bOPxnEr0NWheDLejTWujFvzH018B2IpbTROCE/NCmpvgDquWWk76se
+P/JV9bTfAkEAxgmOdCmkor0lEzYxl2BwAmW88dQiABVPpGQuepgUAyWQB5A9ZSAV
+zyVEuwj/0XYAmKqKxMG7HH85Q+Np/OaKoQJAOIH7ThiSMz436Q9Ci2IzBtgSBJvF
+kmhzQ54545YuRM+wc2r32ofjejzA/l9wdk9CyI2NgqFkHac+/meRdVdLdwJASEAY
+Tt0aiZ0EN7wf36B5fQZtJrVEKk+cHNfH9UYilvtPTtMa8xf/nPF1397qphqtIQWn
+Vx1vDHiGBfSkKHZbwQJARTPon0ksT7Yl3nO07m/aoOqrrEm6+3JK1Ihcq5kkiXv9
+0A3ae1V0iJbnya/LTmeo5bVvm+DQQDWAEXp6bOlb3w==
+-----END RSA PRIVATE KEY-----
diff --git a/tcllib/examples/smtpd/server-public.pem b/tcllib/examples/smtpd/server-public.pem
new file mode 100644
index 0000000..e580c8f
--- /dev/null
+++ b/tcllib/examples/smtpd/server-public.pem
@@ -0,0 +1,22 @@
+-----BEGIN CERTIFICATE-----
+MIIDqjCCAxOgAwIBAgIBADANBgkqhkiG9w0BAQQFADCBmzELMAkGA1UEBhMCVUsx
+EDAOBgNVBAgTB0VuZ2xhbmQxEDAOBgNVBAcTB0JyaXN0b2wxDzANBgNVBAoTBlRj
+bGxpYjEOMAwGA1UECxMFc210cGQxFzAVBgNVBAMTDlBhdHJpY2sgVGhveXRzMS4w
+LAYJKoZIhvcNAQkBFh9wYXR0aG95dHNAdXNlcnMuc291cmNlZm9yZ2UubmV0MB4X
+DTA0MDYyNDE4MzExOFoXDTEyMDkxMDE4MzExOFowgZsxCzAJBgNVBAYTAlVLMRAw
+DgYDVQQIEwdFbmdsYW5kMRAwDgYDVQQHEwdCcmlzdG9sMQ8wDQYDVQQKEwZUY2xs
+aWIxDjAMBgNVBAsTBXNtdHBkMRcwFQYDVQQDEw5QYXRyaWNrIFRob3l0czEuMCwG
+CSqGSIb3DQEJARYfcGF0dGhveXRzQHVzZXJzLnNvdXJjZWZvcmdlLm5ldDCBnzAN
+BgkqhkiG9w0BAQEFAAOBjQAwgYkCgYEAsFpEbxvJa1DdhBivcgcp3L+oxUehlhZ8
+U4BmDrpEa1JtQIu/TPGMaa0scNWW5ytG5edVbpESoywdMNQXu/hGKlTMjlBbDlVT
+d5Ch/oM2FxC6zAi+JEFmZHX+uzkqgQ0ntSZJUC70C3qvlmtacGmoqSWsXqD12eDs
+C1vfAYdg9j8CAwEAAaOB+zCB+DAdBgNVHQ4EFgQUQEywvfh7Yli2bSgtO86qbicM
+YOQwgcgGA1UdIwSBwDCBvYAUQEywvfh7Yli2bSgtO86qbicMYOShgaGkgZ4wgZsx
+CzAJBgNVBAYTAlVLMRAwDgYDVQQIEwdFbmdsYW5kMRAwDgYDVQQHEwdCcmlzdG9s
+MQ8wDQYDVQQKEwZUY2xsaWIxDjAMBgNVBAsTBXNtdHBkMRcwFQYDVQQDEw5QYXRy
+aWNrIFRob3l0czEuMCwGCSqGSIb3DQEJARYfcGF0dGhveXRzQHVzZXJzLnNvdXJj
+ZWZvcmdlLm5ldIIBADAMBgNVHRMEBTADAQH/MA0GCSqGSIb3DQEBBAUAA4GBAH0x
+GEdC2pnSj/KFTjywDWIcbdmY5sK9FEDIY3Z0Zc147oHcv6tNmPWpQA/s0i9TawpF
+v7+qpQ9ZFGxVyA9lfKApUrKEXNS7PdHTu1EcHVlpCLUX8txkP2qbg0Qppfoetq47
+UPQVkym+kGgGzkpd1tdcJRxSspz+VAbSOKzU5S0j
+-----END CERTIFICATE-----
diff --git a/tcllib/examples/smtpd/tcl_smtpd b/tcllib/examples/smtpd/tcl_smtpd
new file mode 100644
index 0000000..ad6ac73
--- /dev/null
+++ b/tcllib/examples/smtpd/tcl_smtpd
@@ -0,0 +1,92 @@
+#!/usr/bin/env tclsh
+## -*- tcl -*-
+# tcl_smtpd - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Simple test of the mail server. All incoming messages are displayed to
+# stdout.
+#
+# Usage tk_smtpd 0.0.0.0 8025
+#    or tk_smtpd 127.0.0.1 2525
+#    or tk_smtpd
+# to listen to the default port 25 on all tcp/ip interfaces.
+#
+# -------------------------------------------------------------------------
+# 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.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.3
+package require smtpd
+
+# In this example application we just print received mail to stdout.
+proc deliver {sender recipients data} {
+    if {[catch {eval array set saddr [mime::parseaddress $sender]}]} {
+        error "invalid sender address \"$sender\""
+    }
+    set mail "From $saddr(address) [clock format [clock seconds]]"
+    append mail "\n" [join $data "\n"]
+
+    foreach rcpt $recipients {
+        if {! [catch {eval array set addr [mime::parseaddress $rcpt]}]} {
+            puts $mail
+        }
+    }
+}
+
+# Deny only hosts from 192.168.1.*
+proc validate_host {ipnum} {
+    if {[string match "192.168.1.*" $ipnum]} {
+        error "your domain is not allowed to post, Spammers!"
+    }
+}
+
+# Only reject sender 'denied'
+proc validate_sender {address} {
+    eval array set addr [mime::parseaddress $address]
+    if {[string match "denied" $addr(local)]} {
+        error "mailbox $addr(local) denied"
+    }
+    return
+}
+
+# Only reject recipients beginning with 'bogus'
+proc validate_recipient {address} {
+    eval array set addr [mime::parseaddress $address]
+    if {[string match "bogus*" $addr(local)]} {
+        error "mailbox $addr(local) denied"
+    }
+    return
+}
+
+# Set up the server
+smtpd::configure \
+    -deliver            ::deliver \
+    -validate_host      ::validate_host \
+    -validate_recipient ::validate_recipient \
+    -validate_sender    ::validate_sender
+
+# Run the server on the default port 25. For unix change to 
+# a high numbered port eg: 2525 or 8025 etc with
+# smtpd::start 127.0.0.1 8025 or smtpd::start 0.0.0.0 2525
+
+set iface 0.0.0.0
+set port 25
+
+if {$argc > 0} {
+    set iface [lindex $argv 0]
+}
+if {$argc > 1} {
+    set port [lindex $argv 1]
+}
+
+smtpd::start $iface $port
+
+vwait forever
+
+#
+# Local variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End:
diff --git a/tcllib/examples/smtpd/tk_smtpd b/tcllib/examples/smtpd/tk_smtpd
new file mode 100644
index 0000000..8d1e375
--- /dev/null
+++ b/tcllib/examples/smtpd/tk_smtpd
@@ -0,0 +1,238 @@
+#!/usr/bin/env wish
+## -*- tcl -*-
+# tk_smtpd -Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Test of the mail server. All incoming messages are displayed in a 
+# message dialog. This version requires smtpd 1.3.0 which has support for
+# secure mail transactions. If you have the tls package available then the
+# mail connection will be upgraded as per RFC 3207.
+#
+# For this to work smtpd::configure command must be called with some options
+# for the tls::import command. See the tls package documentation and this
+# example for details. A server certificate is required as well. A 
+# demonstration self-signed certificate is provided.
+#
+# Usage tk_smtpd 0.0.0.0 8025
+#    or tk_smtpd 127.0.0.1 2525
+#    or tk_smtpd
+# to listen to the default port 25 on all tcp/ip interfaces. 
+# Alternatively you may configure the server via the GUI.
+#
+# -------------------------------------------------------------------------
+# 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.
+# -------------------------------------------------------------------------
+
+package require Tcl   8.3
+package require Tk    8.3
+package require mime  1.3
+package require smtpd 1.4
+
+variable options
+if {![info exists options]} {
+    set dir [file dirname [info script]]
+    array set options [list \
+        loglevel   debug    \
+        interface  0.0.0.0  \
+        port       2525     \
+        usetls     1        \
+        require    0        \
+        request    1        \
+        certfile           [file join $dir server-public.pem] \
+        keyfile            [file join $dir server-private.key] \
+    ]
+}
+
+variable forever
+if {![info exists forever]} { set forever 0 }
+variable console
+if {![info exists console]} { set console 0 }
+
+wm title . "Tcllib SMTPd [package provide smtpd] Demo"
+set _dlgid 0
+
+# Handle new mail by raising a message dialog for each recipient.
+proc deliverMIME {token} {
+
+    set senders [mime::getheader $token From]
+    set recipients [mime::getheader $token To]
+
+    if {[catch {eval array set saddr \
+                    [mime::parseaddress [lindex $senders 0]]}]} {
+        error "invalid sender address \"$senders\""
+    }
+    set mail "From $saddr(address) [::smtpd::timestamp]\n"
+    append mail [mime::buildmessage $token]
+    foreach rcpt $recipients {
+        if {! [catch {eval array set addr [mime::parseaddress $rcpt]}]} {
+            display "To: $addr(address)" $mail
+        }
+    }
+}
+
+proc display {title mail} {
+    global _dlgid
+    incr _dlgid
+    set dlg [toplevel .dlg$_dlgid]
+    set txt [text ${dlg}.e -yscrollcommand [list ${dlg}.sb set]]
+    set scr [scrollbar ${dlg}.sb -command [list $txt yview]]
+    set but [button ${dlg}.b -text "Dismiss" -command [list destroy $dlg]]
+    grid $txt $scr -sticky news
+    grid $but   -  -sticky ns
+    grid rowconfigure    $dlg 0 -weight 1
+    grid columnconfigure $dlg 0 -weight 1
+    wm title $dlg $title
+    $txt insert 0.0 [string map {\r\n \n} $mail]
+}
+
+# Accept everyone except those spammers on 192.168.1.* :)
+proc validate_host {ipnum} {
+    if {[string match "192.168.1.*" $ipnum]} {
+        error "your domain is not allowed to post, Spammers!"
+    }
+}
+
+# Accept mail from anyone except user 'denied'
+proc validate_sender {address} {
+    eval array set addr [mime::parseaddress $address]
+    if {[string match "denied" $addr(local)]} {
+        error "mailbox $addr(local) denied"
+    }
+    return    
+}
+
+# Only reject mail for recipients beginning with 'bogus'
+proc validate_recipient {address} {
+    eval array set addr [mime::parseaddress $address]
+    if {[string match "bogus*" $addr(local)]} {
+        error "mailbox $addr(local) denied"
+    }
+    return
+}
+
+# -------------------------------------------------------------------------
+
+proc Start {} {
+    variable options
+    smtpd::configure \
+        -loglevel           $options(loglevel) \
+        -deliverMIME        ::deliverMIME \
+        -validate_host      ::validate_host \
+        -validate_recipient ::validate_recipient \
+        -validate_sender    ::validate_sender \
+        -certfile           $options(certfile) \
+        -keyfile            $options(keyfile) \
+        -usetls             $options(usetls) \
+        -ssl2               1 \
+        -ssl3               1 \
+        -tls1               1 \
+        -require            $options(require) \
+        -request            $options(request) \
+        -command            ::smtpd::tlscallback
+
+    smtpd::start $options(interface) $options(port)
+}
+
+proc Stop {} {
+    smtpd::stop
+}
+
+proc Exit {} {
+    variable forever
+    Stop
+    set forever 1
+}
+
+proc ${::smtpd::log}::stdoutcmd {level text} {
+    .t insert end "$text\n" $level
+    .t see end
+}
+
+proc tkerror {msg} {
+    .t insert end "$msg\n" error
+    .t see end
+}
+
+proc ToggleConsole {} {
+    variable console
+    if {[llength [info commands console]]} {
+        if {$console} {
+            console hide ; set console 0
+        } else {
+            console show ; set console 1
+        }
+    }
+}
+
+# Configure a GUI
+proc Main {} {
+    variable options
+    label .l1 -text "Address" -anchor nw
+    entry .e1 -textvariable ::options(interface)
+    label .l2 -text "Port" -anchor nw
+    entry .e2 -textvariable ::options(port)
+    label .l3 -text "Public certificate file" -anchor nw
+    entry .e3 -textvariable ::options(certfile)
+    label .l4 -text "Private key file" -anchor nw
+    entry .e4 -textvariable ::options(keyfile)
+    label .l5 -text "Log level" -anchor nw
+    entry .e5 -textvariable ::options(loglevel)
+
+    frame .f3 -borderwidth 0
+    checkbutton .c1 -text "Support TLS" -variable ::options(usetls)
+    checkbutton .c2 -text "Request cerificate" -variable ::options(request)
+    checkbutton .c3 -text "Require certificate" -variable ::options(require)
+    grid .c1 .c2 .c3 -in .f3 -sticky news
+
+    frame .f1 -borderwidth 0
+    text .t -height 10 -yscrollcommand [list .sb set]
+    scrollbar .sb -command [list .t yview]
+    grid .t .sb -in .f1 -sticky news
+    
+    frame  .f2 -borderwidth 0
+    button .b1 -width -12 -text Start -command Start
+    button .b2 -width -12 -text Stop -command Stop
+    button .b3 -width -12 -text Exit -command Exit
+    grid   .b1 .b2 .b3 -in .f2 -sticky ne -padx 1 -pady 2
+
+    grid .l1 .e1 .l2 .e2  -sticky news
+    grid .f3 -   -   -    -sticky news
+    grid .l3 .e3 -   -    -sticky news
+    grid .l4 .e4 -   -    -sticky news
+    grid .f1 -   -   -    -sticky news
+    grid .l5 .e5 .f2 -    -sticky ne
+    grid rowconfigure    . 4 -weight 1
+    grid columnconfigure . 3 -weight 1
+    grid rowconfigure    .f1 0 -weight 1
+    grid columnconfigure .f1 0 -weight 1
+
+    bind . <F2> {ToggleConsole}
+}
+
+# -------------------------------------------------------------------------
+
+if {$tcl_interactive } {
+
+    puts {you'll want to issue 'smtpd::start' to begin}
+
+} else {
+
+    if {$argc > 0} {
+        set iface [lindex $argv 0]
+    }
+    if {$argc > 1} {
+        set port [lindex $argv 1]
+    }
+
+    Main
+    tkwait variable forever
+    destroy .
+}
+
+#
+# Local variables:
+#  mode: tcl
+#  indent-tabs-mode: nil
+# End: