Tcl Library Source Code

# support the SCGI module
###

package require uri
package require dns
package require cron
package require coroutine
package require mime 1.6
package require fileutil
package require websocket
package require Markdown
package require fileutil::magic::filetype
package require clay 0.7

namespace eval httpd::content {}

# support the SCGI module
###

package require uri
package require dns
package require cron
package require coroutine
package require -exact mime 1.6
package require fileutil
package require websocket
package require Markdown
package require fileutil::magic::filetype
package require clay 0.7

namespace eval httpd::content {}

# Copyright (c) 2003-2006 Pat Thoyts
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require Tcl 8.3
package require mime 1.4.1

catch {
    package require SASL 1.0;           # tcllib 1.8
    package require SASL::NTLM 1.0;     # tcllib 1.8
}

#
................................................................................
#	Sends a mime object (containing a message) to some recipients
#
# Arguments:
#	part  The MIME object containing the message to send
#       args  A list of arguments specifying various options for sending the
#             message:
#             -atleastone  A boolean specifying whether or not to send the
#                          message at all if any of the recipients are 
#                          invalid.  A value of false (as defined by 
#                          ::smtp::boolean) means that ALL recipients must be
#                          valid in order to send the message.  A value of
#                          true means that as long as at least one recipient
#                          is valid, the message will be sent.
#             -debug       A boolean specifying whether or not debugging is
#                          on.  If debugging is enabled, status messages are 
#                          printed to stderr while trying to send mail.
#             -queue       A boolean specifying whether or not the message
#                          being sent should be queued for later delivery.
#             -header      A single RFC 822 header key and value (as a list),
#                          used to specify to whom to send the message 
#                          (To, Cc, Bcc), the "From", etc.
#             -originator  The originator of the message (equivalent to
#                          specifying a From header).
#             -recipients  A string containing recipient e-mail addresses.
#                          NOTE: This option overrides any recipient addresses
#                          specified with -header.
#             -servers     A list of mail servers that could process the
................................................................................
    set tlsP 1
    set tlspolicy {}
    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
    # of the list.
    set lowerL ""
    set mixedL ""

    # Parse options (args).

    if {[expr {[llength $args]%2}]} {
        # Some option didn't get a value.
        error "Each option must have a value!  Invalid option list: $args"
    }
    
    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}
................................................................................
                if {[lsearch -exact $disallowedHdrList $lower] > -1} {
                    error "Content-Type, Content-Transfer-Encoding,\
                        Content-MD5, and MIME-Version cannot be user-specified."
                }
                if {[lsearch -exact $lowerL $lower] < 0} {
                    lappend lowerL $lower
                    lappend mixedL $mixed
                }               

                lappend header($lower) [lindex $value 1]
            }

            -originator {
                set originator $value
                if {$originator == ""} {
................................................................................

    if {$origP} {
        # -originator was specified with "", so SMTP sender should be marked "".
        set sender ""
    } else {
        # -originator was specified with a value, OR -originator wasn't
        # specified at all.
        
        # If no -originator was provided, get the originator from the "From"
        # header.  If there was no "From" header get it from the username
        # executing the script.

        set who "-originator"
        if {$originator == ""} {
            if {![info exists header($fromL)]} {
................................................................................
                set originator [join $header($fromL) ,]

                # Indicate that we're using the From header for the originator.

                set who $fromM
            }
        }
        
	# If there's no "From" header, create a From header with the value
	# of -originator as the value.

        if {[lsearch -exact $lowerL $fromL] < 0} {
            lappend lowerL $fromL
            lappend mixedL $fromM
            lappend header($fromL) $originator
................................................................................
        set inner [::mime::initialize -canonical message/rfc822 \
                                    -header [list Content-Description \
                                                  "Original Message"] \
                                    -parts [list $part]]

        set subject "\[$bccM\]"
        if {[info exists header(subject)]} {
            append subject " " [lindex $header(subject) 0] 
        }

        set outer [::mime::initialize \
                         -canonical multipart/digest \
                         -header [list From $originator] \
                         -header [list Bcc ""] \
                         -header [list Date \
................................................................................

        catch { ::mime::finalize $inner -subordinates none }
        catch { ::mime::finalize $outer -subordinates none }
    }

    # Determine if there was any error in prior operations and set errorcodes
    # and error messages appropriately.
    
    switch -- $code {
        0 {
            set status orderly
        }

        7 {
            set code 1
................................................................................

        default {
            set status abort
        }
    }

    # Destroy SMTP token 'cause we're done with it.
    
    catch { finalize $token -close $status }

    # Restore provided MIME object to original state (without the SMTP headers).
    
    foreach key [::mime::getheader $part -names] {
        mime::setheader $part $key "" -mode delete
    }
    foreach {key values} $savedH {
        foreach value $values {
            ::mime::setheader $part $key $value -mode append
        }
................................................................................
#
#	Create an SMTP token and open a connection to the SMTP server.
#
# Arguments:
#       args  A list of arguments specifying various options for sending the
#             message:
#             -debug       A boolean specifying whether or not debugging is
#                          on.  If debugging is enabled, status messages are 
#                          printed to stderr while trying to send mail.
#             -client      Either localhost or the name of the local host.
#             -multiple    Multiple messages will be sent using this token.
#             -queue       A boolean specifying whether or not the message
#                          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.
#             -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.

proc ::smtp::initialize {args} {
................................................................................
                            -ports 25 -usetls 1 -tlspolicy {} \
                            -username {} -password {}]
    array set options $args
    set state(options) [array get options]

    # Iterate through servers until one accepts a connection (and responds
    # nicely).
   
    set index 0 
    foreach server $options(-servers) {
	set state(readable) 0
        if {[llength $options(-ports)] >= $index} {
            set port [lindex $options(-ports) $index]
        } else {
            set port 25
        }
................................................................................
}

proc ::smtp::initialize_ehlo {token} {
    global errorCode errorInfo
    upvar einfo einfo
    upvar ecode ecode
    upvar code  code
    
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)

    # Try enhanced SMTP first.

................................................................................
            array set response [list code 400 diagnostic $result args ""]
        } else {
            array set response $result
        }
        set ecode $errorCode
        set einfo $errorInfo
    }
    
    if {$response(code) == 250} {
        # Successful response to HELO or EHLO command, so set up queuing
        # and whatnot and return the token.
        
        set state(esmtp) $response(args)

        if {(!$options(-multiple)) \
                && ([lsearch $response(args) ONEX] >= 0)} {
            catch {smtp::talk $token 300 ONEX}
        }
        if {($options(-queue)) \
                && ([lsearch $response(args) XQUE] >= 0)} {
            catch {smtp::talk $token 300 QUED}
        }
        
        # 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]} {
                set state(tls) 0
................................................................................
                    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
................................................................................
                            return {}
                        }
                    }
                }
            }
        }

        # If we have not already tried and the server supports it and we 
        # have a username -- lets try to authenticate.
        #
        if {![info exists state(auth)]
            && [llength [package provide SASL]] != 0
            && [set andx [lsearch -glob $response(args) "AUTH*"]] >= 0 
            && [string length $options(-username)] > 0 } {
            
            # May be AUTH mech or AUTH=mech
            # We want to use the strongest mechanism that has been offered
            # and that we support. If we cannot find a mechanism that 
            # succeeds, we will go ahead and try to carry on unauthenticated.
            # This may still work else we'll get an unauthorised error later.

            set mechs [string range [lindex $response(args) $andx] 5 end]
            foreach mech [SASL::mechanisms] {
                if {[lsearch -exact $mechs $mech] == -1} { continue }
                if {[catch {
................................................................................
                }
                if {[info exists state(auth)] && $state(auth)} {
                    if {$state(auth) == 1} {
                        break
                    } else {
                        # After successful AUTH we are supposed to redo
                        # our connection for mechanisms that setup a new
                        # security layer -- these should set state(auth) 
                        # greater than 1
                        fileevent $state(sd) readable \
                            [list ::smtp::readable $token]
                        return [initialize_ehlo $token]
                    }
                }
            }
        }
        
        return $token
    } else {
        # Bad response; close the connection and hope the next server
        # is happier.
        catch {close $state(sd)}
    }
    return {}
................................................................................
    upvar #0 $context ctx
    array set options $state(options)
    switch -exact -- $command {
        login    { return "" }
        username { return $options(-username) }
        password { return $options(-password) }
        hostname { return [info host] }
        realm    { 
            if {[string equal $ctx(mech) "NTLM"] \
                    && [info exists ::env(USERDOMAIN)]} {
                return $::env(USERDOMAIN)
            } else {
                return ""
            }
        }
        default  { 
            return -code error "error: unsupported SASL information requested"
        }
    }
}

proc ::smtp::Authenticate {token mechanism} {
    upvar 0 $token state
................................................................................
            set challenge $response(diagnostic)
        }
        SASL::step $ctx $challenge
        set result [smtp::talk $token 300 \
                        [base64::encode -maxlen 0 [SASL::response $ctx]]]
        array set response $result
    }
    
    if {$response(code) == 235} {
        set state(auth) 1
        return $result
    } else {
        return -code 7 $result
    }
}
................................................................................
    if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} {
        error "unknown origination mode $mode"
    }

    set from "$mode FROM:<$originator>"

    # RFC 1870 -  SMTP Service Extension for Message Size Declaration
    if {[info exists state(esmtp)] 
        && [lsearch -glob $state(esmtp) "SIZE*"] != -1} {
        catch {
            set size [string length [mime::buildmessage $part]]
            append from " SIZE=$size"
        }
    }

................................................................................
    }
}

# ::smtp::waddr --
#
#	Send recipient info to SMTP server.  This occurs after originator info
#       is sent (in ::smtp::winit).  This function is called by
#       ::smtp::sendmessageaux. 
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#       recipient   One of the recipients to whom the message should be
#                   delivered.  
#
# Results:
#	Recipient info is sent and SMTP server's response is returned.  If an
#       error occurs, throw an exception.

proc ::smtp::waddr {token recipient} {
    # FRINK: nocheck
................................................................................
    }
}

# ::smtp::wtext --
#
#	Send message to SMTP server.  This occurs after recipient info
#       is sent (in ::smtp::winit).  This function is called by
#       ::smtp::sendmessageaux. 
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	part        The MIME object containing the message to send.
#
# Results:
#	MIME message is sent and SMTP server's response is returned.  If an
................................................................................
                [string trim [string range $state(line) 4 end]]
        } else {
            lappend response(args) \
                    [string trim [string range $state(line) 4 end]]
        }

        # When status message line ends in -, it means the message is complete.
        
        if {[string compare [string index $state(line) 3] -]} {
            break
        }
    }

    return [array get response]
}

# Copyright (c) 2003-2006 Pat Thoyts
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require Tcl 8.3
package require -exact mime 1.6

catch {
    package require SASL 1.0;           # tcllib 1.8
    package require SASL::NTLM 1.0;     # tcllib 1.8
}

#
................................................................................
#	Sends a mime object (containing a message) to some recipients
#
# Arguments:
#	part  The MIME object containing the message to send
#       args  A list of arguments specifying various options for sending the
#             message:
#             -atleastone  A boolean specifying whether or not to send the
#                          message at all if any of the recipients are
#                          invalid.  A value of false (as defined by
#                          ::smtp::boolean) means that ALL recipients must be
#                          valid in order to send the message.  A value of
#                          true means that as long as at least one recipient
#                          is valid, the message will be sent.
#             -debug       A boolean specifying whether or not debugging is
#                          on.  If debugging is enabled, status messages are
#                          printed to stderr while trying to send mail.
#             -queue       A boolean specifying whether or not the message
#                          being sent should be queued for later delivery.
#             -header      A single RFC 822 header key and value (as a list),
#                          used to specify to whom to send the message
#                          (To, Cc, Bcc), the "From", etc.
#             -originator  The originator of the message (equivalent to
#                          specifying a From header).
#             -recipients  A string containing recipient e-mail addresses.
#                          NOTE: This option overrides any recipient addresses
#                          specified with -header.
#             -servers     A list of mail servers that could process the
................................................................................
    set tlsP 1
    set tlspolicy {}
    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
    # of the list.
    set lowerL ""
    set mixedL ""

    # Parse options (args).

    if {[expr {[llength $args]%2}]} {
        # Some option didn't get a value.
        error "Each option must have a value!  Invalid option list: $args"
    }

    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}
................................................................................
                if {[lsearch -exact $disallowedHdrList $lower] > -1} {
                    error "Content-Type, Content-Transfer-Encoding,\
                        Content-MD5, and MIME-Version cannot be user-specified."
                }
                if {[lsearch -exact $lowerL $lower] < 0} {
                    lappend lowerL $lower
                    lappend mixedL $mixed
                }

                lappend header($lower) [lindex $value 1]
            }

            -originator {
                set originator $value
                if {$originator == ""} {
................................................................................

    if {$origP} {
        # -originator was specified with "", so SMTP sender should be marked "".
        set sender ""
    } else {
        # -originator was specified with a value, OR -originator wasn't
        # specified at all.

        # If no -originator was provided, get the originator from the "From"
        # header.  If there was no "From" header get it from the username
        # executing the script.

        set who "-originator"
        if {$originator == ""} {
            if {![info exists header($fromL)]} {
................................................................................
                set originator [join $header($fromL) ,]

                # Indicate that we're using the From header for the originator.

                set who $fromM
            }
        }

	# If there's no "From" header, create a From header with the value
	# of -originator as the value.

        if {[lsearch -exact $lowerL $fromL] < 0} {
            lappend lowerL $fromL
            lappend mixedL $fromM
            lappend header($fromL) $originator
................................................................................
        set inner [::mime::initialize -canonical message/rfc822 \
                                    -header [list Content-Description \
                                                  "Original Message"] \
                                    -parts [list $part]]

        set subject "\[$bccM\]"
        if {[info exists header(subject)]} {
            append subject " " [lindex $header(subject) 0]
        }

        set outer [::mime::initialize \
                         -canonical multipart/digest \
                         -header [list From $originator] \
                         -header [list Bcc ""] \
                         -header [list Date \
................................................................................

        catch { ::mime::finalize $inner -subordinates none }
        catch { ::mime::finalize $outer -subordinates none }
    }

    # Determine if there was any error in prior operations and set errorcodes
    # and error messages appropriately.

    switch -- $code {
        0 {
            set status orderly
        }

        7 {
            set code 1
................................................................................

        default {
            set status abort
        }
    }

    # Destroy SMTP token 'cause we're done with it.

    catch { finalize $token -close $status }

    # Restore provided MIME object to original state (without the SMTP headers).

    foreach key [::mime::getheader $part -names] {
        mime::setheader $part $key "" -mode delete
    }
    foreach {key values} $savedH {
        foreach value $values {
            ::mime::setheader $part $key $value -mode append
        }
................................................................................
#
#	Create an SMTP token and open a connection to the SMTP server.
#
# Arguments:
#       args  A list of arguments specifying various options for sending the
#             message:
#             -debug       A boolean specifying whether or not debugging is
#                          on.  If debugging is enabled, status messages are
#                          printed to stderr while trying to send mail.
#             -client      Either localhost or the name of the local host.
#             -multiple    Multiple messages will be sent using this token.
#             -queue       A boolean specifying whether or not the message
#                          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.
#             -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.

proc ::smtp::initialize {args} {
................................................................................
                            -ports 25 -usetls 1 -tlspolicy {} \
                            -username {} -password {}]
    array set options $args
    set state(options) [array get options]

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

    set index 0
    foreach server $options(-servers) {
	set state(readable) 0
        if {[llength $options(-ports)] >= $index} {
            set port [lindex $options(-ports) $index]
        } else {
            set port 25
        }
................................................................................
}

proc ::smtp::initialize_ehlo {token} {
    global errorCode errorInfo
    upvar einfo einfo
    upvar ecode ecode
    upvar code  code

    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)

    # Try enhanced SMTP first.

................................................................................
            array set response [list code 400 diagnostic $result args ""]
        } else {
            array set response $result
        }
        set ecode $errorCode
        set einfo $errorInfo
    }

    if {$response(code) == 250} {
        # Successful response to HELO or EHLO command, so set up queuing
        # and whatnot and return the token.

        set state(esmtp) $response(args)

        if {(!$options(-multiple)) \
                && ([lsearch $response(args) ONEX] >= 0)} {
            catch {smtp::talk $token 300 ONEX}
        }
        if {($options(-queue)) \
                && ([lsearch $response(args) XQUE] >= 0)} {
            catch {smtp::talk $token 300 QUED}
        }

        # 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]} {
                set state(tls) 0
................................................................................
                    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
................................................................................
                            return {}
                        }
                    }
                }
            }
        }

        # If we have not already tried and the server supports it and we
        # have a username -- lets try to authenticate.
        #
        if {![info exists state(auth)]
            && [llength [package provide SASL]] != 0
            && [set andx [lsearch -glob $response(args) "AUTH*"]] >= 0
            && [string length $options(-username)] > 0 } {

            # May be AUTH mech or AUTH=mech
            # We want to use the strongest mechanism that has been offered
            # and that we support. If we cannot find a mechanism that
            # succeeds, we will go ahead and try to carry on unauthenticated.
            # This may still work else we'll get an unauthorised error later.

            set mechs [string range [lindex $response(args) $andx] 5 end]
            foreach mech [SASL::mechanisms] {
                if {[lsearch -exact $mechs $mech] == -1} { continue }
                if {[catch {
................................................................................
                }
                if {[info exists state(auth)] && $state(auth)} {
                    if {$state(auth) == 1} {
                        break
                    } else {
                        # After successful AUTH we are supposed to redo
                        # our connection for mechanisms that setup a new
                        # security layer -- these should set state(auth)
                        # greater than 1
                        fileevent $state(sd) readable \
                            [list ::smtp::readable $token]
                        return [initialize_ehlo $token]
                    }
                }
            }
        }

        return $token
    } else {
        # Bad response; close the connection and hope the next server
        # is happier.
        catch {close $state(sd)}
    }
    return {}
................................................................................
    upvar #0 $context ctx
    array set options $state(options)
    switch -exact -- $command {
        login    { return "" }
        username { return $options(-username) }
        password { return $options(-password) }
        hostname { return [info host] }
        realm    {
            if {[string equal $ctx(mech) "NTLM"] \
                    && [info exists ::env(USERDOMAIN)]} {
                return $::env(USERDOMAIN)
            } else {
                return ""
            }
        }
        default  {
            return -code error "error: unsupported SASL information requested"
        }
    }
}

proc ::smtp::Authenticate {token mechanism} {
    upvar 0 $token state
................................................................................
            set challenge $response(diagnostic)
        }
        SASL::step $ctx $challenge
        set result [smtp::talk $token 300 \
                        [base64::encode -maxlen 0 [SASL::response $ctx]]]
        array set response $result
    }

    if {$response(code) == 235} {
        set state(auth) 1
        return $result
    } else {
        return -code 7 $result
    }
}
................................................................................
    if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} {
        error "unknown origination mode $mode"
    }

    set from "$mode FROM:<$originator>"

    # RFC 1870 -  SMTP Service Extension for Message Size Declaration
    if {[info exists state(esmtp)]
        && [lsearch -glob $state(esmtp) "SIZE*"] != -1} {
        catch {
            set size [string length [mime::buildmessage $part]]
            append from " SIZE=$size"
        }
    }

................................................................................
    }
}

# ::smtp::waddr --
#
#	Send recipient info to SMTP server.  This occurs after originator info
#       is sent (in ::smtp::winit).  This function is called by
#       ::smtp::sendmessageaux.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#       recipient   One of the recipients to whom the message should be
#                   delivered.
#
# Results:
#	Recipient info is sent and SMTP server's response is returned.  If an
#       error occurs, throw an exception.

proc ::smtp::waddr {token recipient} {
    # FRINK: nocheck
................................................................................
    }
}

# ::smtp::wtext --
#
#	Send message to SMTP server.  This occurs after recipient info
#       is sent (in ::smtp::winit).  This function is called by
#       ::smtp::sendmessageaux.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	part        The MIME object containing the message to send.
#
# Results:
#	MIME message is sent and SMTP server's response is returned.  If an
................................................................................
                [string trim [string range $state(line) 4 end]]
        } else {
            lappend response(args) \
                    [string trim [string range $state(line) 4 end]]
        }

        # When status message line ends in -, it means the message is complete.

        if {[string compare [string index $state(line) 3] -]} {
            break
        }
    }

    return [array get response]
}

# smtp.tcl - SMTP client
#
# Copyright (c) 1999-2000 Marshall T. Rose
# Copyright (c) 2003-2006 Pat Thoyts

#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require Tcl 8.3
package require mime 1.4.1

catch {
    package require SASL 1.0;           # tcllib 1.8
    package require SASL::NTLM 1.0;     # tcllib 1.8
}

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


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

proc ::smtp::sendmessage {part args} {
    global errorCode errorInfo

    # Here are the meanings of the following boolean variables:
    # aloP -- value of -atleastone option above.
    # debugP -- value of -debug option above.
    # origP -- 1 if -originator option was specified, 0 otherwise.
    # queueP -- value of -queue option above.

    set aloP 0
................................................................................
    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 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}

	    -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]
................................................................................
                lappend header($senderL) $aprops(address)
            }
        }
    }

    # We're done parsing the arguments.

    if {$recipients != ""} {
        set who -recipients
    } elseif {![info exists header($toL)]} {
        error "need -header \"$toM ...\""
    } else {
        set recipients [join $header($toL) ,]
	# Add Cc values to recipients list
	set who $toM
................................................................................
        lappend vrecipients $aprops(address)
    }

    # If there's no date header, get the date from the mime message.  Same for
    # the message-id.

    if {([lsearch -exact $lowerL $dateL] < 0) \
            && ([catch { ::mime::getheader $part $dateL }])} {
        lappend lowerL $dateL
        lappend mixedL $dateM
        lappend header($dateL) [::mime::parsedatetime -now proper]
    }

    if {([lsearch -exact $lowerL ${message-idL}] < 0) \
            && ([catch { ::mime::getheader $part ${message-idL} }])} {
        lappend lowerL ${message-idL}
        lappend mixedL ${message-idM}
        lappend header(${message-idL}) [::mime::uniqueID]

    }

    # Get all the headers from the MIME object and save them so that they can
    # later be restored.
    set savedH [::mime::getheader $part]

    # Take all the headers defined earlier and add them to the MIME message.
    foreach lower $lowerL mixed $mixedL {
        foreach value $header($lower) {
            ::mime::setheader $part $mixed $value -mode append
        }
    }

    if {[string length $client] < 1} {
        if {![string compare $servers localhost]} {
            set client localhost
        } else {
................................................................................

    # 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 \
                                -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)
    }

    set code [catch { sendmessageaux $token $part \
                                           $sender $vrecipients $aloP } \
                    result]
    set ecode $errorCode
    set einfo $errorInfo


    # Send the message to bcc recipients as a MIME attachment.

    if {($code == 0) && ($bccP)} {
        set inner [::mime::initialize -canonical message/rfc822 \
                                    -header [list Content-Description \
                                                  "Original Message"] \
                                    -parts [list $part]]

        set subject "\[$bccM\]"
        if {[info exists header(subject)]} {
            append subject " " [lindex $header(subject) 0] 
        }

        set outer [::mime::initialize \
                         -canonical multipart/digest \
                         -header [list From $originator] \
                         -header [list Bcc ""] \
                         -header [list Date \


                                       [::mime::parsedatetime -now proper]] \
                         -header [list Subject $subject] \
                         -header [list Message-ID [::mime::uniqueID]] \
                         -header [list Content-Description \
                                       "Blind Carbon Copy"] \
                         -parts [list $inner]]



        set code [catch { sendmessageaux $token $outer \
                                               $sender $brecipients \
                                               $aloP } result2]
        set ecode $errorCode
        set einfo $errorInfo


        if {$code == 0} {
            set result [concat $result $result2]
        } else {
            set result $result2

        }

        catch { ::mime::finalize $inner -subordinates none }
        catch { ::mime::finalize $outer -subordinates none }
    }

    # Determine if there was any error in prior operations and set errorcodes
    # and error messages appropriately.
    


    switch -- $code {
        0 {
            set status orderly
        }

        7 {
            set code 1
            array set response $result
            set result "$response(code): $response(diagnostic)"
            set status abort

        }

        default {
            set status abort

        }
    }

    # Destroy SMTP token 'cause we're done with it.
    
    catch { finalize $token -close $status }







    # Restore provided MIME object to original state (without the SMTP headers).
    
    foreach key [::mime::getheader $part -names] {

        mime::setheader $part $key "" -mode delete
    }
    foreach {key values} $savedH {
        foreach value $values {
            ::mime::setheader $part $key $value -mode append
        }
    }

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

}

# ::smtp::sendmessageaux --
#
#	Sends a mime object (containing a message) to some recipients using an
#       existing SMTP token.
#
................................................................................
#                          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.


#             -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 {} \

                            -username {} -password {}]
    array set options $args
    set state(options) [array get options]

    # Iterate through servers until one accepts a connection (and responds
    # nicely).
   
    set index 0 
    foreach server $options(-servers) {


	set state(readable) 0
        if {[llength $options(-ports)] >= $index} {
            set port [lindex $options(-ports) $index]
        } else {
            set port 25
        }
        if {$options(-debug)} {
            puts stderr "Trying $server..."
            flush stderr
        }

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

        if {[set code [catch {
            set state(sd) [socket -async $server $port]




            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) }
................................................................................
            }
        }

        set r [initialize_ehlo $token]
        if {$r != {}} {
            return $r
        }
        incr index
    }

    # None of the servers accepted our connection, so close everything up and
    # 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


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]} {
                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)
................................................................................
                            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
................................................................................
#
# Results:
#	SMTP connection is closed and state variables are cleared.  If there's
#       an error while attempting to close the connection to the SMTP server,
#       throw an exception with the error code and error message.

proc ::smtp::finalize {token args} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options [list -close orderly]
    array set options $args


    switch -- $options(-close) {
        orderly {
            set code [catch { talk $token 120 QUIT } result]
        }

        abort {
            set code [catch {
                talk $token 0 RSET
                talk $token 0 QUIT
            } result]
        }

        drop {
            set code 0
            set result ""
        }

        default {
            error "unknown value for -close $options(-close)"
        }
    }
    set ecode $errorCode
    set einfo $errorInfo


    catch { close $state(sd) }

    if {$state(afterID) != ""} {
        catch { after cancel $state(afterID) }
    }

    foreach name [array names state] {
        unset state($name)
    }
    # FRINK: nocheck
    unset $token

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

# ::smtp::winit --
#
#	Send originator info to SMTP server.  This occurs after HELO/EHLO
#       command has completed successfully (in ::smtp::initialize).  This function
#       is called by ::smtp::sendmessageaux.
................................................................................

    set from "$mode FROM:<$originator>"

    # RFC 1870 -  SMTP Service Extension for Message Size Declaration
    if {[info exists state(esmtp)] 
        && [lsearch -glob $state(esmtp) "SIZE*"] != -1} {
        catch {
            set size [string length [mime::buildmessage $part]]
            append from " SIZE=$size"
        }
    }

    array set response [set result [talk $token 600 $from]]

    if {$response(code) == 250} {
................................................................................
    # replace all '.'s that start their own line with '..'s, and
    # then write the mime body out to the filehandle. Do not forget to
    # deal with bare LF's here too (SF bug #499242).

    if {$trf} {
        set code [catch { ::mime::copymessage $part $state(sd) } result]
    } else {
        set code [catch { ::mime::buildmessage $part } result]
        if {$code == 0} {
	    # Detect and transform bare LF's into proper CR/LF
	    # sequences.

	    while {[regsub -all -- {([^\r])\n} $result "\\1\r\n" result]} {}
            regsub -all -- {\n\.}      $result "\n.."   result

................................................................................
    array set options $state(options)

    if {$options(-debug)} {
        puts stderr "--> $command (wait upto $secs seconds)"
        flush stderr
    }


    if {[catch { puts -nonewline $state(sd) "$command\r\n"
                 flush $state(sd) } result]} {

        return [list code 400 diagnostic $result]
    }

    if {$secs == 0} {
        return ""
    }

................................................................................
proc ::smtp::hear {token secs} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options $state(options)

    array set response [list args ""]

    set firstP 1
    while {1} {
        if {$secs >= 0} {
	    ## SF [ 836442 ] timeout with large data
	    ## correction, aotto 031105 -
	    if {$secs > 600} {set secs 600}
            set state(afterID) [after [expr {$secs*1000}] \
                                      [list ::smtp::timer $token]]
        }
................................................................................
            error "unknown boolean value: $value"
        }
    }
}

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

package provide smtp 1.4.5

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

# smtp.tcl - SMTP client
#
# Copyright (c) 1999-2000 Marshall T. Rose
# Copyright (c) 2003-2006 Pat Thoyts
# Copyright (c) 2003-2018 Poor Yorick 
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require Tcl 8.3
package require mime 1.7-

catch {
    package require SASL 1.0;           # tcllib 1.8
    package require SASL::NTLM 1.0;     # tcllib 1.8
}

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

proc ::smtp::sendmessage {part args} {


    # Here are the meanings of the following boolean variables:
    # aloP -- value of -atleastone option above.
    # debugP -- value of -debug option above.
    # origP -- 1 if -originator option was specified, 0 otherwise.
    # queueP -- value of -queue option above.

    set aloP 0
................................................................................
    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]
................................................................................
                lappend header($senderL) $aprops(address)
            }
        }
    }

    # We're done parsing the arguments.

    if {$recipients ne {}} {
        set who -recipients
    } elseif {![info exists header($toL)]} {
        error "need -header \"$toM ...\""
    } else {
        set recipients [join $header($toL) ,]
	# Add Cc values to recipients list
	set who $toM
................................................................................
        lappend vrecipients $aprops(address)
    }

    # If there's no date header, get the date from the mime message.  Same for
    # the message-id.

    if {([lsearch -exact $lowerL $dateL] < 0) \
            && ([catch {$part header get $dateL}])} {
        lappend lowerL $dateL
        lappend mixedL $dateM
        lappend header($dateL) [::mime::datetime -now proper]
    }

    if {([lsearch -exact $lowerL ${message-idL}] < 0) \
            && ([catch {$part header get ${message-idL}}])} {
        lappend lowerL ${message-idL}
        lappend mixedL ${message-idM}
        lappend header(${message-idL}) [::mime::uniqueID]

    }

    # Get all the headers from the MIME object and save them so that they can
    # later be restored.
    set savedH [$part header get]

    # Take all the headers defined earlier and add them to the MIME message.
    foreach lower $lowerL mixed $mixedL {
        foreach value $header($lower) {
            $part header set $mixed $value -mode append
        }
    }

    if {[string length $client] < 1} {
        if {![string compare $servers localhost]} {
            set client localhost
        } else {
................................................................................

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

    set code1 [catch {
	sendmessageaux $token $part $sender $vrecipients $aloP
    } cres1 copts1]
    lappend results $code1 $cres1 $copts1


    if {!$code1 && $bccP} {
	# Send the message to bcc recipients as a MIME attachment.


        set inner [::mime::.new {} -canonical message/rfc822 \
                                    -headers [list Content-Description \
                                                  {Original Message}] \
                                    -parts [list $part]]

        set subject "\[$bccM\]"
        if {[info exists header(subject)]} {
            append subject " " [lindex $header(subject) 0] 
        }

        set outer [::mime::.new {} \
	    -canonical multipart/digest \


	    -headers [list \
		From [list $originator {}] \
		Bcc 
		Date [::mime::datetime -now proper] \
		Subject $subject \
		Message-ID [::mime::uniqueID] \

		Content-Description {Blind Carbon Copy} \
	     -parts [list $inner]]]


        set code2 [catch {
	    sendmessageaux $token $outer $sender $brecipients $aloP




	} cres2 copts2]





	lappend results $code2 $cres2 $copts2


        catch {$inner .destroy -subordinates none}
        catch {$outer .destroy -subordinates none}
    }

    # Determine if there was any error in prior operations and set errorcodes
    # and error messages appropriately.

    foreach {code cres copts} $results {
	# handle just the first one
	switch -- $code {
	    0 {
		set status orderly
	    }

	    7 {
		dict set copts -code 1


		set status abort
		break
	    }

	    default {
		set status abort
		break
	    }
	}
    }


    set code3 [catch {finalize $token -close $status} cres3 copts3]

    if {$code3 && !$code} {
	lassign [list $cres3 $copts3] cres copts
    }

    # Destroy SMTP token 'cause we're done with it.
   
    # Restore provided MIME object to original state (without the SMTP headers).
   

    foreach {key val} [$part header get] {
        $part header set $key "" -mode delete
    }
    foreach {key value} $savedH {

	$part header set $key {*}$value -mode append
    }



    return -options $copts $cres
}

# ::smtp::sendmessageaux --
#
#	Sends a mime object (containing a message) to some recipients using an
#       existing SMTP token.
#
................................................................................
#                          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).
   

    foreach server $options(-servers) port $options(-ports) {
        if {$server == ""} continue

	set state(readable) 0



        if {$port == ""} { set port 25 }
        
        if {$options(-debug)} {
            puts stderr "Trying $server..."
            flush stderr
        }

        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) }
................................................................................
            }
        }

        set r [initialize_ehlo $token]
        if {$r != {}} {
            return $r
        }

    }

    # None of the servers accepted our connection, so close everything up and
    # 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)
................................................................................
                            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
................................................................................
#
# Results:
#	SMTP connection is closed and state variables are cleared.  If there's
#       an error while attempting to close the connection to the SMTP server,
#       throw an exception with the error code and error message.

proc ::smtp::finalize {token args} {

    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options [list -close orderly]
    array set options $args

    try {
	switch -- $options(-close) {
	    orderly {
		set code [catch { talk $token 120 QUIT } result]
	    }

	    abort {
		set code [catch {
		    talk $token 0 RSET
		    talk $token 0 QUIT
		} result]
	    }

	    drop {
		set code 0
		set result ""
	    }

	    default {
		error "unknown value for -close $options(-close)"
	    }
	}
    } finally {
	if {$state(sd) in [chan names]} {
	    close $state(sd)
	}


	if {$state(afterID) ne {}} {
	    after cancel $state(afterID)
	}

	foreach name [array names state] {
	    unset state($name)
	}
	# FRINK: nocheck
	unset $token
    }

}

# ::smtp::winit --
#
#	Send originator info to SMTP server.  This occurs after HELO/EHLO
#       command has completed successfully (in ::smtp::initialize).  This function
#       is called by ::smtp::sendmessageaux.
................................................................................

    set from "$mode FROM:<$originator>"

    # RFC 1870 -  SMTP Service Extension for Message Size Declaration
    if {[info exists state(esmtp)] 
        && [lsearch -glob $state(esmtp) "SIZE*"] != -1} {
        catch {
            set size [string length [$part serialize]]
            append from " SIZE=$size"
        }
    }

    array set response [set result [talk $token 600 $from]]

    if {$response(code) == 250} {
................................................................................
    # replace all '.'s that start their own line with '..'s, and
    # then write the mime body out to the filehandle. Do not forget to
    # deal with bare LF's here too (SF bug #499242).

    if {$trf} {
        set code [catch { ::mime::copymessage $part $state(sd) } result]
    } else {
        set code [catch {$part serialize} result]
        if {$code == 0} {
	    # Detect and transform bare LF's into proper CR/LF
	    # sequences.

	    while {[regsub -all -- {([^\r])\n} $result "\\1\r\n" result]} {}
            regsub -all -- {\n\.}      $result "\n.."   result

................................................................................
    array set options $state(options)

    if {$options(-debug)} {
        puts stderr "--> $command (wait upto $secs seconds)"
        flush stderr
    }

    if {[catch {
	puts -nonewline $state(sd) $command\r\n
	flush $state(sd) } result]
    } {
        return [list code 400 diagnostic $result]
    }

    if {$secs == 0} {
        return ""
    }

................................................................................
proc ::smtp::hear {token secs} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options $state(options)

    array set response [list args {}]

    set firstP 1
    while 1 {
        if {$secs >= 0} {
	    ## SF [ 836442 ] timeout with large data
	    ## correction, aotto 031105 -
	    if {$secs > 600} {set secs 600}
            set state(afterID) [after [expr {$secs*1000}] \
                                      [list ::smtp::timer $token]]
        }
................................................................................
            error "unknown boolean value: $value"
        }
    }
}

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

package provide smtp 1.5

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

# Copyright (c) 2002-2009 by Andreas Kupries
# Copyright (c) 2005      by Reinhard Max (-socket option)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require md5  ; # tcllib | APOP
package require mime 1.6; # tcllib | storage callback
package require log  ; # tcllib | tracing

package provide pop3d 1.1.0

namespace eval ::pop3d {
    # Data storage in the pop3d module
    # -------------------------------

# Copyright (c) 2002-2009 by Andreas Kupries
# Copyright (c) 2005      by Reinhard Max (-socket option)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require md5  ; # tcllib | APOP
package require -exact mime 1.6; # tcllib | storage callback
package require log  ; # tcllib | tracing

package provide pop3d 1.1.0

namespace eval ::pop3d {
    # Data storage in the pop3d module
    # -------------------------------

#	body of the mail.
#
# Copyright (c) 2002 by Andreas Kupries
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require mime 1.6; # tcllib | mime token is result of "get".
package require log  ; # tcllib | Logging package

namespace eval ::pop3d::dbox {
    # Data storage in the pop3d::dbox module
    # -------------------------------------
    # One array per object containing the db contents. Keyed by user name.
    # And the information about the last file data was read from.

#	body of the mail.
#
# Copyright (c) 2002 by Andreas Kupries
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require -exact mime 1.6; # tcllib | mime token is result of "get".
package require log  ; # tcllib | Logging package

namespace eval ::pop3d::dbox {
    # Data storage in the pop3d::dbox module
    # -------------------------------------
    # One array per object containing the db contents. Keyed by user name.
    # And the information about the last file data was read from.

# or FITNESS FOR A PARTICULAR PURPOSE.  See the file 'license.terms' for
# more details.
# -------------------------------------------------------------------------
# @mdgen EXCLUDE: clients/mail-test.tcl

package require Tcl 8.3;                # tcl minimum version
package require logger;                 # tcllib 1.3
package require mime 1.6;                   # tcllib

package provide smtpd 1.5

namespace eval ::smtpd {
    variable version [package present smtpd]
    variable stopped

# or FITNESS FOR A PARTICULAR PURPOSE.  See the file 'license.terms' for
# more details.
# -------------------------------------------------------------------------
# @mdgen EXCLUDE: clients/mail-test.tcl

package require Tcl 8.3;                # tcl minimum version
package require logger;                 # tcllib 1.3
package require -exact mime 1.6;                   # tcllib

package provide smtpd 1.5

namespace eval ::smtpd {
    variable version [package present smtpd]
    variable stopped