home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 5 / hacker05 / 05_HACK_05.ISO / programacao / freewrap / TCLLIBsampleApp.exe / sample / tcllib / tcllib1.0 / mime / smtp.tcl < prev   
Encoding:
Text File  |  2001-08-17  |  36.8 KB  |  1,246 lines

  1. # smtp.tcl - SMTP client
  2. #
  3. # (c) 1999-2000 Marshall T. Rose
  4. #
  5. # See the file "license.terms" for information on usage and redistribution
  6. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  7. #
  8.  
  9. package require Tcl 8.3
  10. package require mime 1.0
  11. package provide smtp 1.2
  12.  
  13. if {[catch {package require Trf  2.0}]} {
  14.     # Trf is not available, but we can live without it as long as the
  15.     # unstack and transform procs are defined.
  16.  
  17.     # Create these commands in the smtp namespace so that they
  18.     # won't collide with things at the global namespace level
  19.  
  20.     namespace eval smtp {
  21.         proc transform {args} {
  22.          upvar state mystate
  23.         set mystate(size) 1
  24.         }
  25.         proc unstack {channel} {
  26.             # do nothing
  27.             return
  28.         }
  29.     }
  30. }
  31.  
  32. #
  33. # state variables:
  34. #
  35. #    sd: socket to server
  36. #    afterID: afterID associated with smtp::timer
  37. #    options: array of user-supplied options
  38. #    readable: semaphore for vwait
  39. #    addrs: number of recipients negotiated
  40. #    error: error during read
  41. #    line: response read from server
  42. #    crP: just put a \r in the data
  43. #    nlP: just put a \n in the data
  44. #    size: number of octets sent in DATA
  45. #
  46.  
  47.  
  48. namespace eval smtp {
  49.     variable trf 1
  50.     variable smtp
  51.     array set smtp { uid 0 }
  52.  
  53.     namespace export sendmessage
  54. }
  55.  
  56. if {[catch {package require Trf  2.0}]} {
  57.     # Trf is not available, but we can live without it as long as the
  58.     # transform proc is defined.
  59.  
  60.     # Warning!
  61.     # This is a fragile emulation of the more general calling sequence
  62.     # that appears to work with this code here.
  63.  
  64.     proc transform {args} {
  65.     upvar state mystate
  66.     set mystate(size) 1
  67.     }
  68.     set ::smtp::trf 0
  69. }
  70.  
  71.  
  72. # smtp::sendmessage --
  73. #
  74. #    Sends a mime object (containing a message) to some recipients
  75. #
  76. # Arguments:
  77. #    part  The MIME object containing the message to send
  78. #       args  A list of arguments specifying various options for sending the
  79. #             message:
  80. #             -atleastone  A boolean specifying whether or not to send the
  81. #                          message at all if any of the recipients are 
  82. #                          invalid.  A value of false (as defined by 
  83. #                          smtp::boolean) means that ALL recipients must be
  84. #                          valid in order to send the message.  A value of
  85. #                          true means that as long as at least one recipient
  86. #                          is valid, the message will be sent.
  87. #             -debug       A boolean specifying whether or not debugging is
  88. #                          on.  If debugging is enabled, status messages are 
  89. #                          printed to stderr while trying to send mail.
  90. #             -queue       A boolean specifying whether or not the message
  91. #                          being sent should be queued for later delivery.
  92. #             -header      A single RFC 822 header key and value (as a list),
  93. #                          used to specify to whom to send the message 
  94. #                          (To, Cc, Bcc), the "From", etc.
  95. #             -originator  The originator of the message (equivalent to
  96. #                          specifying a From header).
  97. #             -recipients  A string containing recipient e-mail addresses.
  98. #                          NOTE: This option overrides any recipient addresses
  99. #                          specified with -header.
  100. #             -servers     A list of mail servers that could process the
  101. #                          request.
  102. #             -ports       A list of SMTP ports to use for each SMTP server
  103. #                          specified
  104. #
  105. # Results:
  106. #    Message is sent.  On success, return "".  On failure, throw an
  107. #       exception with an error code and error message.
  108.  
  109. proc smtp::sendmessage {part args} {
  110.     global errorCode errorInfo
  111.  
  112.     # Here are the meanings of the following boolean variables:
  113.     # aloP -- value of -atleastone option above.
  114.     # debugP -- value of -debug option above.
  115.     # origP -- 1 if -originator option was specified, 0 otherwise.
  116.     # queueP -- value of -queue option above.
  117.  
  118.     set aloP 0
  119.     set debugP 0
  120.     set origP 0
  121.     set queueP 0
  122.     set originator ""
  123.     set recipients ""
  124.     set servers [list localhost]
  125.     set ports [list 25]
  126.  
  127.     array set header ""
  128.  
  129.     # lowerL will contain the list of header keys (converted to lower case) 
  130.     # specified with various -header options.  mixedL is the mixed-case version
  131.     # of the list.
  132.     set lowerL ""
  133.     set mixedL ""
  134.  
  135.     # Parse options (args).
  136.  
  137.     if {[expr {[llength $args]%2}]} {
  138.         # Some option didn't get a value.
  139.         error "Each option must have a value!  Invalid option list: $args"
  140.     }
  141.     
  142.     foreach {option value} $args {
  143.         switch -- $option {
  144.             -atleastone {set aloP   [smtp::boolean $value]}
  145.             -debug      {set debugP [smtp::boolean $value]}
  146.             -queue      {set queueP [smtp::boolean $value]}
  147.             -header {
  148.                 if {[llength $value] != 2} {
  149.                     error "-header expects a key and a value, not $value"
  150.                 }
  151.                 set mixed [lindex $value 0]
  152.                 set lower [string tolower $mixed]
  153.                 set disallowedHdrList \
  154.                     [list content-type \
  155.                           content-transfer-encoding \
  156.                           content-md5 \
  157.                           mime-version]
  158.                 if {[lsearch -exact $disallowedHdrList $lower] > -1} {
  159.                     error "Content-Type, Content-Transfer-Encoding,\
  160.                         Content-MD5, and MIME-Version cannot be user-specified."
  161.                 }
  162.                 if {[lsearch -exact $lowerL $lower] < 0} {
  163.                     lappend lowerL $lower
  164.                     lappend mixedL $mixed
  165.                 }               
  166.  
  167.                 lappend header($lower) [lindex $value 1]
  168.             }
  169.  
  170.             -originator {
  171.                 set originator $value
  172.                 if {$originator == ""} {
  173.                     set origP 1
  174.                 }
  175.             }
  176.  
  177.             -recipients {
  178.                 set recipients $value
  179.             }
  180.  
  181.             -servers {
  182.                 set servers $value
  183.             }
  184.  
  185.             -ports {
  186.                 set ports $value
  187.             }
  188.  
  189.             default {
  190.                 error "unknown option $option"
  191.             }
  192.         }
  193.     }
  194.  
  195.     if {[lsearch -glob $lowerL resent-*] >= 0} {
  196.         set prefixL resent-
  197.         set prefixM Resent-
  198.     } else {
  199.         set prefixL ""
  200.         set prefixM ""
  201.     }
  202.  
  203.     # Set a bunch of variables whose value will be the real header to be used
  204.     # in the outbound message (with proper case and prefix).
  205.  
  206.     foreach mixed {From Sender To cc Dcc Bcc Date Message-ID} {
  207.         set lower [string tolower $mixed]
  208.     # FRINK: nocheck
  209.         set ${lower}L $prefixL$lower
  210.     # FRINK: nocheck
  211.         set ${lower}M $prefixM$mixed
  212.     }
  213.  
  214.     if {$origP} {
  215.         # -originator was specified with "", so SMTP sender should be marked "".
  216.         set sender ""
  217.     } else {
  218.         # -originator was specified with a value, OR -originator wasn't
  219.         # specified at all.
  220.         
  221.         # If no -originator was provided, get the originator from the "From"
  222.         # header.  If there was no "From" header get it from the username
  223.         # executing the script.
  224.  
  225.         set who "-originator"
  226.         if {$originator == ""} {
  227.             if {![info exists header($fromL)]} {
  228.                 set originator $::tcl_platform(user)
  229.             } else {
  230.                 set originator [join $header($fromL) ,]
  231.  
  232.                 # Indicate that we're using the From header for the originator.
  233.  
  234.                 set who $fromM
  235.             }
  236.         }
  237.         
  238.     # If there's no "From" header, create a From header with the value
  239.     # of -originator as the value.
  240.  
  241.         if {[lsearch -exact $lowerL $fromL] < 0} {
  242.             lappend lowerL $fromL
  243.             lappend mixedL $fromM
  244.             lappend header($fromL) $originator
  245.         }
  246.  
  247.     # mime::parseaddress returns a list whose elements are huge key-value
  248.     # lists with info about the addresses.  In this case, we only want one
  249.     # originator, so we want the length of the main list to be 1.
  250.  
  251.         set addrs [mime::parseaddress $originator]
  252.         if {[llength $addrs] > 1} {
  253.             error "too many mailboxes in $who: $originator"
  254.         }
  255.         array set aprops [lindex $addrs 0]
  256.         if {$aprops(error) != ""} {
  257.             error "error in $who: $aprops(error)"
  258.         }
  259.  
  260.     # sender = validated originator or the value of the From header.
  261.  
  262.         set sender $aprops(address)
  263.  
  264.     # If no Sender header has been specified and From is different from
  265.     # originator, then set the sender header to the From.  Otherwise, don't
  266.     # specify a Sender header.
  267.         set from [join $header($fromL) ,]
  268.         if {[lsearch -exact $lowerL $senderL] < 0 && \
  269.                 [string compare $originator $from]} {
  270.             if {[info exists aprops]} {
  271.                 unset aprops
  272.             }
  273.             array set aprops [lindex [mime::parseaddress $from] 0]
  274.             if {$aprops(error) != ""} {
  275.                 error "error in $fromM: $aprops(error)"
  276.             }
  277.             if {[string compare $aprops(address) $sender]} {
  278.                 lappend lowerL $senderL
  279.                 lappend mixedL $senderM
  280.                 lappend header($senderL) $aprops(address)
  281.             }
  282.         }
  283.     }
  284.  
  285.     # We're done parsing the arguments.
  286.  
  287.     if {$recipients != ""} {
  288.         set who -recipients
  289.     } elseif {![info exists header($toL)]} {
  290.         error "need -header \"$toM ...\""
  291.     } else {
  292.         set recipients [join $header($toL) ,]
  293.     # Add Cc values to recipients list
  294.     set who $toM
  295.         if {[info exists header($ccL)]} {
  296.             append recipients ,[join $header($ccL) ,]
  297.             append who /$ccM
  298.         }
  299.  
  300.         set dccInd [lsearch -exact $lowerL $dccL]
  301.         if {$dccInd >= 0} {
  302.         # Add Dcc values to recipients list, and get rid of Dcc header
  303.         # since we don't want to output that.
  304.             append recipients ,[join $header($dccL) ,]
  305.             append who /$dccM
  306.  
  307.             unset header($dccL)
  308.             set lowerL [lreplace $lowerL $dccInd $dccInd]
  309.             set mixedL [lreplace $mixedL $dccInd $dccInd]
  310.         }
  311.     }
  312.  
  313.     set brecipients ""
  314.     set bccInd [lsearch -exact $lowerL $bccL]
  315.     if {$bccInd >= 0} {
  316.         set bccP 1
  317.  
  318.     # Build valid bcc list and remove bcc element of header array (so that
  319.     # bcc info won't be sent with mail).
  320.         foreach addr [mime::parseaddress [join $header($bccL) ,]] {
  321.             if {[info exists aprops]} {
  322.                 unset aprops
  323.             }
  324.             array set aprops $addr
  325.             if {$aprops(error) != ""} {
  326.                 error "error in $bccM: $aprops(error)"
  327.             }
  328.             lappend brecipients $aprops(address)
  329.         }
  330.  
  331.         unset header($bccL)
  332.         set lowerL [lreplace $lowerL $bccInd $bccInd]
  333.         set mixedL [lreplace $mixedL $bccInd $bccInd]
  334.     } else {
  335.         set bccP 0
  336.     }
  337.  
  338.     # If there are no To headers, add "" to bcc list.  WHY??
  339.     if {[lsearch -exact $lowerL $toL] < 0} {
  340.         lappend lowerL $bccL
  341.         lappend mixedL $bccM
  342.         lappend header($bccL) ""
  343.     }
  344.  
  345.     # Construct valid recipients list from recipients list.
  346.  
  347.     set vrecipients ""
  348.     foreach addr [mime::parseaddress $recipients] {
  349.         if {[info exists aprops]} {
  350.             unset aprops
  351.         }
  352.         array set aprops $addr
  353.         if {$aprops(error) != ""} {
  354.             error "error in $who: $aprops(error)"
  355.         }
  356.         lappend vrecipients $aprops(address)
  357.     }
  358.  
  359.     # If there's no date header, get the date from the mime message.  Same for
  360.     # the message-id.
  361.  
  362.     if {([lsearch -exact $lowerL $dateL] < 0) \
  363.             && ([catch { mime::getheader $part $dateL }])} {
  364.         lappend lowerL $dateL
  365.         lappend mixedL $dateM
  366.         lappend header($dateL) [mime::parsedatetime -now proper]
  367.     }
  368.  
  369.     if {([lsearch -exact $lowerL ${message-idL}] < 0) \
  370.             && ([catch { mime::getheader $part ${message-idL} }])} {
  371.         lappend lowerL ${message-idL}
  372.         lappend mixedL ${message-idM}
  373.         lappend header(${message-idL}) [mime::uniqueID]
  374.  
  375.     }
  376.  
  377.     # Get all the headers from the MIME object and save them so that they can
  378.     # later be restored.
  379.     set savedH [mime::getheader $part]
  380.  
  381.     # Take all the headers defined earlier and add them to the MIME message.
  382.     foreach lower $lowerL mixed $mixedL {
  383.         foreach value $header($lower) {
  384.             mime::setheader $part $mixed $value -mode append
  385.         }
  386.     }
  387.  
  388.     if {![string compare $servers localhost]} {
  389.         set client localhost
  390.     } else {
  391.         set client [info hostname]
  392.     }
  393.  
  394.     # Create smtp token, which essentially means begin talking to the SMTP
  395.     # server.
  396.     set token [smtp::initialize -debug $debugP -client $client \
  397.                                 -multiple $bccP -queue $queueP \
  398.                                 -servers $servers -ports $ports]
  399.  
  400.     if {![string match "::smtp::*" $token]} {
  401.     # An error occurred and $token contains the error info
  402.     array set respArr $token
  403.     return -code error $respArr(diagnostic)
  404.     }
  405.  
  406.     set code [catch { smtp::sendmessageaux $token $part \
  407.                                            $sender $vrecipients $aloP } \
  408.                     result]
  409.     set ecode $errorCode
  410.     set einfo $errorInfo
  411.  
  412.     # Send the message to bcc recipients as a MIME attachment.
  413.  
  414.     if {($code == 0) && ($bccP)} {
  415.         set inner [mime::initialize -canonical message/rfc822 \
  416.                                     -header [list Content-Description \
  417.                                                   "Original Message"] \
  418.                                     -parts [list $part]]
  419.  
  420.         set subject "\[$bccM\]"
  421.         if {[info exists header(subject)]} {
  422.             append subject " " [lindex $header(subject) 0] 
  423.         }
  424.  
  425.         set outer [mime::initialize \
  426.                          -canonical multipart/digest \
  427.                          -header [list From $originator] \
  428.                          -header [list Bcc ""] \
  429.                          -header [list Date \
  430.                                        [mime::parsedatetime -now proper]] \
  431.                          -header [list Subject $subject] \
  432.                          -header [list Message-ID [mime::uniqueID]] \
  433.                          -header [list Content-Description \
  434.                                        "Blind Carbon Copy"] \
  435.                          -parts [list $inner]]
  436.  
  437.  
  438.         set code [catch { smtp::sendmessageaux $token $outer \
  439.                                                $sender $brecipients \
  440.                                                $aloP } result2]
  441.         set ecode $errorCode
  442.         set einfo $errorInfo
  443.  
  444.         if {$code == 0} {
  445.             set result [concat $result $result2]
  446.         } else {
  447.             set result $result2
  448.         }
  449.  
  450.         catch { mime::finalize $inner -subordinates none }
  451.         catch { mime::finalize $outer -subordinates none }
  452.     }
  453.  
  454.     # Determine if there was any error in prior operations and set errorcodes
  455.     # and error messages appropriately.
  456.     
  457.     switch -- $code {
  458.         0 {
  459.             set status orderly
  460.         }
  461.  
  462.         7 {
  463.             set code 1
  464.             array set response $result
  465.             set result "$response(code): $response(diagnostic)"
  466.             set status abort
  467.         }
  468.  
  469.         default {
  470.             set status abort
  471.         }
  472.     }
  473.  
  474.     # Destroy SMTP token 'cause we're done with it.
  475.     
  476.     catch { smtp::finalize $token -close $status }
  477.  
  478.     # Restore provided MIME object to original state (without the SMTP headers).
  479.     
  480.     foreach key [mime::getheader $part -names] {
  481.         mime::setheader $part $key "" -mode delete
  482.     }
  483.     foreach {key values} $savedH {
  484.         foreach value $values {
  485.             mime::setheader $part $key $value -mode append
  486.         }
  487.     }
  488.  
  489.     return -code $code -errorinfo $einfo -errorcode $ecode $result
  490. }
  491.  
  492. # smtp::sendmessageaux --
  493. #
  494. #    Sends a mime object (containing a message) to some recipients using an
  495. #       existing SMTP token.
  496. #
  497. # Arguments:
  498. #       token       SMTP token that has an open connection to the SMTP server.
  499. #    part        The MIME object containing the message to send.
  500. #       originator  The e-mail address of the entity sending the message,
  501. #                   usually the From clause.
  502. #       recipients  List of e-mail addresses to whom message will be sent.
  503. #       aloP        Boolean "atleastone" setting; see the -atleastone option
  504. #                   in smtp::sendmessage for details.
  505. #
  506. # Results:
  507. #    Message is sent.  On success, return "".  On failure, throw an
  508. #       exception with an error code and error message.
  509.  
  510. proc smtp::sendmessageaux {token part originator recipients aloP} {
  511.     global errorCode errorInfo
  512.  
  513.     smtp::winit $token $originator
  514.  
  515.     set goodP 0
  516.     set badP 0
  517.     set oops ""
  518.     foreach recipient $recipients {
  519.         set code [catch { smtp::waddr $token $recipient } result]
  520.         set ecode $errorCode
  521.         set einfo $errorInfo
  522.  
  523.         switch -- $code {
  524.             0 {
  525.                 incr goodP
  526.             }
  527.  
  528.             7 {
  529.                 incr badP
  530.  
  531.                 array set response $result
  532.                 lappend oops [list $recipient $response(code) \
  533.                                    $response(diagnostic)]
  534.             }
  535.  
  536.             default {
  537.                 return -code $code -errorinfo $einfo -errorcode $ecode $result
  538.             }
  539.         }
  540.     }
  541.  
  542.     if {($goodP) && ((!$badP) || ($aloP))} {
  543.         smtp::wtext $token $part
  544.     } else {
  545.         catch { smtp::talk $token 300 RSET }
  546.     }
  547.  
  548.     return $oops
  549. }
  550.  
  551. # smtp::initialize --
  552. #
  553. #    Create an SMTP token and open a connection to the SMTP server.
  554. #
  555. # Arguments:
  556. #       args  A list of arguments specifying various options for sending the
  557. #             message:
  558. #             -debug       A boolean specifying whether or not debugging is
  559. #                          on.  If debugging is enabled, status messages are 
  560. #                          printed to stderr while trying to send mail.
  561. #             -client      Either localhost or the name of the local host.
  562. #             -multiple    Multiple messages will be sent using this token.
  563. #             -queue       A boolean specifying whether or not the message
  564. #                          being sent should be queued for later delivery.
  565. #             -servers     A list of mail servers that could process the
  566. #                          request.
  567. #             -ports       A list of ports on mail servers that could process
  568. #                          the request (one port per server-- defaults to 25).
  569. #
  570. # Results:
  571. #    On success, return an smtp token.  On failure, throw
  572. #       an exception with an error code and error message.
  573.  
  574. proc smtp::initialize {args} {
  575.     global errorCode errorInfo
  576.  
  577.     variable smtp
  578.  
  579.     set token [namespace current]::[incr smtp(uid)]
  580.     # FRINK: nocheck
  581.     variable $token
  582.     upvar 0 $token state
  583.  
  584.     array set state [list afterID "" options "" readable 0]
  585.     array set options [list -debug 0 -client localhost -multiple 1 \
  586.                             -queue 0 -servers localhost -ports 25]
  587.     array set options $args
  588.     set state(options) [array get options]
  589.  
  590.     # Iterate through servers until one accepts a connection (and responds
  591.     # nicely).
  592.    
  593.     set index 0 
  594.     foreach server $options(-servers) {
  595.         if {[llength $options(-ports)] >= $index} {
  596.             set port [lindex $options(-ports) $index]
  597.         } else {
  598.             set port 25
  599.         }
  600.         if {$options(-debug)} {
  601.             puts stderr "Trying $server..."
  602.             flush stderr
  603.         }
  604.  
  605.         if {[info exists state(sd)]} {
  606.             unset state(sd)
  607.         }
  608.  
  609.         if {[set code [catch {
  610.             set state(sd) [socket -async $server $port]
  611.             fconfigure $state(sd) -blocking off -translation binary
  612.             fileevent $state(sd) readable [list smtp::readable $token]
  613.         } result]]} {
  614.             set ecode $errorCode
  615.             set einfo $errorInfo
  616.  
  617.             catch { close $state(sd) }
  618.             continue
  619.         }
  620.  
  621.         if {[set code [catch { smtp::hear $token 600 } result]]} {
  622.             array set response [list code 400 diagnostic $result]
  623.         } else {
  624.             array set response $result
  625.         }
  626.         set ecode $errorCode
  627.         set einfo $errorInfo
  628.         switch -- $response(code) {
  629.             220 {
  630.             }
  631.  
  632.             421 - default {
  633.                 # 421 - Temporary problem on server
  634.                 catch {close $state(sd)}
  635.                 continue
  636.             }
  637.         }
  638.         
  639.         # Try enhanced SMTP first.
  640.         
  641.         if {[set code [catch {smtp::talk $token 300 "EHLO $options(-client)"} \
  642.                    result]]} {
  643.             array set response [list code 400 diagnostic $result args ""]
  644.         } else {
  645.             array set response $result
  646.         }
  647.         set ecode $errorCode
  648.         set einfo $errorInfo
  649.         if {(500 <= $response(code)) && ($response(code) <= 599)} {
  650.             if {[set code [catch { smtp::talk $token 300 \
  651.                                               "HELO $options(-client)" } \
  652.                        result]]} {
  653.                 array set response [list code 400 diagnostic $result \
  654.                                     args ""]
  655.             } else {
  656.                 array set response $result
  657.             }
  658.             set ecode $errorCode
  659.             set einfo $errorInfo
  660.         }
  661.         
  662.         if {$response(code) == 250} {
  663.             # Successful response to HELO or EHLO command, so set up queuing
  664.             # and whatnot and return the token.
  665.  
  666.             if {(!$options(-multiple)) \
  667.                     && ([lsearch $response(args) ONEX] >= 0)} {
  668.                 catch {smtp::talk $token 300 ONEX}
  669.             }
  670.             if {($options(-queue)) \
  671.                     && ([lsearch $response(args) XQUE] >= 0)} {
  672.                 catch {smtp::talk $token 300 QUED}
  673.             }
  674.  
  675.             return $token
  676.         } else {
  677.             # Bad response; close the connection and hope the next server
  678.             # is happier.
  679.             catch {close $state(sd)}
  680.         }
  681.         incr index
  682.     }
  683.  
  684.     # None of the servers accepted our connection, so close everything up and
  685.     # return an error.
  686.     smtp::finalize $token -close drop
  687.  
  688.     return -code $code -errorinfo $einfo -errorcode $ecode $result
  689. }
  690.  
  691. # smtp::finalize --
  692. #
  693. #    Deletes an SMTP token by closing the connection to the SMTP server,
  694. #       cleanup up various state.
  695. #
  696. # Arguments:
  697. #       token   SMTP token that has an open connection to the SMTP server.
  698. #       args    Optional arguments, where the only useful option is -close,
  699. #               whose valid values are the following:
  700. #               orderly     Normal successful completion.  Close connection and
  701. #                           clear state variables.
  702. #               abort       A connection exists to the SMTP server, but it's in
  703. #                           a weird state and needs to be reset before being
  704. #                           closed.  Then clear state variables.
  705. #               drop        No connection exists, so we just need to clean up
  706. #                           state variables.
  707. #
  708. # Results:
  709. #    SMTP connection is closed and state variables are cleared.  If there's
  710. #       an error while attempting to close the connection to the SMTP server,
  711. #       throw an exception with the error code and error message.
  712.  
  713. proc smtp::finalize {token args} {
  714.     global errorCode errorInfo
  715.     # FRINK: nocheck
  716.     variable $token
  717.     upvar 0 $token state
  718.  
  719.     array set options [list -close orderly]
  720.     array set options $args
  721.  
  722.     switch -- $options(-close) {
  723.         orderly {
  724.             set code [catch { smtp::talk $token 120 QUIT } result]
  725.         }
  726.  
  727.         abort {
  728.             set code [catch {
  729.                 smtp::talk $token 0 RSET
  730.                 smtp::talk $token 0 QUIT
  731.             } result]
  732.         }
  733.  
  734.         drop {
  735.             set code 0
  736.             set result ""
  737.         }
  738.  
  739.         default {
  740.             error "unknown value for -close $options(-close)"
  741.         }
  742.     }
  743.     set ecode $errorCode
  744.     set einfo $errorInfo
  745.  
  746.     catch { close $state(sd) }
  747.  
  748.     if {$state(afterID) != ""} {
  749.         catch { after cancel $state(afterID) }
  750.     }
  751.  
  752.     foreach name [array names state] {
  753.         unset state($name)
  754.     }
  755.     # FRINK: nocheck
  756.     unset $token
  757.  
  758.     return -code $code -errorinfo $einfo -errorcode $ecode $result
  759. }
  760.  
  761. # smtp::winit --
  762. #
  763. #    Send originator info to SMTP server.  This occurs after HELO/EHLO
  764. #       command has completed successfully (in smtp::initialize).  This function
  765. #       is called by smtp::sendmessageaux.
  766. #
  767. # Arguments:
  768. #       token       SMTP token that has an open connection to the SMTP server.
  769. #       originator  The e-mail address of the entity sending the message,
  770. #                   usually the From clause.
  771. #       mode        SMTP command specifying the mode of communication.  Default
  772. #                   value is MAIL.
  773. #
  774. # Results:
  775. #    Originator info is sent and SMTP server's response is returned.  If an
  776. #       error occurs, throw an exception.
  777.  
  778. proc smtp::winit {token originator {mode MAIL}} {
  779.     # FRINK: nocheck
  780.     variable $token
  781.     upvar 0 $token state
  782.  
  783.     if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} {
  784.         error "unknown origination mode $mode"
  785.     }
  786.  
  787.     array set response \
  788.           [set result [smtp::talk $token 600 \
  789.                                   "$mode FROM:<$originator>"]]
  790.     if {$response(code) == 250} {
  791.         set state(addrs) 0
  792.         return $result
  793.     } else {
  794.         return -code 7 $result
  795.     }
  796. }
  797.  
  798. # smtp::waddr --
  799. #
  800. #    Send recipient info to SMTP server.  This occurs after originator info
  801. #       is sent (in smtp::winit).  This function is called by
  802. #       smtp::sendmessageaux. 
  803. #
  804. # Arguments:
  805. #       token       SMTP token that has an open connection to the SMTP server.
  806. #       recipient   One of the recipients to whom the message should be
  807. #                   delivered.  
  808. #
  809. # Results:
  810. #    Recipient info is sent and SMTP server's response is returned.  If an
  811. #       error occurs, throw an exception.
  812.  
  813. proc smtp::waddr {token recipient} {
  814.     # FRINK: nocheck
  815.     variable $token
  816.     upvar 0 $token state
  817.  
  818.     set result [smtp::talk $token 3600 "RCPT TO:<$recipient>"]
  819.     array set response $result
  820.  
  821.     switch -- $response(code) {
  822.         250 - 251 {
  823.             incr state(addrs)
  824.             return $result
  825.         }
  826.  
  827.         default {
  828.             return -code 7 $result
  829.         }
  830.     }
  831. }
  832.  
  833. # smtp::wtext --
  834. #
  835. #    Send message to SMTP server.  This occurs after recipient info
  836. #       is sent (in smtp::winit).  This function is called by
  837. #       smtp::sendmessageaux. 
  838. #
  839. # Arguments:
  840. #       token       SMTP token that has an open connection to the SMTP server.
  841. #    part        The MIME object containing the message to send.
  842. #
  843. # Results:
  844. #    MIME message is sent and SMTP server's response is returned.  If an
  845. #       error occurs, throw an exception.
  846.  
  847. proc smtp::wtext {token part} {
  848.     # FRINK: nocheck
  849.     variable $token
  850.     upvar 0 $token state
  851.  
  852.     set result [smtp::talk $token 300 DATA]
  853.     array set response $result
  854.     if {$response(code) != 354} {
  855.         return -code 7 $result
  856.     }
  857.  
  858.     if {[catch { smtp::wtextaux $token $part } result]} {
  859.         catch { puts -nonewline $state(sd) "\r\n.\r\n" ; flush $state(sd) }
  860.         return -code 7 [list code 400 diagnostic $result]
  861.     }
  862.  
  863.     set secs [expr {(($state(size)>>10)+1)*3600}]
  864.  
  865.     set result [smtp::talk $token $secs .]
  866.     array set response $result
  867.     switch -- $response(code) {
  868.         250 - 251 {
  869.             return $result
  870.         }
  871.  
  872.         default {
  873.             return -code 7 $result
  874.         }
  875.     }
  876. }
  877.  
  878. # smtp::wtextaux --
  879. #
  880. #    Helper function that coordinates writing the MIME message to the socket.
  881. #       In particular, it stacks the channel leading to the SMTP server, sets up
  882. #       some file events, sends the message, unstacks the channel, resets the
  883. #       file events to their original state, and returns.
  884. #
  885. # Arguments:
  886. #       token       SMTP token that has an open connection to the SMTP server.
  887. #    part        The MIME object containing the message to send.
  888. #
  889. # Results:
  890. #    Message is sent.  If anything goes wrong, throw an exception.
  891.  
  892. proc smtp::wtextaux {token part} {
  893.     global errorCode errorInfo
  894.     variable trf
  895.     # FRINK: nocheck
  896.     variable $token
  897.     upvar 0 $token state
  898.  
  899.     flush $state(sd)
  900.     fileevent $state(sd) readable ""
  901.     transform -attach $state(sd) -command [list smtp::wdata $token]
  902.     fileevent $state(sd) readable [list smtp::readable $token]
  903.  
  904.     # If trf is not available, get the contents of the message,
  905.     # replace all '.'s that start their own line with '..'s, and
  906.     # then write the mime body out to the filehandle.
  907.  
  908.     if {$trf} {
  909.         set code [catch { mime::copymessage $part $state(sd) } result]
  910.     } else {
  911.         set code [catch { mime::buildmessage $part } result]
  912.         if {$code == 0} {
  913.             regsub -all -- {\n\.} $result "\n.." result
  914.             set state(size) [string length $result]
  915.             puts -nonewline $state(sd) $result
  916.             set result ""
  917.     }
  918.     }
  919.     set ecode $errorCode
  920.     set einfo $errorInfo
  921.  
  922.     flush $state(sd)
  923.     fileevent $state(sd) readable ""
  924.     unstack $state(sd)
  925.     fileevent $state(sd) readable [list smtp::readable $token]
  926.  
  927.     return -code $code -errorinfo $einfo -errorcode $ecode $result
  928. }
  929.  
  930. # smtp::wdata --
  931. #
  932. #    This is the custom transform using Trf to do CR/LF translation.  If Trf
  933. #       is not installed on the system, then this function never gets called and
  934. #       no translation occurs.
  935. #
  936. # Arguments:
  937. #       token       SMTP token that has an open connection to the SMTP server.
  938. #       command     Trf provided command for manipulating socket data.
  939. #    buffer      Data to be converted.
  940. #
  941. # Results:
  942. #    buffer is translated, and state(size) is set.  If Trf is not installed
  943. #       on the system, the transform proc defined at the top of this file sets
  944. #       state(size) to 1.  state(size) is used later to determine a timeout
  945. #       value.
  946.  
  947. proc smtp::wdata {token command buffer} {
  948.     # FRINK: nocheck
  949.     variable $token
  950.     upvar 0 $token state
  951.  
  952.     switch -- $command {
  953.         create/write
  954.             -
  955.         clear/write
  956.             -
  957.         delete/write {
  958.             set state(crP) 0
  959.             set state(nlP) 1
  960.             set state(size) 0
  961.         }
  962.  
  963.         write {
  964.             set result ""
  965.  
  966.             foreach c [split $buffer ""] {
  967.                 switch -- $c {
  968.                     "." {
  969.                         if {$state(nlP)} {
  970.                             append result .
  971.                         }
  972.                         set state(crP) 0
  973.                         set state(nlP) 0
  974.                     }
  975.  
  976.                     "\r" {
  977.                         set state(crP) 1
  978.                         set state(nlP) 0
  979.                     }
  980.  
  981.                     "\n" {
  982.                         if {!$state(crP)} {
  983.                             append result "\r"
  984.                         }
  985.                         set state(crP) 0
  986.                         set state(nlP) 1
  987.                     }
  988.  
  989.                     default {
  990.                         set state(crP) 0
  991.                         set state(nlP) 0
  992.                     }
  993.                 }
  994.  
  995.                 append result $c
  996.             }
  997.  
  998.             incr state(size) [string length $result]
  999.             return $result
  1000.         }
  1001.  
  1002.         flush/write {
  1003.             set result ""
  1004.  
  1005.             if {!$state(nlP)} {
  1006.                 if {!$state(crP)} {
  1007.                     append result "\r"
  1008.                 }
  1009.                 append result "\n"
  1010.             }
  1011.  
  1012.             incr state(size) [string length $result]
  1013.             return $result
  1014.         }
  1015.     default {
  1016.         error "Unknown command \"$command\""
  1017.     }
  1018.     }
  1019.  
  1020.     return ""
  1021. }
  1022.  
  1023. # smtp::talk --
  1024. #
  1025. #    Sends an SMTP command to a server
  1026. #
  1027. # Arguments:
  1028. #       token       SMTP token that has an open connection to the SMTP server.
  1029. #    secs        Timeout after which command should be aborted.
  1030. #       command     Command to send to SMTP server.
  1031. #
  1032. # Results:
  1033. #    command is sent and response is returned.  If anything goes wrong, throw
  1034. #       an exception.
  1035.  
  1036. proc smtp::talk {token secs command} {
  1037.     # FRINK: nocheck
  1038.     variable $token
  1039.     upvar 0 $token state
  1040.  
  1041.     array set options $state(options)
  1042.  
  1043.     if {$options(-debug)} {
  1044.         puts stderr "--> $command (wait upto $secs seconds)"
  1045.         flush stderr
  1046.     }
  1047.  
  1048.     if {[catch { puts -nonewline $state(sd) "$command\r\n"
  1049.                  flush $state(sd) } result]} {
  1050.         return [list code 400 diagnostic $result]
  1051.     }
  1052.  
  1053.     if {$secs == 0} {
  1054.         return ""
  1055.     }
  1056.  
  1057.     return [smtp::hear $token $secs]
  1058. }
  1059.  
  1060. # smtp::hear --
  1061. #
  1062. #    Listens for SMTP server's response to some prior command.
  1063. #
  1064. # Arguments:
  1065. #       token       SMTP token that has an open connection to the SMTP server.
  1066. #    secs        Timeout after which we should stop waiting for a response.
  1067. #
  1068. # Results:
  1069. #    Response is returned.
  1070.  
  1071. proc smtp::hear {token secs} {
  1072.     # FRINK: nocheck
  1073.     variable $token
  1074.     upvar 0 $token state
  1075.  
  1076.     array set options $state(options)
  1077.  
  1078.     array set response [list args ""]
  1079.  
  1080.     set firstP 1
  1081.     while {1} {
  1082.         if {$secs >= 0} {
  1083.             set state(afterID) [after [expr {$secs*1000}] \
  1084.                                       [list smtp::timer $token]]
  1085.         }
  1086.  
  1087.         if {!$state(readable)} {
  1088.             vwait $token
  1089.         }
  1090.  
  1091.         # Wait until socket is readable.
  1092.         if {$state(readable) !=  -1} {
  1093.             catch { after cancel $state(afterID) }
  1094.             set state(afterID) ""
  1095.         }
  1096.  
  1097.         if {$state(readable) < 0} {
  1098.             array set response [list code 400 diagnostic $state(error)]
  1099.             break
  1100.         }
  1101.         set state(readable) 0
  1102.  
  1103.         if {$options(-debug)} {
  1104.             puts stderr "<-- $state(line)"
  1105.             flush stderr
  1106.         }
  1107.  
  1108.         if {[string length $state(line)] < 3} {
  1109.             array set response \
  1110.                   [list code 500 \
  1111.                         diagnostic "response too short: $state(line)"]
  1112.             break
  1113.         }
  1114.  
  1115.         if {$firstP} {
  1116.             set firstP 0
  1117.  
  1118.             if {[scan [string range $state(line) 0 2] %d response(code)] \
  1119.                     != 1} {
  1120.                 array set response \
  1121.                       [list code 500 \
  1122.                             diagnostic "unrecognizable code: $state(line)"]
  1123.                 break
  1124.             }
  1125.  
  1126.             set response(diagnostic) \
  1127.                 [string trim [string range $state(line) 4 end]]
  1128.         } else {
  1129.             lappend response(args) \
  1130.                     [string trim [string range $state(line) 4 end]]
  1131.         }
  1132.  
  1133.         # When status message line ends in -, it means the message is complete.
  1134.         
  1135.         if {[string compare [string index $state(line) 3] -]} {
  1136.             break
  1137.         }
  1138.     }
  1139.  
  1140.     return [array get response]
  1141. }
  1142.  
  1143. # smtp::readable --
  1144. #
  1145. #    Reads a line of data from SMTP server when the socket is readable.  This
  1146. #       is the callback of "fileevent readable".
  1147. #
  1148. # Arguments:
  1149. #       token       SMTP token that has an open connection to the SMTP server.
  1150. #
  1151. # Results:
  1152. #    state(line) contains the line of data and state(readable) is reset.
  1153. #       state(readable) gets the following values:
  1154. #       -3  if there's a premature eof,
  1155. #       -2  if reading from socket fails.
  1156. #       1   if reading from socket was successful
  1157.  
  1158. proc smtp::readable {token} {
  1159.     # FRINK: nocheck
  1160.     variable $token
  1161.     upvar 0 $token state
  1162.  
  1163.     if {[catch { array set options $state(options) }]} {
  1164.         return
  1165.     }
  1166.  
  1167.     set state(line) ""
  1168.     if {[eof $state(sd)]} {
  1169.         set state(readable) -3
  1170.         set state(error) "premature end-of-file from server"
  1171.     } elseif {[catch { gets $state(sd) state(line) } result]} {
  1172.         set state(readable) -2
  1173.         set state(error) $result
  1174.     } else {
  1175.         # If the line ends in \r, remove the \r.
  1176.         if {![string compare [string index $state(line) end] "\r"]} {
  1177.             set state(line) [string range $state(line) 0 end-1]
  1178.         }
  1179.         set state(readable) 1
  1180.     }
  1181.  
  1182.     if {$state(readable) != 1} {
  1183.         if {$options(-debug)} {
  1184.             puts stderr "    ... $state(error) ..."
  1185.             flush stderr
  1186.         }
  1187.  
  1188.         catch { fileevent $state(sd) readable "" }
  1189.     }
  1190. }
  1191.  
  1192. # smtp::timer --
  1193. #
  1194. #    Handles timeout condition on any communication with the SMTP server.
  1195. #
  1196. # Arguments:
  1197. #       token       SMTP token that has an open connection to the SMTP server.
  1198. #
  1199. # Results:
  1200. #    Sets state(readable) to -1 and state(error) to an error message.
  1201.  
  1202. proc smtp::timer {token} {
  1203.     # FRINK: nocheck
  1204.     variable $token
  1205.     upvar 0 $token state
  1206.  
  1207.     array set options $state(options)
  1208.  
  1209.     set state(afterID) ""
  1210.     set state(readable) -1
  1211.     set state(error) "read from server timed out"
  1212.  
  1213.     if {$options(-debug)} {
  1214.         puts stderr "    ... $state(error) ..."
  1215.         flush stderr
  1216.     }
  1217. }
  1218.  
  1219. # smtp::boolean --
  1220. #
  1221. #    Helper function for unifying boolean values to 1 and 0.
  1222. #
  1223. # Arguments:
  1224. #       value   Some kind of value that represents true or false (i.e. 0, 1,
  1225. #               false, true, no, yes, off, on).
  1226. #
  1227. # Results:
  1228. #    Return 1 if the value is true, 0 if false.  If the input value is not
  1229. #       one of the above, throw an exception.
  1230.  
  1231. proc smtp::boolean {value} {
  1232.     switch -- [string tolower $value] {
  1233.         0 - false - no - off {
  1234.             return 0
  1235.         }
  1236.  
  1237.         1 - true - yes - on {
  1238.             return 1
  1239.         }
  1240.  
  1241.         default {
  1242.             error "unknown boolean value: $value"
  1243.         }
  1244.     }
  1245. }
  1246.