Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Smtp.tcl reverted to the pooryorick version All package require mime 1.6 have been changes to package require -exact mime |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | hypnotoad |
Files: | files | file ages | folders |
SHA3-256: |
5e923cd325f344fbe2c92512961e7b6a |
User & Date: | hypnotoad 2018-12-06 23:15:31.738 |
Context
2018-12-07
| ||
09:03 | Pulling changes from trunk Closed-Leaf check-in: 22608b7917 user: hypnotoad tags: hypnotoad | |
09:03 | Pulling in changes to re-introduce a snapshot of mime,smtp and ncgi to allow existing modules to function. Modules that need the old ways must explicitly call for [package require -exact mime 1.6] (and such) check-in: f3988b211a user: hypnotoad tags: pooryorick | |
2018-12-06
| ||
23:15 | Smtp.tcl reverted to the pooryorick version All package require mime 1.6 have been changes to package require -exact mime check-in: 5e923cd325 user: hypnotoad tags: hypnotoad | |
23:09 | Whoops. Wrong mime check-in: 6010c7a80d user: hypnotoad tags: hypnotoad | |
Changes
Changes to modules/httpd/build/core.tcl.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # support the SCGI module ### package require uri package require dns package require cron package require coroutine | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # support the SCGI module ### package require uri package require dns package require cron package require coroutine package require -exact mime 1.6 package require fileutil package require websocket package require Markdown package require fileutil::magic::filetype package require clay 0.7 namespace eval httpd::content {} |
︙ | ︙ |
Changes to modules/mime/smtp-1.4.tcl.
1 2 3 4 5 6 7 8 9 10 | # smtp.tcl - SMTP client # # Copyright (c) 1999-2000 Marshall T. Rose # Copyright (c) 2003-2006 Pat Thoyts # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require Tcl 8.3 | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # smtp.tcl - SMTP client # # Copyright (c) 1999-2000 Marshall T. Rose # Copyright (c) 2003-2006 Pat Thoyts # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require Tcl 8.3 package require -exact mime 1.6 catch { package require SASL 1.0; # tcllib 1.8 package require SASL::NTLM 1.0; # tcllib 1.8 } # |
︙ | ︙ | |||
63 64 65 66 67 68 69 | # Sends a mime object (containing a message) to some recipients # # Arguments: # part The MIME object containing the message to send # args A list of arguments specifying various options for sending the # message: # -atleastone A boolean specifying whether or not to send the | | | | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | # Sends a mime object (containing a message) to some recipients # # Arguments: # part The MIME object containing the message to send # args A list of arguments specifying various options for sending the # message: # -atleastone A boolean specifying whether or not to send the # message at all if any of the recipients are # invalid. A value of false (as defined by # ::smtp::boolean) means that ALL recipients must be # valid in order to send the message. A value of # true means that as long as at least one recipient # is valid, the message will be sent. # -debug A boolean specifying whether or not debugging is # on. If debugging is enabled, status messages are # printed to stderr while trying to send mail. # -queue A boolean specifying whether or not the message # being sent should be queued for later delivery. # -header A single RFC 822 header key and value (as a list), # used to specify to whom to send the message # (To, Cc, Bcc), the "From", etc. # -originator The originator of the message (equivalent to # specifying a From header). # -recipients A string containing recipient e-mail addresses. # NOTE: This option overrides any recipient addresses # specified with -header. # -servers A list of mail servers that could process the |
︙ | ︙ | |||
130 131 132 133 134 135 136 | set tlsP 1 set tlspolicy {} set username {} set password {} array set header "" | | | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 | set tlsP 1 set tlspolicy {} set username {} set password {} array set header "" # lowerL will contain the list of header keys (converted to lower case) # specified with various -header options. mixedL is the mixed-case version # of the list. set lowerL "" set mixedL "" # Parse options (args). if {[expr {[llength $args]%2}]} { # Some option didn't get a value. error "Each option must have a value! Invalid option list: $args" } foreach {option value} $args { switch -- $option { -atleastone {set aloP [boolean $value]} -debug {set debugP [boolean $value]} -queue {set queueP [boolean $value]} -usetls {set tlsP [boolean $value]} -tlspolicy {set tlspolicy $value} |
︙ | ︙ | |||
169 170 171 172 173 174 175 | if {[lsearch -exact $disallowedHdrList $lower] > -1} { error "Content-Type, Content-Transfer-Encoding,\ Content-MD5, and MIME-Version cannot be user-specified." } if {[lsearch -exact $lowerL $lower] < 0} { lappend lowerL $lower lappend mixedL $mixed | | | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 | if {[lsearch -exact $disallowedHdrList $lower] > -1} { error "Content-Type, Content-Transfer-Encoding,\ Content-MD5, and MIME-Version cannot be user-specified." } if {[lsearch -exact $lowerL $lower] < 0} { lappend lowerL $lower lappend mixedL $mixed } lappend header($lower) [lindex $value 1] } -originator { set originator $value if {$originator == ""} { |
︙ | ︙ | |||
231 232 233 234 235 236 237 | if {$origP} { # -originator was specified with "", so SMTP sender should be marked "". set sender "" } else { # -originator was specified with a value, OR -originator wasn't # specified at all. | | | | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 | if {$origP} { # -originator was specified with "", so SMTP sender should be marked "". set sender "" } else { # -originator was specified with a value, OR -originator wasn't # specified at all. # If no -originator was provided, get the originator from the "From" # header. If there was no "From" header get it from the username # executing the script. set who "-originator" if {$originator == ""} { if {![info exists header($fromL)]} { set originator $::tcl_platform(user) } else { set originator [join $header($fromL) ,] # Indicate that we're using the From header for the originator. set who $fromM } } # If there's no "From" header, create a From header with the value # of -originator as the value. if {[lsearch -exact $lowerL $fromL] < 0} { lappend lowerL $fromL lappend mixedL $fromM lappend header($fromL) $originator |
︙ | ︙ | |||
442 443 444 445 446 447 448 | set inner [::mime::initialize -canonical message/rfc822 \ -header [list Content-Description \ "Original Message"] \ -parts [list $part]] set subject "\[$bccM\]" if {[info exists header(subject)]} { | | | 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 | set inner [::mime::initialize -canonical message/rfc822 \ -header [list Content-Description \ "Original Message"] \ -parts [list $part]] set subject "\[$bccM\]" if {[info exists header(subject)]} { append subject " " [lindex $header(subject) 0] } set outer [::mime::initialize \ -canonical multipart/digest \ -header [list From $originator] \ -header [list Bcc ""] \ -header [list Date \ |
︙ | ︙ | |||
476 477 478 479 480 481 482 | catch { ::mime::finalize $inner -subordinates none } catch { ::mime::finalize $outer -subordinates none } } # Determine if there was any error in prior operations and set errorcodes # and error messages appropriately. | | | | | 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 | catch { ::mime::finalize $inner -subordinates none } catch { ::mime::finalize $outer -subordinates none } } # Determine if there was any error in prior operations and set errorcodes # and error messages appropriately. switch -- $code { 0 { set status orderly } 7 { set code 1 array set response $result set result "$response(code): $response(diagnostic)" set status abort } default { set status abort } } # Destroy SMTP token 'cause we're done with it. catch { finalize $token -close $status } # Restore provided MIME object to original state (without the SMTP headers). foreach key [::mime::getheader $part -names] { mime::setheader $part $key "" -mode delete } foreach {key values} $savedH { foreach value $values { ::mime::setheader $part $key $value -mode append } |
︙ | ︙ | |||
579 580 581 582 583 584 585 | # # Create an SMTP token and open a connection to the SMTP server. # # Arguments: # args A list of arguments specifying various options for sending the # message: # -debug A boolean specifying whether or not debugging is | | | | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 | # # Create an SMTP token and open a connection to the SMTP server. # # Arguments: # args A list of arguments specifying various options for sending the # message: # -debug A boolean specifying whether or not debugging is # on. If debugging is enabled, status messages are # printed to stderr while trying to send mail. # -client Either localhost or the name of the local host. # -multiple Multiple messages will be sent using this token. # -queue A boolean specifying whether or not the message # being sent should be queued for later delivery. # -servers A list of mail servers that could process the # request. # -ports A list of ports on mail servers that could process # the request (one port per server-- defaults to 25). # -usetls A boolean to indicate we will use TLS if possible. # -tlspolicy Command called if TLS setup fails. # -username These provide the authentication information # -password to be used if needed by the SMTP server. # # Results: # On success, return an smtp token. On failure, throw # an exception with an error code and error message. proc ::smtp::initialize {args} { |
︙ | ︙ | |||
618 619 620 621 622 623 624 | -ports 25 -usetls 1 -tlspolicy {} \ -username {} -password {}] array set options $args set state(options) [array get options] # Iterate through servers until one accepts a connection (and responds # nicely). | | | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 | -ports 25 -usetls 1 -tlspolicy {} \ -username {} -password {}] array set options $args set state(options) [array get options] # Iterate through servers until one accepts a connection (and responds # nicely). set index 0 foreach server $options(-servers) { set state(readable) 0 if {[llength $options(-ports)] >= $index} { set port [lindex $options(-ports) $index] } else { set port 25 } |
︙ | ︙ | |||
692 693 694 695 696 697 698 | } proc ::smtp::initialize_ehlo {token} { global errorCode errorInfo upvar einfo einfo upvar ecode ecode upvar code code | | | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 | } proc ::smtp::initialize_ehlo {token} { global errorCode errorInfo upvar einfo einfo upvar ecode ecode upvar code code # FRINK: nocheck variable $token upvar 0 $token state array set options $state(options) # Try enhanced SMTP first. |
︙ | ︙ | |||
719 720 721 722 723 724 725 | array set response [list code 400 diagnostic $result args ""] } else { array set response $result } set ecode $errorCode set einfo $errorInfo } | | | | | | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 | array set response [list code 400 diagnostic $result args ""] } else { array set response $result } set ecode $errorCode set einfo $errorInfo } if {$response(code) == 250} { # Successful response to HELO or EHLO command, so set up queuing # and whatnot and return the token. set state(esmtp) $response(args) if {(!$options(-multiple)) \ && ([lsearch $response(args) ONEX] >= 0)} { catch {smtp::talk $token 300 ONEX} } if {($options(-queue)) \ && ([lsearch $response(args) XQUE] >= 0)} { catch {smtp::talk $token 300 QUED} } # Support STARTTLS extension. # The state(tls) item is used to see if we have already tried this. if {($options(-usetls)) && ![info exists state(tls)] \ && (([lsearch $response(args) STARTTLS] >= 0) || ([lsearch $response(args) TLS] >= 0))} { if {![load_tls]} { set state(tls) 0 if {![catch {smtp::talk $token 300 STARTTLS} resp]} { array set starttls $resp if {$starttls(code) == 220} { fileevent $state(sd) readable {} catch { ::tls::import $state(sd) catch {::tls::handshake $state(sd)} msg set state(tls) 1 } fileevent $state(sd) readable \ [list ::smtp::readable $token] return [initialize_ehlo $token] } else { # Call a TLS client policy proc here # returns secure close and try another server. # returns insecure continue on current socket |
︙ | ︙ | |||
778 779 780 781 782 783 784 | return {} } } } } } | | | | | | | | | | 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 | return {} } } } } } # If we have not already tried and the server supports it and we # have a username -- lets try to authenticate. # if {![info exists state(auth)] && [llength [package provide SASL]] != 0 && [set andx [lsearch -glob $response(args) "AUTH*"]] >= 0 && [string length $options(-username)] > 0 } { # May be AUTH mech or AUTH=mech # We want to use the strongest mechanism that has been offered # and that we support. If we cannot find a mechanism that # succeeds, we will go ahead and try to carry on unauthenticated. # This may still work else we'll get an unauthorised error later. set mechs [string range [lindex $response(args) $andx] 5 end] foreach mech [SASL::mechanisms] { if {[lsearch -exact $mechs $mech] == -1} { continue } if {[catch { Authenticate $token $mech } msg]} { if {$options(-debug)} { puts stderr "AUTH $mech failed: $msg " flush stderr } } if {[info exists state(auth)] && $state(auth)} { if {$state(auth) == 1} { break } else { # After successful AUTH we are supposed to redo # our connection for mechanisms that setup a new # security layer -- these should set state(auth) # greater than 1 fileevent $state(sd) readable \ [list ::smtp::readable $token] return [initialize_ehlo $token] } } } } return $token } else { # Bad response; close the connection and hope the next server # is happier. catch {close $state(sd)} } return {} } proc ::smtp::SASLCallback {token context command args} { upvar #0 $token state upvar #0 $context ctx array set options $state(options) switch -exact -- $command { login { return "" } username { return $options(-username) } password { return $options(-password) } hostname { return [info host] } realm { if {[string equal $ctx(mech) "NTLM"] \ && [info exists ::env(USERDOMAIN)]} { return $::env(USERDOMAIN) } else { return "" } } default { return -code error "error: unsupported SASL information requested" } } } proc ::smtp::Authenticate {token mechanism} { upvar 0 $token state |
︙ | ︙ | |||
871 872 873 874 875 876 877 | set challenge $response(diagnostic) } SASL::step $ctx $challenge set result [smtp::talk $token 300 \ [base64::encode -maxlen 0 [SASL::response $ctx]]] array set response $result } | | | 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 | set challenge $response(diagnostic) } SASL::step $ctx $challenge set result [smtp::talk $token 300 \ [base64::encode -maxlen 0 [SASL::response $ctx]]] array set response $result } if {$response(code) == 235} { set state(auth) 1 return $result } else { return -code 7 $result } } |
︙ | ︙ | |||
981 982 983 984 985 986 987 | if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} { error "unknown origination mode $mode" } set from "$mode FROM:<$originator>" # RFC 1870 - SMTP Service Extension for Message Size Declaration | | | 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 | if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} { error "unknown origination mode $mode" } set from "$mode FROM:<$originator>" # RFC 1870 - SMTP Service Extension for Message Size Declaration if {[info exists state(esmtp)] && [lsearch -glob $state(esmtp) "SIZE*"] != -1} { catch { set size [string length [mime::buildmessage $part]] append from " SIZE=$size" } } |
︙ | ︙ | |||
1003 1004 1005 1006 1007 1008 1009 | } } # ::smtp::waddr -- # # Send recipient info to SMTP server. This occurs after originator info # is sent (in ::smtp::winit). This function is called by | | | | 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 | } } # ::smtp::waddr -- # # Send recipient info to SMTP server. This occurs after originator info # is sent (in ::smtp::winit). This function is called by # ::smtp::sendmessageaux. # # Arguments: # token SMTP token that has an open connection to the SMTP server. # recipient One of the recipients to whom the message should be # delivered. # # Results: # Recipient info is sent and SMTP server's response is returned. If an # error occurs, throw an exception. proc ::smtp::waddr {token recipient} { # FRINK: nocheck |
︙ | ︙ | |||
1038 1039 1040 1041 1042 1043 1044 | } } # ::smtp::wtext -- # # Send message to SMTP server. This occurs after recipient info # is sent (in ::smtp::winit). This function is called by | | | 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 | } } # ::smtp::wtext -- # # Send message to SMTP server. This occurs after recipient info # is sent (in ::smtp::winit). This function is called by # ::smtp::sendmessageaux. # # Arguments: # token SMTP token that has an open connection to the SMTP server. # part The MIME object containing the message to send. # # Results: # MIME message is sent and SMTP server's response is returned. If an |
︙ | ︙ | |||
1379 1380 1381 1382 1383 1384 1385 | [string trim [string range $state(line) 4 end]] } else { lappend response(args) \ [string trim [string range $state(line) 4 end]] } # When status message line ends in -, it means the message is complete. | | | 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 | [string trim [string range $state(line) 4 end]] } else { lappend response(args) \ [string trim [string range $state(line) 4 end]] } # When status message line ends in -, it means the message is complete. if {[string compare [string index $state(line) 3] -]} { break } } return [array get response] } |
︙ | ︙ |
Changes to modules/mime/smtp.tcl.
1 2 3 4 5 6 7 8 9 10 | # smtp.tcl - SMTP client # # Copyright (c) 1999-2000 Marshall T. Rose # Copyright (c) 2003-2006 Pat Thoyts # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require Tcl 8.3 | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # smtp.tcl - SMTP client # # Copyright (c) 1999-2000 Marshall T. Rose # Copyright (c) 2003-2006 Pat Thoyts # Copyright (c) 2003-2018 Poor Yorick # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # package require Tcl 8.3 package require mime 1.7- catch { package require SASL 1.0; # tcllib 1.8 package require SASL::NTLM 1.0; # tcllib 1.8 } # |
︙ | ︙ | |||
97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | # is 120 seconds. # -usetls A boolean flag. If the server supports it and we # have the package, use TLS to secure the connection. # -tlspolicy A command to call if the TLS negotiation fails for # some reason. Return 'insecure' to continue with # normal SMTP or 'secure' to close the connection and # try another server. # -username These are needed if your SMTP server requires # -password authentication. # # Results: # Message is sent. On success, return "". On failure, throw an # exception with an error code and error message. proc ::smtp::sendmessage {part args} { | > > < < > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 | # is 120 seconds. # -usetls A boolean flag. If the server supports it and we # have the package, use TLS to secure the connection. # -tlspolicy A command to call if the TLS negotiation fails for # some reason. Return 'insecure' to continue with # normal SMTP or 'secure' to close the connection and # try another server. # -tlsimport after a succesfull socket command, import tls on # channel - used for native smtps negotiation # -username These are needed if your SMTP server requires # -password authentication. # # Results: # Message is sent. On success, return "". On failure, throw an # exception with an error code and error message. proc ::smtp::sendmessage {part args} { # Here are the meanings of the following boolean variables: # aloP -- value of -atleastone option above. # debugP -- value of -debug option above. # origP -- 1 if -originator option was specified, 0 otherwise. # queueP -- value of -queue option above. set aloP 0 set debugP 0 set origP 0 set queueP 0 set maxsecs 120 set originator "" set recipients "" set servers [list localhost] set client "" ;# default is set after options processing set ports [list 25] set tlsP 1 set tlspolicy {} set tlsimport 0 set username {} set password {} array set header "" # lowerL will contain the list of header keys (converted to lower case) # specified with various -header options. mixedL is the mixed-case version |
︙ | ︙ | |||
150 151 152 153 154 155 156 157 158 159 160 161 162 163 | foreach {option value} $args { switch -- $option { -atleastone {set aloP [boolean $value]} -debug {set debugP [boolean $value]} -queue {set queueP [boolean $value]} -usetls {set tlsP [boolean $value]} -tlspolicy {set tlspolicy $value} -maxsecs {set maxsecs [expr {$value < 0 ? 0 : $value}]} -header { if {[llength $value] != 2} { error "-header expects a key and a value, not $value" } set mixed [lindex $value 0] set lower [string tolower $mixed] | > | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | foreach {option value} $args { switch -- $option { -atleastone {set aloP [boolean $value]} -debug {set debugP [boolean $value]} -queue {set queueP [boolean $value]} -usetls {set tlsP [boolean $value]} -tlspolicy {set tlspolicy $value} -tlsimport {set tlsimport [boolean $value]} -maxsecs {set maxsecs [expr {$value < 0 ? 0 : $value}]} -header { if {[llength $value] != 2} { error "-header expects a key and a value, not $value" } set mixed [lindex $value 0] set lower [string tolower $mixed] |
︙ | ︙ | |||
300 301 302 303 304 305 306 | lappend header($senderL) $aprops(address) } } } # We're done parsing the arguments. | | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 | lappend header($senderL) $aprops(address) } } } # We're done parsing the arguments. if {$recipients ne {}} { set who -recipients } elseif {![info exists header($toL)]} { error "need -header \"$toM ...\"" } else { set recipients [join $header($toL) ,] # Add Cc values to recipients list set who $toM |
︙ | ︙ | |||
378 379 380 381 382 383 384 | lappend vrecipients $aprops(address) } # If there's no date header, get the date from the mime message. Same for # the message-id. if {([lsearch -exact $lowerL $dateL] < 0) \ | | | | | | | > | | | | | < > | < < | | | | | < | | > | | | < | | | | | < < < < < | | < | | | > > | | | | | | < < | > | | | > | | | | > | > > > | > | | | | | < | < | | 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 | lappend vrecipients $aprops(address) } # If there's no date header, get the date from the mime message. Same for # the message-id. if {([lsearch -exact $lowerL $dateL] < 0) \ && ([catch {$part header get $dateL}])} { lappend lowerL $dateL lappend mixedL $dateM lappend header($dateL) [::mime::datetime -now proper] } if {([lsearch -exact $lowerL ${message-idL}] < 0) \ && ([catch {$part header get ${message-idL}}])} { lappend lowerL ${message-idL} lappend mixedL ${message-idM} lappend header(${message-idL}) [::mime::uniqueID] } # Get all the headers from the MIME object and save them so that they can # later be restored. set savedH [$part header get] # Take all the headers defined earlier and add them to the MIME message. foreach lower $lowerL mixed $mixedL { foreach value $header($lower) { $part header set $mixed $value -mode append } } if {[string length $client] < 1} { if {![string compare $servers localhost]} { set client localhost } else { set client [info hostname] } } # Create smtp token, which essentially means begin talking to the SMTP # server. set token [initialize -debug $debugP -client $client \ -maxsecs $maxsecs -usetls $tlsP \ -multiple $bccP -queue $queueP \ -servers $servers -ports $ports \ -tlspolicy $tlspolicy -tlsimport $tlsimport \ -username $username -password $password] if {![string match ::smtp::* $token]} { # An error occurred and $token contains the error info array set respArr $token return -code error $respArr(diagnostic) } set code1 [catch { sendmessageaux $token $part $sender $vrecipients $aloP } cres1 copts1] lappend results $code1 $cres1 $copts1 if {!$code1 && $bccP} { # Send the message to bcc recipients as a MIME attachment. set inner [::mime::.new {} -canonical message/rfc822 \ -headers [list Content-Description \ {Original Message}] \ -parts [list $part]] set subject "\[$bccM\]" if {[info exists header(subject)]} { append subject " " [lindex $header(subject) 0] } set outer [::mime::.new {} \ -canonical multipart/digest \ -headers [list \ From [list $originator {}] \ Bcc Date [::mime::datetime -now proper] \ Subject $subject \ Message-ID [::mime::uniqueID] \ Content-Description {Blind Carbon Copy} \ -parts [list $inner]]] set code2 [catch { sendmessageaux $token $outer $sender $brecipients $aloP } cres2 copts2] lappend results $code2 $cres2 $copts2 catch {$inner .destroy -subordinates none} catch {$outer .destroy -subordinates none} } # Determine if there was any error in prior operations and set errorcodes # and error messages appropriately. foreach {code cres copts} $results { # handle just the first one switch -- $code { 0 { set status orderly } 7 { dict set copts -code 1 set status abort break } default { set status abort break } } } set code3 [catch {finalize $token -close $status} cres3 copts3] if {$code3 && !$code} { lassign [list $cres3 $copts3] cres copts } # Destroy SMTP token 'cause we're done with it. # Restore provided MIME object to original state (without the SMTP headers). foreach {key val} [$part header get] { $part header set $key "" -mode delete } foreach {key value} $savedH { $part header set $key {*}$value -mode append } return -options $copts $cres } # ::smtp::sendmessageaux -- # # Sends a mime object (containing a message) to some recipients using an # existing SMTP token. # |
︙ | ︙ | |||
591 592 593 594 595 596 597 598 599 600 601 602 603 604 | # being sent should be queued for later delivery. # -servers A list of mail servers that could process the # request. # -ports A list of ports on mail servers that could process # the request (one port per server-- defaults to 25). # -usetls A boolean to indicate we will use TLS if possible. # -tlspolicy Command called if TLS setup fails. # -username These provide the authentication information # -password to be used if needed by the SMTP server. # # Results: # On success, return an smtp token. On failure, throw # an exception with an error code and error message. | > > | 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 | # being sent should be queued for later delivery. # -servers A list of mail servers that could process the # request. # -ports A list of ports on mail servers that could process # the request (one port per server-- defaults to 25). # -usetls A boolean to indicate we will use TLS if possible. # -tlspolicy Command called if TLS setup fails. # -tlsimport after a succesfull socket command, import tls on # channel - used for native smtps negotiation # -username These provide the authentication information # -password to be used if needed by the SMTP server. # # Results: # On success, return an smtp token. On failure, throw # an exception with an error code and error message. |
︙ | ︙ | |||
612 613 614 615 616 617 618 619 620 621 622 623 624 625 | variable $token upvar 0 $token state array set state [list afterID "" options "" readable 0] array set options [list -debug 0 -client localhost -multiple 1 \ -maxsecs 120 -queue 0 -servers localhost \ -ports 25 -usetls 1 -tlspolicy {} \ -username {} -password {}] array set options $args set state(options) [array get options] # Iterate through servers until one accepts a connection (and responds # nicely). | > < | > > < < < | | > > > > | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 | variable $token upvar 0 $token state array set state [list afterID "" options "" readable 0] array set options [list -debug 0 -client localhost -multiple 1 \ -maxsecs 120 -queue 0 -servers localhost \ -ports 25 -usetls 1 -tlspolicy {} \ -tlsimport 0 \ -username {} -password {}] array set options $args set state(options) [array get options] # Iterate through servers until one accepts a connection (and responds # nicely). foreach server $options(-servers) port $options(-ports) { if {$server == ""} continue set state(readable) 0 if {$port == ""} { set port 25 } if {$options(-debug)} { puts stderr "Trying $server..." flush stderr } if {[info exists state(sd)]} { unset state(sd) } if {[set code [catch { set state(sd) [socket -async $server $port] if { $options(-tlsimport) } { package require tls tls::import $state(sd) } fconfigure $state(sd) -blocking off -translation binary fileevent $state(sd) readable [list ::smtp::readable $token] } result]]} { set ecode $errorCode set einfo $errorInfo catch { close $state(sd) } |
︙ | ︙ | |||
670 671 672 673 674 675 676 | } } set r [initialize_ehlo $token] if {$r != {}} { return $r } | < > > | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 | } } set r [initialize_ehlo $token] if {$r != {}} { return $r } } # None of the servers accepted our connection, so close everything up and # return an error. finalize $token -close drop return -code $code -errorinfo $einfo -errorcode $ecode $result } # If we cannot load the tls package, ignore the error # Result value is a Tcl return code, not a bool. # 0 == OK proc ::smtp::load_tls {} { set r [catch {package require tls}] if {$r} {set ::errorInfo ""} return $r } proc ::smtp::initialize_ehlo {token} { |
︙ | ︙ | |||
740 741 742 743 744 745 746 | } # 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))} { | | | | | 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 | } # Support STARTTLS extension. # The state(tls) item is used to see if we have already tried this. if {($options(-usetls)) && ![info exists state(tls)] \ && (([lsearch $response(args) STARTTLS] >= 0) || ([lsearch $response(args) TLS] >= 0))} { if {[load_tls] == 0} { set state(tls) 0 if {![catch {smtp::talk $token 300 STARTTLS} resp]} { array set starttls $resp if {$starttls(code) == 220} { fileevent $state(sd) readable {} catch { ::tls::import $state(sd) catch {::tls::handshake $state(sd)} msg set state(tls) 1 } fileevent $state(sd) readable \ [list ::smtp::readable $token] return [initialize_ehlo $token] } else { # Call a TLS client policy proc here # returns secure - close and try another server. # returns insecure - continue on current socket set policy insecure if {$options(-tlspolicy) != {}} { catch { eval $options(-tlspolicy) \ [list $starttls(code)] \ [list $starttls(diagnostic)] } policy |
︙ | ︙ | |||
903 904 905 906 907 908 909 | # # Results: # SMTP connection is closed and state variables are cleared. If there's # an error while attempting to close the connection to the SMTP server, # throw an exception with the error code and error message. proc ::smtp::finalize {token args} { | < > | | | | | | | | | | | | | | | | | | < | | | | > | | | | | | | | | < | 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 | # # Results: # SMTP connection is closed and state variables are cleared. If there's # an error while attempting to close the connection to the SMTP server, # throw an exception with the error code and error message. proc ::smtp::finalize {token args} { # FRINK: nocheck variable $token upvar 0 $token state array set options [list -close orderly] array set options $args try { switch -- $options(-close) { orderly { set code [catch { talk $token 120 QUIT } result] } abort { set code [catch { talk $token 0 RSET talk $token 0 QUIT } result] } drop { set code 0 set result "" } default { error "unknown value for -close $options(-close)" } } } finally { if {$state(sd) in [chan names]} { close $state(sd) } if {$state(afterID) ne {}} { after cancel $state(afterID) } foreach name [array names state] { unset state($name) } # FRINK: nocheck unset $token } } # ::smtp::winit -- # # Send originator info to SMTP server. This occurs after HELO/EHLO # command has completed successfully (in ::smtp::initialize). This function # is called by ::smtp::sendmessageaux. |
︙ | ︙ | |||
984 985 986 987 988 989 990 | set from "$mode FROM:<$originator>" # RFC 1870 - SMTP Service Extension for Message Size Declaration if {[info exists state(esmtp)] && [lsearch -glob $state(esmtp) "SIZE*"] != -1} { catch { | | | 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 | set from "$mode FROM:<$originator>" # RFC 1870 - SMTP Service Extension for Message Size Declaration if {[info exists state(esmtp)] && [lsearch -glob $state(esmtp) "SIZE*"] != -1} { catch { set size [string length [$part serialize]] append from " SIZE=$size" } } array set response [set result [talk $token 600 $from]] if {$response(code) == 250} { |
︙ | ︙ | |||
1125 1126 1127 1128 1129 1130 1131 | # replace all '.'s that start their own line with '..'s, and # then write the mime body out to the filehandle. Do not forget to # deal with bare LF's here too (SF bug #499242). if {$trf} { set code [catch { ::mime::copymessage $part $state(sd) } result] } else { | | | 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 | # replace all '.'s that start their own line with '..'s, and # then write the mime body out to the filehandle. Do not forget to # deal with bare LF's here too (SF bug #499242). if {$trf} { set code [catch { ::mime::copymessage $part $state(sd) } result] } else { set code [catch {$part serialize} result] if {$code == 0} { # Detect and transform bare LF's into proper CR/LF # sequences. while {[regsub -all -- {([^\r])\n} $result "\\1\r\n" result]} {} regsub -all -- {\n\.} $result "\n.." result |
︙ | ︙ | |||
1290 1291 1292 1293 1294 1295 1296 | array set options $state(options) if {$options(-debug)} { puts stderr "--> $command (wait upto $secs seconds)" flush stderr } | > | | > | 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 | array set options $state(options) if {$options(-debug)} { puts stderr "--> $command (wait upto $secs seconds)" flush stderr } if {[catch { puts -nonewline $state(sd) $command\r\n flush $state(sd) } result] } { return [list code 400 diagnostic $result] } if {$secs == 0} { return "" } |
︙ | ︙ | |||
1320 1321 1322 1323 1324 1325 1326 | proc ::smtp::hear {token secs} { # FRINK: nocheck variable $token upvar 0 $token state array set options $state(options) | | | | 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 | proc ::smtp::hear {token secs} { # FRINK: nocheck variable $token upvar 0 $token state array set options $state(options) array set response [list args {}] set firstP 1 while 1 { if {$secs >= 0} { ## SF [ 836442 ] timeout with large data ## correction, aotto 031105 - if {$secs > 600} {set secs 600} set state(afterID) [after [expr {$secs*1000}] \ [list ::smtp::timer $token]] } |
︙ | ︙ | |||
1496 1497 1498 1499 1500 1501 1502 | error "unknown boolean value: $value" } } } # ------------------------------------------------------------------------- | | | 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 | error "unknown boolean value: $value" } } } # ------------------------------------------------------------------------- package provide smtp 1.5 # ------------------------------------------------------------------------- # Local variables: # indent-tabs-mode: nil # End: |
Changes to modules/pop3d/pop3d.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # pop3d.tcl -- # # Implementation of a pop3 server for Tcl. # # Copyright (c) 2002-2009 by Andreas Kupries # Copyright (c) 2005 by Reinhard Max (-socket option) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require md5 ; # tcllib | APOP | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # pop3d.tcl -- # # Implementation of a pop3 server for Tcl. # # Copyright (c) 2002-2009 by Andreas Kupries # Copyright (c) 2005 by Reinhard Max (-socket option) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require md5 ; # tcllib | APOP package require -exact mime 1.6; # tcllib | storage callback package require log ; # tcllib | tracing package provide pop3d 1.1.0 namespace eval ::pop3d { # Data storage in the pop3d module # ------------------------------- |
︙ | ︙ |
Changes to modules/pop3d/pop3d_dbox.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # -*- tcl -*- # pop3d_dbox.tcl -- # # Implementation of a simple mailbox database for the pop3 server # Each mailbox is a a directory in a base directory, with each mail # a file in that directory. The mail file contains both headers and # body of the mail. # # Copyright (c) 2002 by Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # -*- tcl -*- # pop3d_dbox.tcl -- # # Implementation of a simple mailbox database for the pop3 server # Each mailbox is a a directory in a base directory, with each mail # a file in that directory. The mail file contains both headers and # body of the mail. # # Copyright (c) 2002 by Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require -exact mime 1.6; # tcllib | mime token is result of "get". package require log ; # tcllib | Logging package namespace eval ::pop3d::dbox { # Data storage in the pop3d::dbox module # ------------------------------------- # One array per object containing the db contents. Keyed by user name. # And the information about the last file data was read from. |
︙ | ︙ |
Changes to modules/smtpd/smtpd.tcl.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # or FITNESS FOR A PARTICULAR PURPOSE. See the file 'license.terms' for # more details. # ------------------------------------------------------------------------- # @mdgen EXCLUDE: clients/mail-test.tcl package require Tcl 8.3; # tcl minimum version package require logger; # tcllib 1.3 | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # or FITNESS FOR A PARTICULAR PURPOSE. See the file 'license.terms' for # more details. # ------------------------------------------------------------------------- # @mdgen EXCLUDE: clients/mail-test.tcl package require Tcl 8.3; # tcl minimum version package require logger; # tcllib 1.3 package require -exact mime 1.6; # tcllib package provide smtpd 1.5 namespace eval ::smtpd { variable version [package present smtpd] variable stopped |
︙ | ︙ |