Index: modules/mime/pkgIndex.tcl ================================================================== --- modules/mime/pkgIndex.tcl +++ modules/mime/pkgIndex.tcl @@ -1,4 +1,4 @@ if {![package vsatisfies [package provide Tcl] 8.3]} {return} -package ifneeded smtp 1.4.5 [list source [file join $dir smtp.tcl]] +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]] Index: modules/mime/smtp.man ================================================================== --- modules/mime/smtp.man +++ modules/mime/smtp.man @@ -1,7 +1,8 @@ +[vset VERSION 1.5] [comment {-*- tcl -*- doctools manpage}] -[manpage_begin smtp n 1.4.5] +[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}] @@ -8,11 +9,11 @@ [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 1.4.5]] +[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). @@ -71,10 +72,19 @@ [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 Index: modules/mime/smtp.tcl ================================================================== --- modules/mime/smtp.tcl +++ modules/mime/smtp.tcl @@ -99,10 +99,12 @@ # 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 @@ -127,10 +129,11 @@ 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 "" @@ -152,10 +155,11 @@ -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" } @@ -419,11 +423,11 @@ # server. set token [initialize -debug $debugP -client $client \ -maxsecs $maxsecs -usetls $tlsP \ -multiple $bccP -queue $queueP \ -servers $servers -ports $ports \ - -tlspolicy $tlspolicy \ + -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 @@ -593,10 +597,12 @@ # 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 @@ -614,10 +620,11 @@ 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 @@ -640,10 +647,14 @@ 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 @@ -683,10 +694,12 @@ 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 } @@ -742,11 +755,11 @@ # 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]} { + 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 {} @@ -758,12 +771,12 @@ 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 + # 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)] \ @@ -1498,11 +1511,11 @@ } } # ------------------------------------------------------------------------- -package provide smtp 1.4.5 +package provide smtp 1.5 # ------------------------------------------------------------------------- # Local variables: # indent-tabs-mode: nil # End: