#! /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:

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

----

Here 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}