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