Attachment "mime_prepare_for_jim.diff" to
ticket [8bb4e24bc1]
added by
oehhar
2023-08-16 09:04:04.
--- mime.1.7.1.tcl 2023-01-30 08:21:20.000000000 -0500
+++ mime.tcl 2023-08-02 19:52:58.551306279 -0400
@@ -11,6 +11,7 @@
# (c) 2003-2008 Pat Thoyts
# (c) 2005 Benjamin Riefenstahl
# (c) 2013-2021 Poor Yorick
+# (c) 2023 Georg Lehner
#
#
# See the file "license.terms" for information on usage and redistribution
@@ -24,8 +25,10 @@
package require Tcl 8.5
package provide mime 1.7.1
-package require tcl::chan::memchan
-
+#package provide at.magma-soft.mime 1.7.2
+if {$::tcl_platform(engine) eq "Tcl"} {
+ package require tcl::chan::memchan
+}
if {[catch {package require Trf 2.0}]} {
@@ -337,9 +340,9 @@
}
namespace export {*}{
- copymessage finalize getbody getheader getproperty initialize
- mapencoding parseaddress parsedatetime reversemapencoding setheader
- uniqueID
+ copymessage finalize getbody getheader getproperty initialize
+ mapencoding parseaddress parsedatetime reversemapencoding setheader
+ uniqueID
}
}
@@ -375,8 +378,6 @@
# An initialized mime token.
proc ::mime::initialize args {
- global errorCode errorInfo
-
variable mime
set token [namespace current]::[incr mime(uid)]
@@ -386,7 +387,8 @@
if {[catch [list mime::initializeaux $token {*}$args] result eopts]} {
catch {mime::finalize $token -subordinates dynamic}
- return -options $eopts $result
+ #dict set eopts -level 0
+ return {*}$eopts $result
}
return $token
}
@@ -409,7 +411,6 @@
# Either configures the mime token, or throws an error.
proc ::mime::initializeaux {token args} {
- global errorCode errorInfo
# FRINK: nocheck
variable $token
upvar 0 $token state
@@ -441,7 +442,7 @@
-param {
if {[llength $value] != 2} {
- error "-param expects a key and a value, not $value"
+ error "-param expects a key and a value, not $value"
}
set lower [string tolower [set mixed [lindex $value 0]]]
if {[info exists params($lower)]} {
@@ -453,7 +454,7 @@
}
-encoding {
- set value [string tolower $value[set value {}]]
+ set value [string tolower $value[set value {}]]
switch -- $value {
7bit - 8bit - binary - quoted-printable - base64 {
@@ -485,7 +486,7 @@
lappend state(mixedL) $mixed
}
- set userheader 1
+ set userheader 1
array set header $state(header)
lappend header($lower) [lindex $value 1]
@@ -573,7 +574,8 @@
}
}
}
- default {# Go ahead}
+ default {# Go ahead
+ }
}
if {[lsearch -exact $state(lowerL) content-id] < 0} {
@@ -620,9 +622,7 @@
}
}
- set code [catch {mime::parsepart $token} result]
- set ecode $errorCode
- set einfo $errorInfo
+ set code [catch {mime::parsepart $token} result eopts]
if {$fileP} {
if {!$openP} {
@@ -631,8 +631,8 @@
}
unset state(fd)
}
-
- return -code $code -errorinfo $einfo -errorcode $ecode $result
+ #dict set eopts -level 0
+ return {*}$eopts $result
}
# ::mime::parsepart --
@@ -669,29 +669,29 @@
incr pos [expr {$x + 1}]
}
} else {
- if {$state(lines.current) >= $state(lines.count)} {
- set blankP 1
- set line {}
- } else {
- set line [lindex $state(lines) $state(lines.current)]
- incr state(lines.current)
- set x [string length $line]
- if {$x == 0} {set blankP 1}
- }
+ if {$state(lines.current) >= $state(lines.count)} {
+ set blankP 1
+ set line {}
+ } else {
+ set line [lindex $state(lines) $state(lines.current)]
+ incr state(lines.current)
+ set x [string length $line]
+ if {$x == 0} {set blankP 1}
+ }
}
if {!$blankP && [string match *\r $line]} {
- set line [string range $line 0 $x-2]]
+ set line [string range $line 0 $x-2]
if {$x == 1} {
set blankP 1
}
}
if {!$blankP && (
- [string first { } $line] == 0
- ||
- [string first \t $line] == 0
- )} {
+ [string first { } $line] == 0
+ ||
+ [string first \t $line] == 0
+ )} {
append vline \n $line
continue
}
@@ -706,11 +706,11 @@
}
if {
- [set x [string first : $vline]] <= 0
- ||
- [set mixed [string trimright [
- string range $vline 0 [expr {$x - 1}]]]] eq {}
- } {
+ [set x [string first : $vline]] <= 0
+ ||
+ [set mixed [string trimright [
+ string range $vline 0 [expr {$x - 1}]]]] eq {}
+ } {
error "improper line in header: $vline"
}
set value [string trim [string range $vline [expr {$x + 1}] end]]
@@ -731,10 +731,10 @@
content-transfer-encoding {
if {
- $state(encoding) ne {}
- &&
- $state(encoding) ne [string tolower $value]
- } {
+ $state(encoding) ne {}
+ &&
+ $state(encoding) ne [string tolower $value]
+ } {
error "multiple Content-Transfer-Encoding fields starting with $vline"
}
@@ -940,7 +940,7 @@
# part as the end of the current part.
if {[set moreP [string compare $line --$boundary--]]
- && $line ne "--$boundary"} {
+ && $line ne "--$boundary"} {
# The current part has not ended, so we record the line
# if we are inside a part and doing string parsing.
@@ -965,7 +965,6 @@
set count 0
}
if {$forceoctet} {
- set ::errorInfo {}
if {[catch {
mime::initializeaux $child \
-file $state(file) -root $state(root) \
@@ -1015,7 +1014,6 @@
# tcl list.
proc ::mime::parsetype {token string} {
- global errorCode errorInfo
# FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1030,20 +1028,18 @@
set state(tokenL) $typetokenL
set state(lexemeL) $typelexemeL
- set code [catch {mime::parsetypeaux $token $string} result]
- set ecode $errorCode
- set einfo $errorInfo
+ set code [catch {mime::parsetypeaux $token $string} result eopts]
unset {*}{
- state(input)
- state(buffer)
- state(lastC)
- state(comment)
- state(tokenL)
- state(lexemeL)
+ state(input)
+ state(buffer)
+ state(lastC)
+ state(comment)
+ state(tokenL)
+ state(lexemeL)
}
- return -code $code -errorinfo $einfo -errorcode $ecode $result
+ return {*}$eopts $result
}
# ::mime::parsetypeaux --
@@ -1345,8 +1341,8 @@
set boundary {}
foreach {k v} $state(params) {
if {$k eq {boundary}} {
- set boundary $v
- }
+ set boundary $v
+ }
append res ";\n $k=\"$v\""
}
@@ -1363,7 +1359,7 @@
}
set boundary "----- =_[string trim [base64 -mode encode -- $key]]"
- set state(boundary) $boundary
+ set state(boundary) $boundary
append res ";\n boundary=\"$boundary\""
}
@@ -1403,17 +1399,17 @@
switch -- $key {
{} {
set result {}
- lappend result MIME-Version $state(version)
+ lappend result MIME-Version $state(version)
foreach lower $state(lowerL) mixed $state(mixedL) {
- foreach value $header($lower) {
- lappend result $mixed $value
- }
- }
- set tencoding [getTransferEncoding $token]
- if {$tencoding ne {}} {
- lappend result Content-Transfer-Encoding $tencoding
- }
- lappend result Content-Type [getContentType $token]
+ foreach value $header($lower) {
+ lappend result $mixed $value
+ }
+ }
+ set tencoding [getTransferEncoding $token]
+ if {$tencoding ne {}} {
+ lappend result Content-Transfer-Encoding $tencoding
+ }
+ lappend result Content-Type [getContentType $token]
return $result
}
@@ -1424,23 +1420,23 @@
default {
set lower [string tolower $key]
- switch $lower {
- content-transfer-encoding {
- return [getTransferEncoding $token]
- }
- content-type {
- return [list [getContentType $token]]
- }
- mime-version {
- return [list $state(version)]
- }
- default {
- if {![info exists header($lower)]} {
- error "key $key not in header"
- }
- return $header($lower)
- }
- }
+ switch $lower {
+ content-transfer-encoding {
+ return [getTransferEncoding $token]
+ }
+ content-type {
+ return [list [getContentType $token]]
+ }
+ mime-version {
+ return [list $state(version)]
+ }
+ default {
+ if {![info exists header($lower)]} {
+ error "key $key not in header"
+ }
+ return $header($lower)
+ }
+ }
}
}
}
@@ -1451,24 +1447,24 @@
upvar 0 $token state
set res {}
if {[set encoding $state(encoding)] eq {}} {
- set encoding [encoding $token]
+ set encoding [encoding $token]
}
if {$encoding ne {}} {
- set res $encoding
+ set res $encoding
}
switch -- $encoding {
- base64
- -
- quoted-printable {
- set converter $encoding
- }
- 7bit - 8bit - binary - {} {
- # Bugfix for [#477088], also [#539952]
- # Go ahead
- }
- default {
- error "Can't handle content encoding \"$encoding\""
- }
+ base64
+ -
+ quoted-printable {
+ set converter $encoding
+ }
+ 7bit - 8bit - binary - {} {
+ # Bugfix for [#477088], also [#539952]
+ # Go ahead
+ }
+ default {
+ error "Can't handle content encoding \"$encoding\""
+ }
}
return $res
}
@@ -1527,33 +1523,33 @@
set result $header($lower)
}
switch -- $options(-mode) {
- append - write {
- if {!$internal} {
- switch -- $lower {
- content-md5
- -
- content-type
- -
- content-transfer-encoding
- -
- mime-version {
- set values [getheader $token $lower]
- if {$value ni $values} {
- error "key $key may not be set"
- }
- }
- default {# Skip key}
- }
- }
- switch -- $options(-mode) {
- append {
- lappend header($lower) $value
- }
- write {
- set header($lower) [list $value]
- }
- }
- }
+ append - write {
+ if {!$internal} {
+ switch -- $lower {
+ content-md5
+ -
+ content-type
+ -
+ content-transfer-encoding
+ -
+ mime-version {
+ set values [getheader $token $lower]
+ if {$value ni $values} {
+ error "key $key may not be set"
+ }
+ }
+ default {# Skip key}
+ }
+ }
+ switch -- $options(-mode) {
+ append {
+ lappend header($lower) $value
+ }
+ write {
+ set header($lower) [list $value]
+ }
+ }
+ }
delete {
unset header($lower)
set state(lowerL) [lreplace $state(lowerL) $x $x]
@@ -1605,7 +1601,6 @@
# is returned.
proc ::mime::getbody {token args} {
- global errorCode errorInfo
# FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1678,9 +1673,7 @@
if {[string length $fragment] > 0} {
uplevel #0 $options(-command) [list data $fragment]
}
- } result]
- set ecode $errorCode
- set einfo $errorInfo
+ } result eopts]
catch {close $fd}
}
@@ -1695,9 +1688,7 @@
set fragment [read $fd $options(-blocksize)]]] > 0} {
uplevel #0 $options(-command) [list data $fragment]
}
- } result]
- set ecode $errorCode
- set einfo $errorInfo
+ } result eopts]
catch {close $fd}
}
@@ -1738,27 +1729,24 @@
if {[string length $fragment] > 0} {
uplevel #0 $options(-command) [list data $fragment]
}
- } result]
- set ecode $errorCode
- set einfo $errorInfo
+ } result eopts]
}
default {
error "Unknown combination \"$state(value)/$state(canonicalP)\""
}
}
+ # Note: we have catched + captured several times eopts until know, but we never used that.
set code [catch {
if {$code} {
uplevel #0 $options(-command) [list error $result]
} else {
uplevel #0 $options(-command) [list end]
}
- } result]
- set ecode $errorCode
- set einfo $errorInfo
+ } result eopts]
if {$code} {
- return -code $code -errorinfo $einfo -errorcode $ecode $result
+ return {*}$eopts $result
}
if {$decode} {
@@ -1847,16 +1835,13 @@
# is being written to the channel.
proc ::mime::copymessage {token channel} {
- global errorCode errorInfo
# FRINK: nocheck
variable $token
upvar 0 $token state
set openP [info exists state(fd)]
- set code [catch {mime::copymessageaux $token $channel} result]
- set ecode $errorCode
- set einfo $errorInfo
+ set code [catch {mime::copymessageaux $token $channel} result eopts]
if {!$openP && [info exists state(fd)]} {
if {![info exists state(root)]} {
@@ -1865,7 +1850,7 @@
unset state(fd)
}
- return -code $code -errorinfo $einfo -errorcode $ecode $result
+ return {*}$eopts $result
}
# ::mime::copymessageaux --
@@ -1889,7 +1874,7 @@
set result {}
foreach {mixed value} [getheader $token] {
- puts $channel "$mixed: $value"
+ puts $channel "$mixed: $value"
}
set boundary $state(boundary) ;# computed by `getheader`
@@ -1976,10 +1961,10 @@
parts {
if {
- ![info exists state(root)]
- &&
- [info exists state(file)]
- } {
+ ![info exists state(root)]
+ &&
+ [info exists state(file)]
+ } {
set state(fd) [open $state(file) RDONLY]
fconfigure $state(fd) -translation binary
}
@@ -2067,20 +2052,13 @@
# The message.
proc ::mime::buildmessage token {
- global errorCode errorInfo
# FRINK: nocheck
variable $token
upvar 0 $token state
set openP [info exists state(fd)]
- set code [catch {mime::buildmessageaux $token} result]
- if {![info exists errorCode]} {
- set ecode {}
- } else {
- set ecode $errorCode
- }
- set einfo $errorInfo
+ set code [catch {mime::buildmessageaux $token} result eopts]
if {!$openP && [info exists state(fd)]} {
if {![info exists state(root)]} {
@@ -2089,19 +2067,19 @@
unset state(fd)
}
- return -code $code -errorinfo $einfo -errorcode $ecode $result
+ return {*}$eopts $result
}
proc ::mime::buildmessageaux token {
- set chan [tcl::chan::memchan]
- chan configure $chan -translation crlf
- copymessageaux $token $chan
- seek $chan 0
- chan configure $chan -translation binary
- set res [read $chan]
- close $chan
- return $res
+ set chan [tcl::chan::memchan]
+ chan configure $chan -translation crlf
+ copymessageaux $token $chan
+ seek $chan 0
+ chan configure $chan -translation binary
+ set res [read $chan]
+ close $chan
+ return $res
}
# ::mime::encoding --
@@ -2241,9 +2219,9 @@
}
}
if {
- [set r [string first \r $line]] < 0
- ||
- $r == {[string length $line] - 1}
+ [set r [string first \r $line]] < 0
+ ||
+ $r == {[string length $line] - 1}
} {
return 1
}
@@ -2326,12 +2304,12 @@
}
if {[catch {
- puts -nonewline $channel [
- string range $state(string) $offset [expr {$offset + $cc - 1}]]
- fileevent $channel writable [
- list mime::scopy $token $channel [
- incr offset $cc] [incr len -$cc] $blocksize]
- } result]
+ puts -nonewline $channel [
+ string range $state(string) $offset [expr {$offset + $cc - 1}]]
+ fileevent $channel writable [
+ list mime::scopy $token $channel [
+ incr offset $cc] [incr len -$cc] $blocksize]
+ } result]
} {
set state(error) $result
set state(doneP) 1
@@ -2361,7 +2339,7 @@
if {$encoded_word} {
# Special processing for encoded words (RFC 2047)
set regexp {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF\x09\x5F\x3F]}
- lappend mapChars { } _
+ lappend mapChars { } _
} else {
set regexp {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]}
}
@@ -2500,8 +2478,6 @@
# specified in the argument.
proc ::mime::parseaddress {string} {
- global errorCode errorInfo
-
variable mime
set token [namespace current]::[incr mime(uid)]
@@ -2509,17 +2485,15 @@
variable $token
upvar 0 $token state
- set code [catch {mime::parseaddressaux $token $string} result]
- set ecode $errorCode
- set einfo $errorInfo
+ set code [catch {mime::parseaddressaux $token $string} result eopts]
foreach name [array names state] {
unset state($name)
}
# FRINK: nocheck
catch {unset $token}
-
- return -code $code -errorinfo $einfo -errorcode $ecode $result
+ #dict set eopts -level 0
+ return {*}$eopts $result
}
# ::mime::parseaddressaux --
@@ -2606,19 +2580,19 @@
set note [string trimleft [string range $note 1 end]]
}
if {
- [string last ) $note]
+ [string last ) $note]
== [set len [expr {[string length $note] - 1}]]
- } {
+ } {
set note [string range $note 0 [expr {$len - 1}]]
}
set friendly $note
}
if {
- $friendly eq {}
- &&
- [set mbox $state(local)] ne {}
- } {
+ $friendly eq {}
+ &&
+ [set mbox $state(local)] ne {}
+ } {
#TODO: this path is not covered by tests
set mbox [string trim $mbox \"]
@@ -2626,10 +2600,10 @@
set friendly $mbox
} elseif {[set friendly [addr_x400 $mbox PN]] ne {}} {
} elseif {
- [set friendly [addr_x400 $mbox S]] ne {}
+ [set friendly [addr_x400 $mbox S]] ne {}
&&
- [set g [addr_x400 $mbox G]] ne {}
- } {
+ [set g [addr_x400 $mbox G]] ne {}
+ } {
set friendly "$g $friendly"
}
@@ -2655,12 +2629,12 @@
}
unset {*}{
- state(input)
- state(glevel)
- state(buffer)
- state(lastC)
- state(tokenL)
- state(lexemeL)
+ state(input)
+ state(glevel)
+ state(buffer)
+ state(lastC)
+ state(tokenL)
+ state(lexemeL)
}
return $result
@@ -2677,7 +2651,6 @@
# Returns 1 if there is another address, and 0 if there is not.
proc ::mime::addr_next {token} {
- global errorCode errorInfo
# FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2686,11 +2659,11 @@
if {$nocomplain} {
unset -nocomplain state($prop)
} else {
- if {[catch {unset state($prop)}]} {set ::errorInfo {}}
+ catch {unset state($prop)}
}
}
- switch -- [set code [catch {mime::addr_specification $token} result]] {
+ switch -- [set code [catch {mime::addr_specification $token} result eopts]] {
0 {
if {!$result} {
return 0
@@ -2729,10 +2702,7 @@
}
default {
- set ecode $errorCode
- set einfo $errorInfo
-
- return -code $code -errorinfo $einfo -errorcode $ecode $result
+ return {*}$eopts $result
}
}
@@ -2799,8 +2769,8 @@
default {
return -code 7 [
- format "unexpected character at beginning (found %s)" \
- $state(buffer)]
+ format "unexpected character at beginning (found %s)" \
+ $state(buffer)]
}
}
@@ -2843,10 +2813,10 @@
LX_END {
set state(memberP) $state(glevel)
if {
- $state(lastC) eq "LX_SEMICOLON"
- &&
- ([incr state(glevel) -1] < 0)
- } {
+ $state(lastC) eq "LX_SEMICOLON"
+ &&
+ ([incr state(glevel) -1] < 0)
+ } {
#TODO: this path is not covered by tests
return -code 7 "extraneous semi-colon"
}
@@ -2988,8 +2958,8 @@
default {
return -code 7 [
- format "expecting colon to terminate route (found %s)" \
- $state(buffer)]
+ format "expecting colon to terminate route (found %s)" \
+ $state(buffer)]
}
}
}
@@ -3022,8 +2992,8 @@
default {
return -code 7 [
- format "expecting sub-domain in domain-part (found %s)" \
- $state(buffer)]
+ format "expecting sub-domain in domain-part (found %s)" \
+ $state(buffer)]
}
}
@@ -3134,8 +3104,8 @@
default {
return -code 7 [
- format "found phrase instead of mailbox (%s%s)" \
- $state(phrase) $state(buffer)]
+ format "found phrase instead of mailbox (%s%s)" \
+ $state(phrase) $state(buffer)]
}
}
}
@@ -3157,7 +3127,7 @@
if {[incr state(glevel)] > 1} {
return -code 7 [
- format "nested groups not allowed (found %s)" $state(phrase)]
+ format "nested groups not allowed (found %s)" $state(phrase)]
}
set state(group) $state(phrase)
@@ -3213,7 +3183,7 @@
default {
return -code 7 [
- format "junk after local@domain (found %s)" $state(buffer)]
+ format "junk after local@domain (found %s)" $state(buffer)]
}
}
}
@@ -3297,7 +3267,7 @@
if {$value eq "-now"} {
set clock [clock seconds]
} elseif {[regexp {^(.*) ([+-])([0-9][0-9])([0-9][0-9])$} $value \
- -> value zone_sign zone_hour zone_min]
+ -> value zone_sign zone_hour zone_min]
} {
set clock [clock scan $value -gmt 1]
if {[info exists zone_min]} {
@@ -3348,7 +3318,7 @@
month {
variable MONTHS_SHORT
return [lindex $MONTHS_SHORT [
- scan [clock format $clock -format %m] %d]]
+ scan [clock format $clock -format %m] %d]]
}
proper {
@@ -3366,10 +3336,10 @@
set wday [lindex $WDAYS_SHORT [clock format $clock -format %w]]
variable MONTHS_SHORT
set mon [lindex $MONTHS_SHORT [
- scan [clock format $clock -format %m] %d]]
+ scan [clock format $clock -format %m] %d]]
return [
- clock format $clock -format "$wday, %d $mon %Y %H:%M:%S $zone"]
+ clock format $clock -format "$wday, %d $mon %Y %H:%M:%S $zone"]
}
rclock {
@@ -3416,16 +3386,16 @@
}
set value [string trim [string range $value 1 end]]
if {(
- [string length $value] != 4)
- ||
- [scan $value %2d%2d h m] != 2
- ||
- $h > 12
- ||
- $m > 59
- ||
- ($h == 12 && $m > 0)
- } {
+ [string length $value] != 4)
+ ||
+ [scan $value %2d%2d h m] != 2
+ ||
+ $h > 12
+ ||
+ $m > 59
+ ||
+ ($h == 12 && $m > 0)
+ } {
error "malformed timezone-specification: $value"
}
set value $s[expr {$h * 60 + $m}]
@@ -3784,8 +3754,8 @@
error "maxlength $options(-maxlength) too short for chosen charset and encoding"
}
if {
- $length + [string length $qp_enc_char] > $maxlength
- } {
+ $length + [string length $qp_enc_char] > $maxlength
+ } {
set length $maxlength
} else {
append encoded_word $qp_enc_char
@@ -3825,7 +3795,7 @@
variable reversemap
if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded \
- - charset method string] != 1
+ - charset method string] != 1
} {
error "malformed word-encoded expression '$encoded'"
}
@@ -3891,7 +3861,7 @@
# non-greedy - perhaps because of the earlier ".*?", sigh.
while {[regexp {(.*?)(=\?(?:[^?]+)\?(?:.)\?(?:[^?]*)\?=)(.*)$} $field \
- ignore prefix encoded field]
+ ignore prefix encoded field]
} {
# don't allow whitespace between encoded words per RFC 2047
if {{} ne $prefix} {
@@ -3918,7 +3888,7 @@
foreach {enc mimeType} $encList {
if {$mimeType eq {}} continue
- set reversemap([string tolower $mimeType]) $enc
+ set reversemap([string tolower $mimeType]) $enc
}
foreach {enc mimeType} $encAliasList {
