Note: The tcllib smtpd package is a framework for writing Mail Transfer Agents (MTA). It does not handle delivery but provides hooks to program against. Its function is to provide a correct interface to SMTP network clients; "correct" here means, in conformance with RFCs 821 and 2821 [1].
Here's a simple example (found in the tcllib examples tree):
#! /bin/sh
#
# tk_smtpd - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# Simple test of the mail server. All incoming messages are displayed in a
# message dialog.
#
# This example works nicely under Windows or within tkcon.
#
# 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.
# -------------------------------------------------------------------------
# \
exec wish8.3 "$0" ${1+"$@"}
package require smtpd
package require Tk
wm withdraw .
# Handle new mail by raising a message dialog for each recipient.
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]}]} {
tk_messageBox -title "To: $addr(address)" -message $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
}
# Setup the mail 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
#
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:The following will take and only send the message to unique destinations. It uses both the smtpd and smtp packages.
##
## Program to ensure that duplicate messages are not sent from ClearQuest
## to a given recipient
##
##
## Require any packages that will be used
##
package require Tcl
package require mime
package require smtpd
package require smtp
package require log
package require msgcat
##
## Set global variables
##
set allowedUserPatternList {*}
set allowedHostIPList {127.0.0.1}
set mailForwardingHost {houmailgwi1.hou.aspentech.com}
set mailForwardingPort 25
##
## Uncomment the following lines after the "##+" up to the "##-" to turn
## off messages, comment them out to turn messages on
##
##+
#::log::lvSuppress debug
#::log::lvSuppress notice
##-
##
## validateHost - Checks to see if a host is legal
##
## Arguments:
## ipnum - IP address of sender
##
proc validateHost {ipnum} {
global allowedHostIPList
##
## Loop through the patterns and check for a match
##
foreach allowedIP $allowedHostIPList {
if {[string equal $allowedIP $ipnum]} then {
::log::log debug [::msgcat::mc ip.granted $ipnum]
return;
}
}
##
## No matches, so we throw an error to deny access
##
::log::log debug [::msgcat::mc ip.denied $ipnum]
return -code error deny
return
}
##
## validateSender - Checks to see if a sender if legeal
##
## Arguments:
## address - sender's e-mail address
##
proc validateSender {address} {
global allowedUserPatternList
##
## Loop through the patterns and check for a match
##
foreach allowedPattern $allowedUserPatternList {
if {[string match $allowedPattern $address]} then {
::log::log debug [::msgcat::mc sender.granted $address]
return;
}
}
##
## No matches, so we throw an error to deny access
##
::log::log debug [::msgcat::mc sender.denied $address]
return -code error deny
}
##
## processMail - Procedure that processes a mail message
##
## Arguments:
## args - accept any arguments
##
proc processMail {sender recipients data} {
global mailForwardingHost
global mailForwardingPort
global LastData
##
## Send the mail
##
::log::log debug [::msgcat::mc process.sending $data]
set LastData $data
set token [mime::initialize -string [join $data "\n"]]
set results [smtp::sendmessage $token \
-servers $mailForwardingHost \
-ports $mailForwardingPort \
-queue 0 \
-atleastone 1 \
-originator $sender \
-recipients [lsort -unique $recipients] \
]
mime::finalize $token -subordinates all
if {[llength $results]} then {
::log::log debug [::msgcat::mc process.failure $results]
}
##
## Return to caller
##
return
}
##
## ok - Procedure that always returns a successful validation
##
## Arguments:
## args - accept any arguments
##
proc ok {args} {
return
}
##
## Main code body
##
##
## Initialize Message Catalog
##
set msgDir [file join [file dirname [info script]] msgs]
::msgcat::mcload $msgDir
##
## Setup to receive mail
##
::smtpd::configure \
-validate_host validateHost \
-validate_sender validateSender \
-validate_recipient ok \
-deliver processMail
##
## Kick off the whole thing
##
::log::log debug [::msgcat::mc starting]
::smtpd::startHere is the associated message file:
##
## Message file ClearQuest Smtp Deamon
##
::msgcat::mcset c ip.granted {Access granted to host "%s"}
::msgcat::mcset c ip.denied {Access denied to host "%s"}
::msgcat::mcset c sender.granted {Access granted to sender "%s"}
::msgcat::mcset c sender.denied {Access denied to sender "%s"}
::msgcat::mcset c process.original {Orginal recipients "%s"}
::msgcat::mcset c process.resultant {Resultant recipients "%s"}
::msgcat::mcset c process.sending {Sending "%s"}
::msgcat::mcset c process.failure {Message failed to be sent to {%s}}
::msgcat::mcset c starting {ClearQuest SMTP Deamon Started}Fakemail [2] is a maintained project for a small dummy SMTP daemon for testing.Hmm - fakemail is stinky perl - the tcllib smtpd package is also maintained and is beautiful tcl :) 'Anyone motivated enough to determine whether there's any functionality smtpd can learn from fakemail?
SMTPD Example
Category Package, subset Tcllib