#! /bin/sh
 #
 # tk_smtpd - Copyright (C) 2001 Pat Thoyts <[email protected]>
 #
 # 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::start