Tcl Library Source Code

if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded smtp 1.5 [list source [file join $dir smtp.tcl]]
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded mime 1.6 [list source [file join $dir mime.tcl]]

[vset VERSION 1.5]
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin smtp n [vset VERSION]]
[see_also ftp]
[see_also http]
[see_also mime]
[see_also pop3]
[copyright {1999-2000 Marshall T. Rose and others}]
[moddesc   {smtp client}]
[titledesc {Client-side tcl implementation of the smtp protocol}]
[category  Networking]
[require Tcl]
[require mime [opt 1.5.4]]
[require smtp [opt [vset VERSION]]]
[description]
[para]

The [package smtp] library package provides the client side of the
Simple Mail Transfer Protocol (SMTP) (1) (2).

[list_begin definitions]

value (the -header option may occur zero or more times).

[def [option -usetls]]

This package supports the RFC 3207 TLS extension (3) by default provided the
tls package is available. You can turn this off with this boolean option.

[def [option -tlsimport]]

This boolean flag is [const false] by default.

When this flag is set the package will import TLS on a sucessfully
opened channel. This is needed for connections using native TLS
negotiation instead of [const STARTTLS]. The [package tls] package
is automatically required when needed.

[def [option -tlspolicy]]

This option lets you specify a command to be called if an error occurs
during TLS setup. The command is called with the SMTP code and diagnostic
message appended. The command should return 'secure' or 'insecure' where
insecure will cause the package to continue on the unencrypted channel.
Returning 'secure' will cause the socket to be closed and the next server

#                          is 120 seconds.
#             -usetls      A boolean flag. If the server supports it and we
#                          have the package, use TLS to secure the connection.
#             -tlspolicy   A command to call if the TLS negotiation fails for
#                          some reason. Return 'insecure' to continue with
#                          normal SMTP or 'secure' to close the connection and
#                          try another server.
#             -tlsimport   after a succesfull socket command, import tls on
#                          channel - used for native smtps negotiation
#             -username    These are needed if your SMTP server requires
#             -password    authentication.
#
# Results:
#	Message is sent.  On success, return "".  On failure, throw an
#       exception with an error code and error message.

    set originator ""
    set recipients ""
    set servers [list localhost]
    set client "" ;# default is set after options processing
    set ports [list 25]
    set tlsP 1
    set tlspolicy {}
    set tlsimport 0
    set username {}
    set password {}

    array set header ""

    # lowerL will contain the list of header keys (converted to lower case) 
    # specified with various -header options.  mixedL is the mixed-case version

    foreach {option value} $args {
        switch -- $option {
            -atleastone {set aloP   [boolean $value]}
            -debug      {set debugP [boolean $value]}
            -queue      {set queueP [boolean $value]}
            -usetls     {set tlsP   [boolean $value]}
            -tlspolicy  {set tlspolicy $value}
            -tlsimport  {set tlsimport [boolean $value]}
	    -maxsecs    {set maxsecs [expr {$value < 0 ? 0 : $value}]}
            -header {
                if {[llength $value] != 2} {
                    error "-header expects a key and a value, not $value"
                }
                set mixed [lindex $value 0]
                set lower [string tolower $mixed]

    # Create smtp token, which essentially means begin talking to the SMTP
    # server.
    set token [initialize -debug $debugP -client $client \
		                -maxsecs $maxsecs -usetls $tlsP \
                                -multiple $bccP -queue $queueP \
                                -servers $servers -ports $ports \
                                -tlspolicy $tlspolicy -tlsimport $tlsimport \
                                -username $username -password $password]

    if {![string match "::smtp::*" $token]} {
	# An error occurred and $token contains the error info
	array set respArr $token
	return -code error $respArr(diagnostic)
    }

#                          being sent should be queued for later delivery.
#             -servers     A list of mail servers that could process the
#                          request.
#             -ports       A list of ports on mail servers that could process
#                          the request (one port per server-- defaults to 25).
#             -usetls      A boolean to indicate we will use TLS if possible.
#             -tlspolicy   Command called if TLS setup fails.
#             -tlsimport   after a succesfull socket command, import tls on
#                          channel - used for native smtps negotiation
#             -username    These provide the authentication information 
#             -password    to be used if needed by the SMTP server.
#
# Results:
#	On success, return an smtp token.  On failure, throw
#       an exception with an error code and error message.

    variable $token
    upvar 0 $token state

    array set state [list afterID "" options "" readable 0]
    array set options [list -debug 0 -client localhost -multiple 1 \
                            -maxsecs 120 -queue 0 -servers localhost \
                            -ports 25 -usetls 1 -tlspolicy {} \
                            -tlsimport 0 \
                            -username {} -password {}]
    array set options $args
    set state(options) [array get options]

    # Iterate through servers until one accepts a connection (and responds
    # nicely).
   

        if {[info exists state(sd)]} {
            unset state(sd)
        }

        if {[set code [catch {
            set state(sd) [socket -async $server $port]
            if { $options(-tlsimport) } {
                package require tls
                tls::import $state(sd)
            }
            fconfigure $state(sd) -blocking off -translation binary
            fileevent $state(sd) readable [list ::smtp::readable $token]
        } result]]} {
            set ecode $errorCode
            set einfo $errorInfo

            catch { close $state(sd) }

    # return an error.
    finalize $token -close drop

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# If we cannot load the tls package, ignore the error
# Result value is a Tcl return code, not a bool.
# 0 == OK
proc ::smtp::load_tls {} {
    set r [catch {package require tls}]
    if {$r} {set ::errorInfo ""}
    return $r
}

proc ::smtp::initialize_ehlo {token} {

        }
        
        # Support STARTTLS extension.
        # The state(tls) item is used to see if we have already tried this.
        if {($options(-usetls)) && ![info exists state(tls)] \
                && (([lsearch $response(args) STARTTLS] >= 0)
                    || ([lsearch $response(args) TLS] >= 0))} {
            if {[load_tls] == 0} {
                set state(tls) 0
                if {![catch {smtp::talk $token 300 STARTTLS} resp]} {
                    array set starttls $resp
                    if {$starttls(code) == 220} {
                        fileevent $state(sd) readable {}
                        catch {
                            ::tls::import $state(sd)
                            catch {::tls::handshake $state(sd)} msg
                            set state(tls) 1
                        } 
                        fileevent $state(sd) readable \
                            [list ::smtp::readable $token]
                        return [initialize_ehlo $token]
                    } else {
                        # Call a TLS client policy proc here
                        #  returns secure   - close and try another server.
                        #  returns insecure - continue on current socket
                        set policy insecure
                        if {$options(-tlspolicy) != {}} {
                            catch {
                                eval $options(-tlspolicy) \
                                    [list $starttls(code)] \
                                    [list $starttls(diagnostic)]
                            } policy

            error "unknown boolean value: $value"
        }
    }
}

# -------------------------------------------------------------------------

package provide smtp 1.5

# -------------------------------------------------------------------------
# Local variables:
# indent-tabs-mode: nil
# End: