Index: openacs-4/packages/acs-tcl/tcl/base64-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/Attic/base64-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/base64-procs.tcl 19 Sep 2003 13:07:38 -0000 1.1
@@ -0,0 +1,323 @@
+# base64.tcl --
+#
+# Encode/Decode base64 for a string
+# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems
+# The decoder was done for exmh by Chris Garrigues
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: base64-procs.tcl,v 1.1 2003/09/19 13:07:38 peterm Exp $
+
+# Version 1.0 implemented Base64_Encode, Bae64_Decode
+# Version 2.0 uses the base64 namespace
+# Version 2.1 fixes various decode bugs and adds options to encode
+# Version 2.2 is much faster, Tcl8.0 compatible
+# Version 2.2.1 bugfixes
+# Version 2.2.2 bugfixes
+
+package require Tcl 8.2
+namespace eval ::base64 {
+ namespace export encode decode
+}
+
+if {![catch {package require Trf 2.0}]} {
+ # Trf is available, so implement the functionality provided here
+ # in terms of calls to Trf for speed.
+
+ # ::base64::encode --
+ #
+ # Base64 encode a given string.
+ #
+ # Arguments:
+ # args ?-maxlen maxlen? ?-wrapchar wrapchar? string
+ #
+ # If maxlen is 0, the output is not wrapped.
+ #
+ # Results:
+ # A Base64 encoded version of $string, wrapped at $maxlen characters
+ # by $wrapchar.
+
+ proc ::base64::encode {args} {
+ # Set the default wrapchar and maximum line length to match the output
+ # of GNU uuencode 4.2. Various RFC's allow for different wrapping
+ # characters and wraplengths, so these may be overridden by command line
+ # options.
+ set wrapchar "\n"
+ set maxlen 60
+
+ if { [llength $args] == 0 } {
+ error "wrong # args: should be \"[lindex [info level 0] 0]\
+ ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
+ }
+
+ set optionStrings [list "-maxlen" "-wrapchar"]
+ for {set i 0} {$i < [llength $args] - 1} {incr i} {
+ set arg [lindex $args $i]
+ set index [lsearch -glob $optionStrings "${arg}*"]
+ if { $index == -1 } {
+ error "unknown option \"$arg\": must be -maxlen or -wrapchar"
+ }
+ incr i
+ if { $i >= [llength $args] - 1 } {
+ error "value for \"$arg\" missing"
+ }
+ set val [lindex $args $i]
+
+ # The name of the variable to assign the value to is extracted
+ # from the list of known options, all of which have an
+ # associated variable of the same name as the option without
+ # a leading "-". The [string range] command is used to strip
+ # of the leading "-" from the name of the option.
+ #
+ # FRINK: nocheck
+ set [string range [lindex $optionStrings $index] 1 end] $val
+ }
+
+ # [string is] requires Tcl8.2; this works with 8.0 too
+ if {[catch {expr {$maxlen % 2}}]} {
+ error "expected integer but got \"$maxlen\""
+ }
+
+ set string [lindex $args end]
+ set result [::base64 -mode encode -- $string]
+ set result [string map [list \n ""] $result]
+
+ if {$maxlen > 0} {
+ set res ""
+ set edge [expr {$maxlen - 1}]
+ while {[string length $result] > $maxlen} {
+ append res [string range $result 0 $edge]$wrapchar
+ set result [string range $result $maxlen end]
+ }
+ if {[string length $result] > 0} {
+ append res $result
+ }
+ set result $res
+ }
+
+ return $result
+ }
+
+ # ::base64::decode --
+ #
+ # Base64 decode a given string.
+ #
+ # Arguments:
+ # string The string to decode. Characters not in the base64
+ # alphabet are ignored (e.g., newlines)
+ #
+ # Results:
+ # The decoded value.
+
+ proc ::base64::decode {string} {
+ ::base64 -mode decode -- $string
+ }
+
+} else {
+ # Without Trf use a pure tcl implementation
+
+ namespace eval base64 {
+ variable base64 {}
+ variable base64_en {}
+
+ # We create the auxiliary array base64_tmp, it will be unset later.
+
+ set i 0
+ foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
+ a b c d e f g h i j k l m n o p q r s t u v w x y z \
+ 0 1 2 3 4 5 6 7 8 9 + /} {
+ set base64_tmp($char) $i
+ lappend base64_en $char
+ incr i
+ }
+
+ #
+ # Create base64 as list: to code for instance C<->3, specify
+ # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded
+ # ascii chars get a {}. we later use the fact that lindex on a
+ # non-existing index returns {}, and that [expr {} < 0] is true
+ #
+
+ # the last ascii char is 'z'
+ scan z %c len
+ for {set i 0} {$i <= $len} {incr i} {
+ set char [format %c $i]
+ set val {}
+ if {[info exists base64_tmp($char)]} {
+ set val $base64_tmp($char)
+ } else {
+ set val {}
+ }
+ lappend base64 $val
+ }
+
+ # code the character "=" as -1; used to signal end of message
+ scan = %c i
+ set base64 [lreplace $base64 $i $i -1]
+
+ # remove unneeded variables
+ unset base64_tmp i char len val
+
+ namespace export encode decode
+ }
+
+ # ::base64::encode --
+ #
+ # Base64 encode a given string.
+ #
+ # Arguments:
+ # args ?-maxlen maxlen? ?-wrapchar wrapchar? string
+ #
+ # If maxlen is 0, the output is not wrapped.
+ #
+ # Results:
+ # A Base64 encoded version of $string, wrapped at $maxlen characters
+ # by $wrapchar.
+
+ proc ::base64::encode {args} {
+ set base64_en $::base64::base64_en
+
+ # Set the default wrapchar and maximum line length to match the output
+ # of GNU uuencode 4.2. Various RFC's allow for different wrapping
+ # characters and wraplengths, so these may be overridden by command line
+ # options.
+ set wrapchar "\n"
+ set maxlen 60
+
+ if { [llength $args] == 0 } {
+ error "wrong # args: should be \"[lindex [info level 0] 0]\
+ ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
+ }
+
+ set optionStrings [list "-maxlen" "-wrapchar"]
+ for {set i 0} {$i < [llength $args] - 1} {incr i} {
+ set arg [lindex $args $i]
+ set index [lsearch -glob $optionStrings "${arg}*"]
+ if { $index == -1 } {
+ error "unknown option \"$arg\": must be -maxlen or -wrapchar"
+ }
+ incr i
+ if { $i >= [llength $args] - 1 } {
+ error "value for \"$arg\" missing"
+ }
+ set val [lindex $args $i]
+
+ # The name of the variable to assign the value to is extracted
+ # from the list of known options, all of which have an
+ # associated variable of the same name as the option without
+ # a leading "-". The [string range] command is used to strip
+ # of the leading "-" from the name of the option.
+ #
+ # FRINK: nocheck
+ set [string range [lindex $optionStrings $index] 1 end] $val
+ }
+
+ # [string is] requires Tcl8.2; this works with 8.0 too
+ if {[catch {expr {$maxlen % 2}}]} {
+ error "expected integer but got \"$maxlen\""
+ }
+
+ set string [lindex $args end]
+
+ set result {}
+ set state 0
+ set length 0
+
+
+ # Process the input bytes 3-by-3
+
+ binary scan $string c* X
+ foreach {x y z} $X {
+ # Do the line length check before appending so that we don't get an
+ # extra newline if the output is a multiple of $maxlen chars long.
+ if {$maxlen && $length >= $maxlen} {
+ append result $wrapchar
+ set length 0
+ }
+
+ append result [lindex $base64_en [expr {($x >>2) & 0x3F}]]
+ if {$y != {}} {
+ append result [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]]
+ if {$z != {}} {
+ append result \
+ [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]]
+ append result [lindex $base64_en [expr {($z & 0x3F)}]]
+ } else {
+ set state 2
+ break
+ }
+ } else {
+ set state 1
+ break
+ }
+ incr length 4
+ }
+ if {$state == 1} {
+ append result [lindex $base64_en [expr {(($x << 4) & 0x30)}]]==
+ } elseif {$state == 2} {
+ append result [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]=
+ }
+ return $result
+ }
+
+ # ::base64::decode --
+ #
+ # Base64 decode a given string.
+ #
+ # Arguments:
+ # string The string to decode. Characters not in the base64
+ # alphabet are ignored (e.g., newlines)
+ #
+ # Results:
+ # The decoded value.
+
+ proc ::base64::decode {string} {
+ if {[string length $string] == 0} {return ""}
+
+ set base64 $::base64::base64
+
+ binary scan $string c* X
+ foreach x $X {
+ set bits [lindex $base64 $x]
+ if {$bits >= 0} {
+ if {[llength [lappend nums $bits]] == 4} {
+ foreach {v w z y} $nums break
+ set a [expr {($v << 2) | ($w >> 4)}]
+ set b [expr {(($w & 0xF) << 4) | ($z >> 2)}]
+ set c [expr {(($z & 0x3) << 6) | $y}]
+ append output [binary format ccc $a $b $c]
+ set nums {}
+ }
+ } elseif {$bits == -1} {
+ # = indicates end of data. Output whatever chars are left.
+ # The encoding algorithm dictates that we can only have 1 or 2
+ # padding characters. If x=={}, we have 12 bits of input
+ # (enough for 1 8-bit output). If x!={}, we have 18 bits of
+ # input (enough for 2 8-bit outputs).
+
+ foreach {v w z} $nums break
+ set a [expr {($v << 2) | (($w & 0x30) >> 4)}]
+
+ if {$z == {}} {
+ append output [binary format c $a ]
+ } else {
+ set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}]
+ append output [binary format cc $a $b]
+ }
+ break
+ } else {
+ # RFC 2045 says that line breaks and other characters not part
+ # of the Base64 alphabet must be ignored, and that the decoder
+ # can optionally emit a warning or reject the message. We opt
+ # not to do so, but to just ignore the character.
+ continue
+ }
+ }
+ return $output
+ }
+}
+
+package provide base64 2.2.2
+
Fisheye: Tag 1.3 refers to a dead (removed) revision in file `openacs-4/packages/acs-tcl/tcl/base64.tcl'.
Fisheye: No comparison available. Pass `N' to diff?
Index: openacs-4/packages/acs-tcl/tcl/md5-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/Attic/md5-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/md5-procs.tcl 19 Sep 2003 13:07:38 -0000 1.1
@@ -0,0 +1,453 @@
+##################################################
+#
+# md5.tcl - MD5 in Tcl
+# Author: Don Libes <libes@nist.gov>, July 1999
+# Version 1.2.0
+#
+# MD5 defined by RFC 1321, "The MD5 Message-Digest Algorithm"
+# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
+#
+# Most of the comments below come right out of RFC 1321; That's why
+# they have such peculiar numbers. In addition, I have retained
+# original syntax, bugs in documentation (yes, really), etc. from the
+# RFC. All remaining bugs are mine.
+#
+# HMAC implementation by D. J. Hagberg <dhagberg@millibits.com> and
+# is based on C code in RFC 2104.
+#
+# For more info, see: http://expect.nist.gov/md5pure
+#
+# - Don
+#
+# Modified by Miguel Sofer to use inlines and simple variables
+##################################################
+
+package require Tcl 8.2
+namespace eval ::md5 {
+}
+
+if {![catch {package require Trf 2.0}] && ![catch {::md5 -- test}]} {
+ # Trf is available, so implement the functionality provided here
+ # in terms of calls to Trf for speed.
+
+ proc ::md5::md5 {msg} {
+ string tolower [::hex -mode encode -- [::md5 -- $msg]]
+ }
+
+ # hmac: hash for message authentication
+
+ # MD5 of Trf and MD5 as defined by this package have slightly
+ # different results. Trf returns the digest in binary, here we get
+ # it as hex-string. In the computation of the HMAC the latter
+ # requires back conversion into binary in some places. With Trf we
+ # can use omit these.
+
+ proc ::md5::hmac {key text} {
+ # if key is longer than 64 bytes, reset it to MD5(key). If shorter,
+ # pad it out with null (\x00) chars.
+ set keyLen [string length $key]
+ if {$keyLen > 64} {
+ #old: set key [binary format H32 [md5 $key]]
+ set key [::md5 -- $key]
+ set keyLen [string length $key]
+ }
+
+ # ensure the key is padded out to 64 chars with nulls.
+ set padLen [expr {64 - $keyLen}]
+ append key [binary format "a$padLen" {}]
+
+ # Split apart the key into a list of 16 little-endian words
+ binary scan $key i16 blocks
+
+ # XOR key with ipad and opad values
+ set k_ipad {}
+ set k_opad {}
+ foreach i $blocks {
+ append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
+ append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
+ }
+
+ # Perform inner md5, appending its results to the outer key
+ append k_ipad $text
+ #old: append k_opad [binary format H* [md5 $k_ipad]]
+ append k_opad [::md5 -- $k_ipad]
+
+ # Perform outer md5
+ #old: md5 $k_opad
+ string tolower [::hex -mode encode -- [::md5 -- $k_opad]]
+ }
+
+} else {
+ # Without Trf use the all-tcl implementation by Don Libes.
+
+ # T will be inlined after the definition of md5body
+
+ # test md5
+ #
+ # This proc is not necessary during runtime and may be omitted if you
+ # are simply inserting this file into a production program.
+ #
+ proc ::md5::test {} {
+ foreach {msg expected} {
+ ""
+ "d41d8cd98f00b204e9800998ecf8427e"
+ "a"
+ "0cc175b9c0f1b6a831c399e269772661"
+ "abc"
+ "900150983cd24fb0d6963f7d28e17f72"
+ "message digest"
+ "f96b697d7cb7938d525a2f31aaf161d0"
+ "abcdefghijklmnopqrstuvwxyz"
+ "c3fcd3d76192e4007dfb496cca67e13b"
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ "d174ab98d277d9f5a5611c2c9f419d9f"
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "57edf4a22be3c955ac49da2e2107b67a"
+ } {
+ puts "testing: md5 \"$msg\""
+ set computed [md5 $msg]
+ puts "expected: $expected"
+ puts "computed: $computed"
+ if {0 != [string compare $computed $expected]} {
+ puts "FAILED"
+ } else {
+ puts "SUCCEEDED"
+ }
+ }
+ }
+
+ # time md5
+ #
+ # This proc is not necessary during runtime and may be omitted if you
+ # are simply inserting this file into a production program.
+ #
+ proc ::md5::time {} {
+ foreach len {10 50 100 500 1000 5000 10000} {
+ set time [::time {md5 [format %$len.0s ""]} 100]
+ set msec [lindex $time 0]
+ puts "input length $len: [expr {$msec/1000}] milliseconds per interation"
+ }
+ }
+
+ #
+ # We just define the body of md5pure::md5 here; later we
+ # regsub to inline a few function calls for speed
+ #
+
+ set ::md5::md5body {
+
+ #
+ # 3.1 Step 1. Append Padding Bits
+ #
+
+ set msgLen [string length $msg]
+
+ set padLen [expr {56 - $msgLen%64}]
+ if {$msgLen % 64 > 56} {
+ incr padLen 64
+ }
+
+ # pad even if no padding required
+ if {$padLen == 0} {
+ incr padLen 64
+ }
+
+ # append single 1b followed by 0b's
+ append msg [binary format "a$padLen" \200]
+
+ #
+ # 3.2 Step 2. Append Length
+ #
+
+ # RFC doesn't say whether to use little- or big-endian
+ # code demonstrates little-endian
+ # This step limits our input to size 2^32b or 2^24B
+ append msg [binary format "i1i1" [expr {8*$msgLen}] 0]
+
+ #
+ # 3.3 Step 3. Initialize MD Buffer
+ #
+
+ set A [expr 0x67452301]
+ set B [expr 0xefcdab89]
+ set C [expr 0x98badcfe]
+ set D [expr 0x10325476]
+
+ #
+ # 3.4 Step 4. Process Message in 16-Word Blocks
+ #
+
+ # process each 16-word block
+ # RFC doesn't say whether to use little- or big-endian
+ # code says little-endian
+ binary scan $msg i* blocks
+
+ # loop over the message taking 16 blocks at a time
+
+ foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {
+
+ # Save A as AA, B as BB, C as CC, and D as DD.
+ set AA $A
+ set BB $B
+ set CC $C
+ set DD $D
+
+ # Round 1.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s).
+ # [ABCD 0 7 1] [DABC 1 12 2] [CDAB 2 17 3] [BCDA 3 22 4]
+ set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X0 + $T01}] 7]}]
+ set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X1 + $T02}] 12]}]
+ set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X2 + $T03}] 17]}]
+ set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X3 + $T04}] 22]}]
+ # [ABCD 4 7 5] [DABC 5 12 6] [CDAB 6 17 7] [BCDA 7 22 8]
+ set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X4 + $T05}] 7]}]
+ set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X5 + $T06}] 12]}]
+ set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X6 + $T07}] 17]}]
+ set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X7 + $T08}] 22]}]
+ # [ABCD 8 7 9] [DABC 9 12 10] [CDAB 10 17 11] [BCDA 11 22 12]
+ set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X8 + $T09}] 7]}]
+ set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X9 + $T10}] 12]}]
+ set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X10 + $T11}] 17]}]
+ set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X11 + $T12}] 22]}]
+ # [ABCD 12 7 13] [DABC 13 12 14] [CDAB 14 17 15] [BCDA 15 22 16]
+ set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X12 + $T13}] 7]}]
+ set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X13 + $T14}] 12]}]
+ set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X14 + $T15}] 17]}]
+ set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X15 + $T16}] 22]}]
+
+ # Round 2.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s).
+ # Do the following 16 operations.
+ # [ABCD 1 5 17] [DABC 6 9 18] [CDAB 11 14 19] [BCDA 0 20 20]
+ set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X1 + $T17}] 5]}]
+ set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X6 + $T18}] 9]}]
+ set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X11 + $T19}] 14]}]
+ set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X0 + $T20}] 20]}]
+ # [ABCD 5 5 21] [DABC 10 9 22] [CDAB 15 14 23] [BCDA 4 20 24]
+ set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X5 + $T21}] 5]}]
+ set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X10 + $T22}] 9]}]
+ set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X15 + $T23}] 14]}]
+ set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X4 + $T24}] 20]}]
+ # [ABCD 9 5 25] [DABC 14 9 26] [CDAB 3 14 27] [BCDA 8 20 28]
+ set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X9 + $T25}] 5]}]
+ set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X14 + $T26}] 9]}]
+ set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X3 + $T27}] 14]}]
+ set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X8 + $T28}] 20]}]
+ # [ABCD 13 5 29] [DABC 2 9 30] [CDAB 7 14 31] [BCDA 12 20 32]
+ set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X13 + $T29}] 5]}]
+ set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X2 + $T30}] 9]}]
+ set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X7 + $T31}] 14]}]
+ set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X12 + $T32}] 20]}]
+
+ # Round 3.
+ # Let [abcd k s t] [sic] denote the operation
+ # a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s).
+ # Do the following 16 operations.
+ # [ABCD 5 4 33] [DABC 8 11 34] [CDAB 11 16 35] [BCDA 14 23 36]
+ set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X5 + $T33}] 4]}]
+ set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X8 + $T34}] 11]}]
+ set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X11 + $T35}] 16]}]
+ set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X14 + $T36}] 23]}]
+ # [ABCD 1 4 37] [DABC 4 11 38] [CDAB 7 16 39] [BCDA 10 23 40]
+ set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X1 + $T37}] 4]}]
+ set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X4 + $T38}] 11]}]
+ set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X7 + $T39}] 16]}]
+ set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X10 + $T40}] 23]}]
+ # [ABCD 13 4 41] [DABC 0 11 42] [CDAB 3 16 43] [BCDA 6 23 44]
+ set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X13 + $T41}] 4]}]
+ set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X0 + $T42}] 11]}]
+ set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X3 + $T43}] 16]}]
+ set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X6 + $T44}] 23]}]
+ # [ABCD 9 4 45] [DABC 12 11 46] [CDAB 15 16 47] [BCDA 2 23 48]
+ set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X9 + $T45}] 4]}]
+ set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X12 + $T46}] 11]}]
+ set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X15 + $T47}] 16]}]
+ set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X2 + $T48}] 23]}]
+
+ # Round 4.
+ # Let [abcd k s t] [sic] denote the operation
+ # a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s).
+ # Do the following 16 operations.
+ # [ABCD 0 6 49] [DABC 7 10 50] [CDAB 14 15 51] [BCDA 5 21 52]
+ set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X0 + $T49}] 6]}]
+ set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X7 + $T50}] 10]}]
+ set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X14 + $T51}] 15]}]
+ set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X5 + $T52}] 21]}]
+ # [ABCD 12 6 53] [DABC 3 10 54] [CDAB 10 15 55] [BCDA 1 21 56]
+ set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X12 + $T53}] 6]}]
+ set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X3 + $T54}] 10]}]
+ set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X10 + $T55}] 15]}]
+ set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X1 + $T56}] 21]}]
+ # [ABCD 8 6 57] [DABC 15 10 58] [CDAB 6 15 59] [BCDA 13 21 60]
+ set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X8 + $T57}] 6]}]
+ set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X15 + $T58}] 10]}]
+ set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X6 + $T59}] 15]}]
+ set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X13 + $T60}] 21]}]
+ # [ABCD 4 6 61] [DABC 11 10 62] [CDAB 2 15 63] [BCDA 9 21 64]
+ set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X4 + $T61}] 6]}]
+ set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X11 + $T62}] 10]}]
+ set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X2 + $T63}] 15]}]
+ set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X9 + $T64}] 21]}]
+
+ # Then perform the following additions. (That is increment each
+ # of the four registers by the value it had before this block
+ # was started.)
+ incr A $AA
+ incr B $BB
+ incr C $CC
+ incr D $DD
+ }
+ # 3.5 Step 5. Output
+
+ # ... begin with the low-order byte of A, and end with the high-order byte
+ # of D.
+
+ return [bytes $A][bytes $B][bytes $C][bytes $D]
+ }
+
+ #
+ # Here we inline/regsub the functions F, G, H, I and <<<
+ #
+
+ namespace eval ::md5 {
+ #proc md5pure::F {x y z} {expr {(($x & $y) | ((~$x) & $z))}}
+ regsub -all -- {\[ *F +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \2) | ((~\1) \& \3))} md5body
+
+ #proc md5pure::G {x y z} {expr {(($x & $z) | ($y & (~$z)))}}
+ regsub -all -- {\[ *G +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \3) | (\2 \& (~\3)))} md5body
+
+ #proc md5pure::H {x y z} {expr {$x ^ $y ^ $z}}
+ regsub -all -- {\[ *H +(\$.) +(\$.) +(\$.) *\]} $md5body {(\1 ^ \2 ^ \3)} md5body
+
+ #proc md5pure::I {x y z} {expr {$y ^ ($x | (~$z))}}
+ regsub -all -- {\[ *I +(\$.) +(\$.) +(\$.) *\]} $md5body {(\2 ^ (\1 | (~\3)))} md5body
+
+ # bitwise left-rotate
+ if {0} {
+ proc md5pure::<<< {x i} {
+ # This works by bitwise-ORing together right piece and left
+ # piece so that the (original) right piece becomes the left
+ # piece and vice versa.
+ #
+ # The (original) right piece is a simple left shift.
+ # The (original) left piece should be a simple right shift
+ # but Tcl does sign extension on right shifts so we
+ # shift it 1 bit, mask off the sign, and finally shift
+ # it the rest of the way.
+
+ # expr {($x << $i) | ((($x >> 1) & 0x7fffffff) >> (31-$i))}
+
+ #
+ # New version, faster when inlining
+ # We replace inline (computing at compile time):
+ # R$i -> (32 - $i)
+ # S$i -> (0x7fffffff >> (31-$i))
+ #
+
+ expr { ($x << $i) | (($x >> R$i) & S$i)}
+ }
+ }
+ # inline <<<
+ regsub -all -- {\[ *<<< +\[ *expr +({[^\}]*})\] +([0-9]+) *\]} $md5body {(([set x [expr \1]] << \2) | (($x >> R\2) \& S\2))} md5body
+
+ # now replace the R and S
+ set map {}
+ foreach i {
+ 7 12 17 22
+ 5 9 14 20
+ 4 11 16 23
+ 6 10 15 21
+ } {
+ lappend map R$i [expr {32 - $i}] S$i [expr {0x7fffffff >> (31-$i)}]
+ }
+
+ # inline the values of T
+ foreach \
+ tName {
+ T01 T02 T03 T04 T05 T06 T07 T08 T09 T10
+ T11 T12 T13 T14 T15 T16 T17 T18 T19 T20
+ T21 T22 T23 T24 T25 T26 T27 T28 T29 T30
+ T31 T32 T33 T34 T35 T36 T37 T38 T39 T40
+ T41 T42 T43 T44 T45 T46 T47 T48 T49 T50
+ T51 T52 T53 T54 T55 T56 T57 T58 T59 T60
+ T61 T62 T63 T64 } \
+ tVal {
+ 0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee
+ 0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501
+ 0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be
+ 0x6b901122 0xfd987193 0xa679438e 0x49b40821
+
+ 0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa
+ 0xd62f105d 0x2441453 0xd8a1e681 0xe7d3fbc8
+ 0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed
+ 0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a
+
+ 0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c
+ 0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70
+ 0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05
+ 0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665
+
+ 0xf4292244 0x432aff97 0xab9423a7 0xfc93a039
+ 0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1
+ 0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1
+ 0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391
+ } {
+ lappend map \$$tName $tVal
+ }
+ set md5body [string map $map $md5body]
+
+
+ # Finally, define the proc
+ proc md5 {msg} $md5body
+
+ # unset auxiliary variables
+ unset md5body tName tVal map
+ }
+
+ proc ::md5::byte0 {i} {expr {0xff & $i}}
+ proc ::md5::byte1 {i} {expr {(0xff00 & $i) >> 8}}
+ proc ::md5::byte2 {i} {expr {(0xff0000 & $i) >> 16}}
+ proc ::md5::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}}
+
+ proc ::md5::bytes {i} {
+ format %0.2x%0.2x%0.2x%0.2x [byte0 $i] [byte1 $i] [byte2 $i] [byte3 $i]
+ }
+
+ # hmac: hash for message authentication
+ proc ::md5::hmac {key text} {
+ # if key is longer than 64 bytes, reset it to MD5(key). If shorter,
+ # pad it out with null (\x00) chars.
+ set keyLen [string length $key]
+ if {$keyLen > 64} {
+ set key [binary format H32 [md5 $key]]
+ set keyLen [string length $key]
+ }
+
+ # ensure the key is padded out to 64 chars with nulls.
+ set padLen [expr {64 - $keyLen}]
+ append key [binary format "a$padLen" {}]
+
+ # Split apart the key into a list of 16 little-endian words
+ binary scan $key i16 blocks
+
+ # XOR key with ipad and opad values
+ set k_ipad {}
+ set k_opad {}
+ foreach i $blocks {
+ append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
+ append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
+ }
+
+ # Perform inner md5, appending its results to the outer key
+ append k_ipad $text
+ append k_opad [binary format H* [md5 $k_ipad]]
+
+ # Perform outer md5
+ md5 $k_opad
+ }
+}
+
+package provide md5 1.4.3
+
Fisheye: Tag 1.3 refers to a dead (removed) revision in file `openacs-4/packages/acs-tcl/tcl/md5.tcl'.
Fisheye: No comparison available. Pass `N' to diff?
Index: openacs-4/packages/acs-tcl/tcl/mime-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/Attic/mime-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/mime-procs.tcl 19 Sep 2003 13:07:38 -0000 1.1
@@ -0,0 +1,3585 @@
+# mime.tcl - MIME body parts
+#
+# (c) 1999-2000 Marshall T. Rose
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's
+# unpublished package of 1999.
+#
+
+# new string features and inline scan are used, requiring 8.3.
+package require Tcl 8.3
+
+package provide mime 1.3.3
+
+if {[catch {package require Trf 2.0}]} {
+
+ # Fall-back to tcl-based procedures of base64 and quoted-printable encoders
+ # Warning!
+ # These are a fragile emulations of the more general calling sequence
+ # that appears to work with this code here.
+
+ package require base64 2.0
+ package require md5 1.0
+
+ # Create these commands in the mime namespace so that they
+ # won't collide with things at the global namespace level
+
+ namespace eval ::mime {
+ proc base64 {-mode what -- chunk} {
+ return [base64::$what $chunk]
+ }
+ proc quoted-printable {-mode what -- chunk} {
+ return [mime::qp_$what $chunk]
+ }
+ proc md5 {-- string} {
+ return [md5::md5 $string]
+ }
+ proc unstack {channel} {
+ # do nothing
+ return
+ }
+ }
+}
+
+#
+# state variables:
+#
+# canonicalP: input is in its canonical form
+# content: type/subtype
+# params: seralized array of key/value pairs (keys are lower-case)
+# encoding: transfer encoding
+# version: MIME-version
+# header: serialized array of key/value pairs (keys are lower-case)
+# lowerL: list of header keys, lower-case
+# mixedL: list of header keys, mixed-case
+# value: either "file", "parts", or "string"
+#
+# file: input file
+# fd: cached file-descriptor, typically for root
+# root: token for top-level part, for (distant) subordinates
+# offset: number of octets from beginning of file/string
+# count: length in octets of (encoded) content
+#
+# parts: list of bodies (tokens)
+#
+# string: input string
+#
+# cid: last child-id assigned
+#
+
+
+namespace eval ::mime {
+ variable mime
+ array set mime { uid 0 cid 0 }
+
+# 822 lexemes
+ variable addrtokenL [list ";" "," \
+ "<" ">" \
+ ":" "." \
+ "(" ")" \
+ "@" "\"" \
+ "\[" "\]" \
+ "\\"]
+ variable addrlexemeL [list LX_SEMICOLON LX_COMMA \
+ LX_LBRACKET LX_RBRACKET \
+ LX_COLON LX_DOT \
+ LX_LPAREN LX_RPAREN \
+ LX_ATSIGN LX_QUOTE \
+ LX_LSQUARE LX_RSQUARE \
+ LX_QUOTE]
+
+# 2045 lexemes
+ variable typetokenL [list ";" "," \
+ "<" ">" \
+ ":" "?" \
+ "(" ")" \
+ "@" "\"" \
+ "\[" "\]" \
+ "=" "/" \
+ "\\"]
+ variable typelexemeL [list LX_SEMICOLON LX_COMMA \
+ LX_LBRACKET LX_RBRACKET \
+ LX_COLON LX_QUESTION \
+ LX_LPAREN LX_RPAREN \
+ LX_ATSIGN LX_QUOTE \
+ LX_LSQUARE LX_RSQUARE \
+ LX_EQUALS LX_SOLIDUS \
+ LX_QUOTE]
+
+ set encList [list \
+ ascii US-ASCII \
+ big5 Big5 \
+ cp1250 "" \
+ cp1251 "" \
+ cp1252 "" \
+ cp1253 "" \
+ cp1254 "" \
+ cp1255 "" \
+ cp1256 "" \
+ cp1257 "" \
+ cp1258 "" \
+ cp437 "" \
+ cp737 "" \
+ cp775 "" \
+ cp850 "" \
+ cp852 "" \
+ cp855 "" \
+ cp857 "" \
+ cp860 "" \
+ cp861 "" \
+ cp862 "" \
+ cp863 "" \
+ cp864 "" \
+ cp865 "" \
+ cp866 "" \
+ cp869 "" \
+ cp874 "" \
+ cp932 "" \
+ cp936 "" \
+ cp949 "" \
+ cp950 "" \
+ dingbats "" \
+ euc-cn EUC-CN \
+ euc-jp EUC-JP \
+ euc-kr EUC-KR \
+ gb12345 GB12345 \
+ gb1988 GB1988 \
+ gb2312 GB2312 \
+ iso2022 ISO-2022 \
+ iso2022-jp ISO-2022-JP \
+ iso2022-kr ISO-2022-KR \
+ iso8859-1 ISO-8859-1 \
+ iso8859-2 ISO-8859-2 \
+ iso8859-3 ISO-8859-3 \
+ iso8859-4 ISO-8859-4 \
+ iso8859-5 ISO-8859-5 \
+ iso8859-6 ISO-8859-6 \
+ iso8859-7 ISO-8859-7 \
+ iso8859-8 ISO-8859-8 \
+ iso8859-9 ISO-8859-9 \
+ iso8859-15 ISO-8859-15 \
+ jis0201 "" \
+ jis0208 "" \
+ jis0212 "" \
+ koi8-r KOI8-R \
+ ksc5601 "" \
+ macCentEuro "" \
+ macCroatian "" \
+ macCyrillic "" \
+ macDingbats "" \
+ macGreek "" \
+ macIceland "" \
+ macJapan "" \
+ macRoman "" \
+ macRomania "" \
+ macThai "" \
+ macTurkish "" \
+ macUkraine "" \
+ shiftjis Shift_JIS \
+ symbol "" \
+ unicode "" \
+ utf-8 ""]
+
+ variable encodings
+ array set encodings $encList
+ variable reversemap
+ foreach {enc mimeType} $encList {
+ if {$mimeType != ""} {
+ set reversemap([string tolower $mimeType]) $enc
+ }
+ }
+
+ namespace export initialize finalize getproperty \
+ getheader setheader \
+ getbody \
+ copymessage \
+ mapencoding \
+ reversemapencoding \
+ parseaddress \
+ parsedatetime \
+ uniqueID
+}
+
+# ::mime::initialize --
+#
+# Creates a MIME part, and returnes the MIME token for that part.
+#
+# Arguments:
+# args Args can be any one of the following:
+# ?-canonical type/subtype
+# ?-param {key value}?...
+# ?-encoding value?
+# ?-header {key value}?... ?
+# (-file name | -string value | -parts {token1 ... tokenN})
+#
+# If the -canonical option is present, then the body is in
+# canonical (raw) form and is found by consulting either the -file,
+# -string, or -part option.
+#
+# In addition, both the -param and -header options may occur zero
+# or more times to specify "Content-Type" parameters (e.g.,
+# "charset") and header keyword/values (e.g.,
+# "Content-Disposition"), respectively.
+#
+# Also, -encoding, if present, specifies the
+# "Content-Transfer-Encoding" when copying the body.
+#
+# If the -canonical option is not present, then the MIME part
+# contained in either the -file or the -string option is parsed,
+# dynamically generating subordinates as appropriate.
+#
+# Results:
+# An initialized mime token.
+
+proc ::mime::initialize {args} {
+ global errorCode errorInfo
+
+ variable mime
+
+ set token [namespace current]::[incr mime(uid)]
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[set code [catch { eval [list mime::initializeaux $token] $args } \
+ result]]} {
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ catch { mime::finalize $token -subordinates dynamic }
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+ }
+
+ return $token
+}
+
+# ::mime::initializeaux --
+#
+# Configures the MIME token created in mime::initialize based on
+# the arguments that mime::initialize supports.
+#
+# Arguments:
+# token The MIME token to configure.
+# args Args can be any one of the following:
+# ?-canonical type/subtype
+# ?-param {key value}?...
+# ?-encoding value?
+# ?-header {key value}?... ?
+# (-file name | -string value | -parts {token1 ... tokenN})
+#
+# Results:
+# 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
+
+ array set params [set state(params) ""]
+ set state(encoding) ""
+ set state(version) "1.0"
+
+ set state(header) ""
+ set state(lowerL) ""
+ set state(mixedL) ""
+
+ set state(cid) 0
+
+ set argc [llength $args]
+ for {set argx 0} {$argx < $argc} {incr argx} {
+ set option [lindex $args $argx]
+ if {[incr argx] >= $argc} {
+ error "missing argument to $option"
+ }
+ set value [lindex $args $argx]
+
+ switch -- $option {
+ -canonical {
+ set state(content) [string tolower $value]
+ }
+
+ -param {
+ if {[llength $value] != 2} {
+ error "-param expects a key and a value, not $value"
+ }
+ set lower [string tolower [set mixed [lindex $value 0]]]
+ if {[info exists params($lower)]} {
+ error "the $mixed parameter may be specified at most once"
+ }
+
+ set params($lower) [lindex $value 1]
+ set state(params) [array get params]
+ }
+
+ -encoding {
+ switch -- [set state(encoding) [string tolower $value]] {
+ 7bit - 8bit - binary - quoted-printable - base64 {
+ }
+
+ default {
+ error "unknown value for -encoding $state(encoding)"
+ }
+ }
+ }
+
+ -header {
+ if {[llength $value] != 2} {
+ error "-header expects a key and a value, not $value"
+ }
+ set lower [string tolower [set mixed [lindex $value 0]]]
+ if {![string compare $lower content-type]} {
+ error "use -canonical instead of -header $value"
+ }
+ if {![string compare $lower content-transfer-encoding]} {
+ error "use -encoding instead of -header $value"
+ }
+ if {(![string compare $lower content-md5]) \
+ || (![string compare $lower mime-version])} {
+ error "don't go there..."
+ }
+ if {[lsearch -exact $state(lowerL) $lower] < 0} {
+ lappend state(lowerL) $lower
+ lappend state(mixedL) $mixed
+ }
+
+ array set header $state(header)
+ lappend header($lower) [lindex $value 1]
+ set state(header) [array get header]
+ }
+
+ -file {
+ set state(file) $value
+ }
+
+ -parts {
+ set state(parts) $value
+ }
+
+ -string {
+ set state(string) $value
+
+ set state(lines) [split $value "\n"]
+ set state(lines.count) [llength $state(lines)]
+ set state(lines.current) 0
+ }
+
+ -root {
+ # the following are internal options
+
+ set state(root) $value
+ }
+
+ -offset {
+ set state(offset) $value
+ }
+
+ -count {
+ set state(count) $value
+ }
+
+ -lineslist {
+ set state(lines) $value
+ set state(lines.count) [llength $state(lines)]
+ set state(lines.current) 0
+ #state(string) is needed, but will be built when required
+ set state(string) ""
+ }
+
+ default {
+ error "unknown option $option"
+ }
+ }
+ }
+
+ #We only want one of -file, -parts or -string:
+ set valueN 0
+ foreach value [list file parts string] {
+ if {[info exists state($value)]} {
+ set state(value) $value
+ incr valueN
+ }
+ }
+ if {$valueN != 1 && ![info exists state(lines)]} {
+ error "specify exactly one of -file, -parts, or -string"
+ }
+
+ if {[set state(canonicalP) [info exists state(content)]]} {
+ switch -- $state(value) {
+ file {
+ set state(offset) 0
+ }
+
+ parts {
+ switch -glob -- $state(content) {
+ text/*
+ -
+ image/*
+ -
+ audio/*
+ -
+ video/* {
+ error "-canonical $state(content) and -parts do not mix"
+ }
+
+ default {
+ if {[string compare $state(encoding) ""]} {
+ error "-encoding and -parts do not mix"
+ }
+ }
+ }
+ }
+ default {# Go ahead}
+ }
+
+ if {[lsearch -exact $state(lowerL) content-id] < 0} {
+ lappend state(lowerL) content-id
+ lappend state(mixedL) Content-ID
+
+ array set header $state(header)
+ lappend header(content-id) [uniqueID]
+ set state(header) [array get header]
+ }
+
+ set state(version) 1.0
+
+ return
+ }
+
+ if {[string compare $state(params) ""]} {
+ error "-param requires -canonical"
+ }
+ if {[string compare $state(encoding) ""]} {
+ error "-encoding requires -canonical"
+ }
+ if {[string compare $state(header) ""]} {
+ error "-header requires -canonical"
+ }
+ if {[info exists state(parts)]} {
+ error "-parts requires -canonical"
+ }
+
+ if {[set fileP [info exists state(file)]]} {
+ if {[set openP [info exists state(root)]]} {
+ # FRINK: nocheck
+ variable $state(root)
+ upvar 0 $state(root) root
+
+ set state(fd) $root(fd)
+ } else {
+ set state(root) $token
+ set state(fd) [open $state(file) { RDONLY }]
+ set state(offset) 0
+ seek $state(fd) 0 end
+ set state(count) [tell $state(fd)]
+
+ fconfigure $state(fd) -translation binary
+ }
+ }
+
+ set code [catch { mime::parsepart $token } result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ if {$fileP} {
+ if {!$openP} {
+ unset state(root)
+ catch { close $state(fd) }
+ }
+ unset state(fd)
+ }
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::mime::parsepart --
+#
+# Parses the MIME headers and attempts to break up the message
+# into its various parts, creating a MIME token for each part.
+#
+# Arguments:
+# token The MIME token to parse.
+#
+# Results:
+# Throws an error if it has problems parsing the MIME token,
+# otherwise it just sets up the appropriate variables.
+
+proc ::mime::parsepart {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[set fileP [info exists state(file)]]} {
+ seek $state(fd) [set pos $state(offset)] start
+ set last [expr {$state(offset)+$state(count)-1}]
+ } else {
+ set string $state(string)
+ }
+
+ set vline ""
+ while {1} {
+ set blankP 0
+ if {$fileP} {
+ if {($pos > $last) || ([set x [gets $state(fd) line]] <= 0)} {
+ set blankP 1
+ } else {
+ 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 {(!$blankP) && ([string last "\r" $line] == [expr {$x-1}])} {
+
+ set line [string range $line 0 [expr {$x-2}]]
+ if {$x == 1} {
+ set blankP 1
+ }
+ }
+
+ if {(!$blankP) \
+ && (([string first " " $line] == 0) \
+ || ([string first "\t" $line] == 0))} {
+ append vline "\n" $line
+ continue
+ }
+
+ if {![string compare $vline ""]} {
+ if {$blankP} {
+ break
+ }
+
+ set vline $line
+ continue
+ }
+
+ if {([set x [string first ":" $vline]] <= 0) \
+ || (![string compare \
+ [set mixed \
+ [string trimright \
+ [string range \
+ $vline 0 [expr {$x-1}]]]] \
+ ""])} {
+ error "improper line in header: $vline"
+ }
+ set value [string trim [string range $vline [expr {$x+1}] end]]
+ switch -- [set lower [string tolower $mixed]] {
+ content-type {
+ if {[info exists state(content)]} {
+ error "multiple Content-Type fields starting with $vline"
+ }
+
+ if {![catch { set x [parsetype $token $value] }]} {
+ set state(content) [lindex $x 0]
+ set state(params) [lindex $x 1]
+ }
+ }
+
+ content-md5 {
+ }
+
+ content-transfer-encoding {
+ if {([string compare $state(encoding) ""]) \
+ && ([string compare $state(encoding) \
+ [string tolower $value]])} {
+ error "multiple Content-Transfer-Encoding fields starting with $vline"
+ }
+
+ set state(encoding) [string tolower $value]
+ }
+
+ mime-version {
+ set state(version) $value
+ }
+
+ default {
+ if {[lsearch -exact $state(lowerL) $lower] < 0} {
+ lappend state(lowerL) $lower
+ lappend state(mixedL) $mixed
+ }
+
+ array set header $state(header)
+ lappend header($lower) $value
+ set state(header) [array get header]
+ }
+ }
+
+ if {$blankP} {
+ break
+ }
+ set vline $line
+ }
+
+ if {![info exists state(content)]} {
+ set state(content) text/plain
+ set state(params) [list charset us-ascii]
+ }
+
+ if {![string match multipart/* $state(content)]} {
+ if {$fileP} {
+ set x [tell $state(fd)]
+ incr state(count) [expr {$state(offset)-$x}]
+ set state(offset) $x
+ } else {
+ # rebuild string, this is cheap and needed by other functions
+ set state(string) [join [lrange $state(lines) \
+ $state(lines.current) end] "\n"]
+ }
+
+ if {[string match message/* $state(content)]} {
+ # FRINK: nocheck
+ variable [set child $token-[incr state(cid)]]
+
+ set state(value) parts
+ set state(parts) $child
+ if {$fileP} {
+ mime::initializeaux $child \
+ -file $state(file) -root $state(root) \
+ -offset $state(offset) -count $state(count)
+ } else {
+ mime::initializeaux $child \
+ -lineslist [lrange $state(lines) \
+ $state(lines.current) end]
+ }
+ }
+
+ return
+ }
+
+ set state(value) parts
+
+ set boundary ""
+ foreach {k v} $state(params) {
+ if {![string compare $k boundary]} {
+ set boundary $v
+ break
+ }
+ }
+ if {![string compare $boundary ""]} {
+ error "boundary parameter is missing in $state(content)"
+ }
+ if {![string compare [string trim $boundary] ""]} {
+ error "boundary parameter is empty in $state(content)"
+ }
+
+ if {$fileP} {
+ set pos [tell $state(fd)]
+ }
+
+ set inP 0
+ set moreP 1
+ while {$moreP} {
+ if {$fileP} {
+ if {$pos > $last} {
+ # error "termination string missing in $state(content)"
+ set line "--$boundary--"
+ } else {
+ if {[set x [gets $state(fd) line]] < 0} {
+ error "end-of-file encountered while parsing $state(content)"
+ }
+ }
+ incr pos [expr {$x+1}]
+ } else {
+
+ if { $state(lines.current) >= $state(lines.count) } {
+ error "end-of-string encountered while parsing $state(content)"
+ } else {
+ set line [lindex $state(lines) $state(lines.current)]
+ incr state(lines.current)
+ set x [string length $line]
+ }
+
+ set x [string length $line]
+ }
+ if {[string last "\r" $line] == [expr {$x-1}]} {
+ set line [string range $line 0 [expr {$x-2}]]
+ }
+
+ if {[string first "--$boundary" $line] != 0} {
+ if {$inP && !$fileP} {
+ lappend start $line
+ }
+
+ continue
+ }
+
+ if {!$inP} {
+ if {![string compare $line "--$boundary"]} {
+ set inP 1
+ if {$fileP} {
+ set start $pos
+ } else {
+ set start [list]
+ }
+ }
+
+ continue
+ }
+
+ if {([set moreP [string compare $line "--$boundary--"]]) \
+ && ([string compare $line "--$boundary"])} {
+ if {$inP && !$fileP} {
+ lappend start $line
+ }
+ continue
+ }
+ # FRINK: nocheck
+ variable [set child $token-[incr state(cid)]]
+
+ lappend state(parts) $child
+
+ if {$fileP} {
+ if {[set count [expr {$pos-($start+$x+3)}]] < 0} {
+ set count 0
+ }
+
+ mime::initializeaux $child \
+ -file $state(file) -root $state(root) \
+ -offset $start -count $count
+
+ seek $state(fd) [set start $pos] start
+ } else {
+ mime::initializeaux $child -lineslist $start
+ set start ""
+ }
+ }
+}
+
+# ::mime::parsetype --
+#
+# Parses the string passed in and identifies the content-type and
+# params strings.
+#
+# Arguments:
+# token The MIME token to parse.
+# string The content-type string that should be parsed.
+#
+# Results:
+# Returns the content and params for the string as a two element
+# tcl list.
+
+proc ::mime::parsetype {token string} {
+ global errorCode errorInfo
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ variable typetokenL
+ variable typelexemeL
+
+ set state(input) $string
+ set state(buffer) ""
+ set state(lastC) LX_END
+ set state(comment) ""
+ set state(tokenL) $typetokenL
+ set state(lexemeL) $typelexemeL
+
+ set code [catch { mime::parsetypeaux $token $string } result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ unset state(input) \
+ state(buffer) \
+ state(lastC) \
+ state(comment) \
+ state(tokenL) \
+ state(lexemeL)
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::mime::parsetypeaux --
+#
+# A helper function for mime::parsetype. Parses the specified
+# string looking for the content type and params.
+#
+# Arguments:
+# token The MIME token to parse.
+# string The content-type string that should be parsed.
+#
+# Results:
+# Returns the content and params for the string as a two element
+# tcl list.
+
+proc ::mime::parsetypeaux {token string} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[string compare [parselexeme $token] LX_ATOM]} {
+ error [format "expecting type (found %s)" $state(buffer)]
+ }
+ set type [string tolower $state(buffer)]
+
+ switch -- [parselexeme $token] {
+ LX_SOLIDUS {
+ }
+
+ LX_END {
+ if {[string compare $type message]} {
+ error "expecting type/subtype (found $type)"
+ }
+
+ return [list message/rfc822 ""]
+ }
+
+ default {
+ error [format "expecting \"/\" (found %s)" $state(buffer)]
+ }
+ }
+
+ if {[string compare [parselexeme $token] LX_ATOM]} {
+ error [format "expecting subtype (found %s)" $state(buffer)]
+ }
+ append type [string tolower /$state(buffer)]
+
+ array set params ""
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_END {
+ return [list $type [array get params]]
+ }
+
+ LX_SEMICOLON {
+ }
+
+ default {
+ error [format "expecting \";\" (found %s)" $state(buffer)]
+ }
+ }
+
+ switch -- [parselexeme $token] {
+ LX_END {
+ return [list $type [array get params]]
+ }
+
+ LX_ATOM {
+ }
+
+ default {
+ error [format "expecting attribute (found %s)" $state(buffer)]
+ }
+ }
+
+ set attribute [string tolower $state(buffer)]
+
+ if {[string compare [parselexeme $token] LX_EQUALS]} {
+ error [format "expecting \"=\" (found %s)" $state(buffer)]
+ }
+
+ switch -- [parselexeme $token] {
+ LX_ATOM {
+ }
+
+ LX_QSTRING {
+ set state(buffer) \
+ [string range $state(buffer) 1 \
+ [expr {[string length $state(buffer)]-2}]]
+ }
+
+ default {
+ error [format "expecting value (found %s)" $state(buffer)]
+ }
+ }
+ set params($attribute) $state(buffer)
+ }
+}
+
+# ::mime::finalize --
+#
+# mime::finalize destroys a MIME part.
+#
+# If the -subordinates option is present, it specifies which
+# subordinates should also be destroyed. The default value is
+# "dynamic".
+#
+# Arguments:
+# token The MIME token to parse.
+# args Args can be optionally be of the following form:
+# ?-subordinates "all" | "dynamic" | "none"?
+#
+# Results:
+# Returns an empty string.
+
+proc ::mime::finalize {token args} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set options [list -subordinates dynamic]
+ array set options $args
+
+ switch -- $options(-subordinates) {
+ all {
+ if {![string compare $state(value) parts]} {
+ foreach part $state(parts) {
+ eval [list mime::finalize $part] $args
+ }
+ }
+ }
+
+ dynamic {
+ for {set cid $state(cid)} {$cid > 0} {incr cid -1} {
+ eval [list mime::finalize $token-$cid] $args
+ }
+ }
+
+ none {
+ }
+
+ default {
+ error "unknown value for -subordinates $options(-subordinates)"
+ }
+ }
+
+ foreach name [array names state] {
+ unset state($name)
+ }
+ # FRINK: nocheck
+ unset $token
+}
+
+# ::mime::getproperty --
+#
+# mime::getproperty returns the properties of a MIME part.
+#
+# The properties are:
+#
+# property value
+# ======== =====
+# content the type/subtype describing the content
+# encoding the "Content-Transfer-Encoding"
+# params a list of "Content-Type" parameters
+# parts a list of tokens for the part's subordinates
+# size the approximate size of the content (unencoded)
+#
+# The "parts" property is present only if the MIME part has
+# subordinates.
+#
+# If mime::getproperty is invoked with the name of a specific
+# property, then the corresponding value is returned; instead, if
+# -names is specified, a list of all properties is returned;
+# otherwise, a serialized array of properties and values is returned.
+#
+# Arguments:
+# token The MIME token to parse.
+# property One of 'content', 'encoding', 'params', 'parts', and
+# 'size'. Defaults to returning a serialized array of
+# properties and values.
+#
+# Results:
+# Returns the properties of a MIME part
+
+proc ::mime::getproperty {token {property ""}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ switch -- $property {
+ "" {
+ array set properties [list content $state(content) \
+ encoding $state(encoding) \
+ params $state(params) \
+ size [getsize $token]]
+ if {[info exists state(parts)]} {
+ set properties(parts) $state(parts)
+ }
+
+ return [array get properties]
+ }
+
+ -names {
+ set names [list content encoding params]
+ if {[info exists state(parts)]} {
+ lappend names parts
+ }
+
+ return $names
+ }
+
+ content
+ -
+ encoding
+ -
+ params {
+ return $state($property)
+ }
+
+ parts {
+ if {![info exists state(parts)]} {
+ error "MIME part is a leaf"
+ }
+
+ return $state(parts)
+ }
+
+ size {
+ return [getsize $token]
+ }
+
+ default {
+ error "unknown property $property"
+ }
+ }
+}
+
+# ::mime::getsize --
+#
+# Determine the size (in bytes) of a MIME part/token
+#
+# Arguments:
+# token The MIME token to parse.
+#
+# Results:
+# Returns the size in bytes of the MIME token.
+
+proc ::mime::getsize {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ switch -- $state(value)/$state(canonicalP) {
+ file/0 {
+ set size $state(count)
+ }
+
+ file/1 {
+ return [file size $state(file)]
+ }
+
+ parts/0
+ -
+ parts/1 {
+ set size 0
+ foreach part $state(parts) {
+ incr size [getsize $part]
+ }
+
+ return $size
+ }
+
+ string/0 {
+ set size [string length $state(string)]
+ }
+
+ string/1 {
+ return [string length $state(string)]
+ }
+ default {
+ error "Unknown combination \"$state(value)/$state(canonicalP)\""
+ }
+ }
+
+ if {![string compare $state(encoding) base64]} {
+ set size [expr {($size*3+2)/4}]
+ }
+
+ return $size
+}
+
+# ::mime::getheader --
+#
+# mime::getheader returns the header of a MIME part.
+#
+# A header consists of zero or more key/value pairs. Each value is a
+# list containing one or more strings.
+#
+# If mime::getheader is invoked with the name of a specific key, then
+# a list containing the corresponding value(s) is returned; instead,
+# if -names is specified, a list of all keys is returned; otherwise, a
+# serialized array of keys and values is returned. Note that when a
+# key is specified (e.g., "Subject"), the list returned usually
+# contains exactly one string; however, some keys (e.g., "Received")
+# often occur more than once in the header, accordingly the list
+# returned usually contains more than one string.
+#
+# Arguments:
+# token The MIME token to parse.
+# key Either a key or '-names'. If it is '-names' a list
+# of all keys is returned.
+#
+# Results:
+# Returns the header of a MIME part.
+
+proc ::mime::getheader {token {key ""}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set header $state(header)
+ switch -- $key {
+ "" {
+ set result ""
+ foreach lower $state(lowerL) mixed $state(mixedL) {
+ lappend result $mixed $header($lower)
+ }
+ return $result
+ }
+
+ -names {
+ return $state(mixedL)
+ }
+
+ default {
+ set lower [string tolower [set mixed $key]]
+
+ if {![info exists header($lower)]} {
+ error "key $mixed not in header"
+ }
+ return $header($lower)
+ }
+ }
+}
+
+# ::mime::setheader --
+#
+# mime::setheader writes, appends to, or deletes the value associated
+# with a key in the header.
+#
+# The value for -mode is one of:
+#
+# write: the key/value is either created or overwritten (the
+# default);
+#
+# append: a new value is appended for the key (creating it as
+# necessary); or,
+#
+# delete: all values associated with the key are removed (the
+# "value" parameter is ignored).
+#
+# Regardless, mime::setheader returns the previous value associated
+# with the key.
+#
+# Arguments:
+# token The MIME token to parse.
+# key The name of the key whose value should be set.
+# value The value for the header key to be set to.
+# args An optional argument of the form:
+# ?-mode "write" | "append" | "delete"?
+#
+# Results:
+# Returns previous value associated with the specified key.
+
+proc ::mime::setheader {token key value args} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set options [list -mode write]
+ array set options $args
+
+ switch -- [set lower [string tolower $key]] {
+ content-md5
+ -
+ content-type
+ -
+ content-transfer-encoding
+ -
+ mime-version {
+ error "key $key may not be set"
+ }
+ default {# Skip key}
+ }
+
+ array set header $state(header)
+ if {[set x [lsearch -exact $state(lowerL) $lower]] < 0} {
+ if {![string compare $options(-mode) delete]} {
+ error "key $key not in header"
+ }
+
+ lappend state(lowerL) $lower
+ lappend state(mixedL) $key
+
+ set result ""
+ } else {
+ set result $header($lower)
+ }
+ switch -- $options(-mode) {
+ append {
+ lappend header($lower) $value
+ }
+
+ delete {
+ unset header($lower)
+ set state(lowerL) [lreplace $state(lowerL) $x $x]
+ set state(mixedL) [lreplace $state(mixedL) $x $x]
+ }
+
+ write {
+ set header($lower) [list $value]
+ }
+
+ default {
+ error "unknown value for -mode $options(-mode)"
+ }
+ }
+
+ set state(header) [array get header]
+
+ return $result
+}
+
+# ::mime::getbody --
+#
+# mime::getbody returns the body of a leaf MIME part in canonical form.
+#
+# If the -command option is present, then it is repeatedly invoked
+# with a fragment of the body as this:
+#
+# uplevel #0 $callback [list "data" $fragment]
+#
+# (The -blocksize option, if present, specifies the maximum size of
+# each fragment passed to the callback.)
+# When the end of the body is reached, the callback is invoked as:
+#
+# uplevel #0 $callback "end"
+#
+# Alternatively, if an error occurs, the callback is invoked as:
+#
+# uplevel #0 $callback [list "error" reason]
+#
+# Regardless, the return value of the final invocation of the callback
+# is propagated upwards by mime::getbody.
+#
+# If the -command option is absent, then the return value of
+# mime::getbody is a string containing the MIME part's entire body.
+#
+# Arguments:
+# token The MIME token to parse.
+# args Optional arguments of the form:
+# ?-command callback ?-blocksize octets? ?
+#
+# Results:
+# Returns a string containing the MIME part's entire body, or
+# if '-command' is specified, the return value of the command
+# is returned.
+
+proc ::mime::getbody {token args} {
+ global errorCode errorInfo
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set options [list -command [list mime::getbodyaux $token] \
+ -blocksize 4096]
+ array set options $args
+ if {$options(-blocksize) < 1} {
+ error "-blocksize expects a positive integer, not $options(-blocksize)"
+ }
+
+ set code 0
+ set ecode ""
+ set einfo ""
+
+ switch -- $state(value)/$state(canonicalP) {
+ file/0 {
+ set fd [open $state(file) { RDONLY }]
+
+ set code [catch {
+ fconfigure $fd -translation binary
+ seek $fd [set pos $state(offset)] start
+ set last [expr {$state(offset)+$state(count)-1}]
+
+ set fragment ""
+ while {$pos <= $last} {
+ if {[set cc [expr {($last-$pos)+1}]] \
+ > $options(-blocksize)} {
+ set cc $options(-blocksize)
+ }
+ incr pos [set len \
+ [string length [set chunk [read $fd $cc]]]]
+ switch -exact -- $state(encoding) {
+ base64
+ -
+ quoted-printable {
+ if {([set x [string last "\n" $chunk]] > 0) \
+ && ($x+1 != $len)} {
+ set chunk [string range $chunk 0 $x]
+ seek $fd [incr pos [expr {($x+1)-$len}]] start
+ }
+ set chunk [$state(encoding) -mode decode \
+ -- $chunk]
+ }
+ 7bit - 8bit - binary - "" {
+ # Bugfix for [#477088]
+ # Go ahead, leave chunk alone
+ }
+ default {
+ error "Can't handle content encoding \"$state(encoding)\""
+ }
+ }
+ append fragment $chunk
+
+ set cc [expr {$options(-blocksize)-1}]
+ while {[string length $fragment] > $options(-blocksize)} {
+ uplevel #0 $options(-command) \
+ [list data \
+ [string range $fragment 0 $cc]]
+
+ set fragment [string range \
+ $fragment $options(-blocksize) \
+ end]
+ }
+ }
+ if {[string length $fragment] > 0} {
+ uplevel #0 $options(-command) [list data $fragment]
+ }
+ } result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ catch { close $fd }
+ }
+
+ file/1 {
+ set fd [open $state(file) { RDONLY }]
+
+ set code [catch {
+ fconfigure $fd -translation binary
+
+ while {[string length \
+ [set fragment \
+ [read $fd $options(-blocksize)]]] > 0} {
+ uplevel #0 $options(-command) [list data $fragment]
+ }
+ } result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ catch { close $fd }
+ }
+
+ parts/0
+ -
+ parts/1 {
+ error "MIME part isn't a leaf"
+ }
+
+ string/0
+ -
+ string/1 {
+ switch -- $state(encoding)/$state(canonicalP) {
+ base64/0
+ -
+ quoted-printable/0 {
+ set fragment [$state(encoding) -mode decode \
+ -- $state(string)]
+ }
+
+ default {
+ # Not a bugfix for [#477088], but clarification
+ # This handles no-encoding, 7bit, 8bit, and binary.
+ set fragment $state(string)
+ }
+ }
+
+ set code [catch {
+ set cc [expr {$options(-blocksize)-1}]
+ while {[string length $fragment] > $options(-blocksize)} {
+ uplevel #0 $options(-command) \
+ [list data [string range $fragment 0 $cc]]
+
+ set fragment [string range $fragment \
+ $options(-blocksize) end]
+ }
+ if {[string length $fragment] > 0} {
+ uplevel #0 $options(-command) [list data $fragment]
+ }
+ } result]
+ set ecode $errorCode
+ set einfo $errorInfo
+ }
+ default {
+ error "Unknown combination \"$state(value)/$state(canonicalP)\""
+ }
+ }
+
+ 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
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::mime::getbodyaux --
+#
+# Builds up the body of the message, fragment by fragment. When
+# the entire message has been retrieved, it is returned.
+#
+# Arguments:
+# token The MIME token to parse.
+# reason One of 'data', 'end', or 'error'.
+# fragment The section of data data fragment to extract a
+# string from.
+#
+# Results:
+# Returns nothing, except when called with the 'end' argument
+# in which case it returns a string that contains all of the
+# data that 'getbodyaux' has been called with. Will throw an
+# error if it is called with the reason of 'error'.
+
+proc ::mime::getbodyaux {token reason {fragment ""}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ switch -- $reason {
+ data {
+ append state(getbody) $fragment
+ return ""
+ }
+
+ end {
+ if {[info exists state(getbody)]} {
+ set result $state(getbody)
+ unset state(getbody)
+ } else {
+ set result ""
+ }
+
+ return $result
+ }
+
+ error {
+ catch { unset state(getbody) }
+ error $reason
+ }
+
+ default {
+ error "Unknown reason \"$reason\""
+ }
+ }
+}
+
+# ::mime::copymessage --
+#
+# mime::copymessage copies the MIME part to the specified channel.
+#
+# mime::copymessage operates synchronously, and uses fileevent to
+# allow asynchronous operations to proceed independently.
+#
+# Arguments:
+# token The MIME token to parse.
+# channel The channel to copy the message to.
+#
+# Results:
+# Returns nothing unless an error is thrown while the message
+# 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
+
+ if {(!$openP) && ([info exists state(fd)])} {
+ if {![info exists state(root)]} {
+ catch { close $state(fd) }
+ }
+ unset state(fd)
+ }
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::mime::copymessageaux --
+#
+# mime::copymessageaux copies the MIME part to the specified channel.
+#
+# Arguments:
+# token The MIME token to parse.
+# channel The channel to copy the message to.
+#
+# Results:
+# Returns nothing unless an error is thrown while the message
+# is being written to the channel.
+
+proc ::mime::copymessageaux {token channel} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set header $state(header)
+
+ if {[string compare $state(version) ""]} {
+ puts $channel "MIME-Version: $state(version)"
+ }
+ foreach lower $state(lowerL) mixed $state(mixedL) {
+ foreach value $header($lower) {
+ puts $channel "$mixed: $value"
+ }
+ }
+ if {(!$state(canonicalP)) \
+ && ([string compare [set encoding $state(encoding)] ""])} {
+ puts $channel "Content-Transfer-Encoding: $encoding"
+ }
+
+ puts -nonewline $channel "Content-Type: $state(content)"
+ set boundary ""
+ foreach {k v} $state(params) {
+ if {![string compare $k boundary]} {
+ set boundary $v
+ }
+
+ puts -nonewline $channel ";\n $k=\"$v\""
+ }
+
+ set converter ""
+ set encoding ""
+ if {[string compare $state(value) parts]} {
+ puts $channel ""
+
+ if {$state(canonicalP)} {
+ if {![string compare [set encoding $state(encoding)] ""]} {
+ set encoding [encoding $token]
+ }
+ if {[string compare $encoding ""]} {
+ puts $channel "Content-Transfer-Encoding: $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\""
+ }
+ }
+ }
+ } elseif {([string match multipart/* $state(content)]) \
+ && (![string compare $boundary ""])} {
+# we're doing everything in one pass...
+ set key [clock seconds]$token[info hostname][array get state]
+ set seqno 8
+ while {[incr seqno -1] >= 0} {
+ set key [md5 -- $key]
+ }
+ set boundary "----- =_[string trim [base64 -mode encode -- $key]]"
+
+ puts $channel ";\n boundary=\"$boundary\""
+ } else {
+ puts $channel ""
+ }
+
+ if {[info exists state(error)]} {
+ unset state(error)
+ }
+
+ switch -- $state(value) {
+ file {
+ set closeP 1
+ if {[info exists state(root)]} {
+ # FRINK: nocheck
+ variable $state(root)
+ upvar 0 $state(root) root
+
+ if {[info exists root(fd)]} {
+ set fd $root(fd)
+ set closeP 0
+ } else {
+ set fd [set state(fd) \
+ [open $state(file) { RDONLY }]]
+ }
+ set size $state(count)
+ } else {
+ set fd [set state(fd) [open $state(file) { RDONLY }]]
+ # read until eof
+ set size -1
+ }
+ seek $fd $state(offset) start
+ if {$closeP} {
+ fconfigure $fd -translation binary
+ }
+
+ puts $channel ""
+
+ while {($size != 0) && (![eof $fd])} {
+ if {$size < 0 || $size > 32766} {
+ set X [read $fd 32766]
+ } else {
+ set X [read $fd $size]
+ }
+ if {$size > 0} {
+ set size [expr {$size - [string length $X]}]
+ }
+ if {[string compare $converter ""]} {
+ puts $channel [$converter -mode encode -- $X]
+ } else {
+ puts $channel $X
+ }
+ }
+
+ if {$closeP} {
+ catch { close $state(fd) }
+ unset state(fd)
+ }
+ }
+
+ parts {
+ if {(![info exists state(root)]) \
+ && ([info exists state(file)])} {
+ set state(fd) [open $state(file) { RDONLY }]
+ fconfigure $state(fd) -translation binary
+ }
+
+ switch -glob -- $state(content) {
+ message/* {
+ puts $channel ""
+ foreach part $state(parts) {
+ mime::copymessage $part $channel
+ break
+ }
+ }
+
+ default {
+ foreach part $state(parts) {
+ puts $channel "\n--$boundary"
+ mime::copymessage $part $channel
+ }
+ puts $channel "\n--$boundary--"
+ }
+ }
+
+ if {[info exists state(fd)]} {
+ catch { close $state(fd) }
+ unset state(fd)
+ }
+ }
+
+ string {
+ if {[catch { fconfigure $channel -buffersize } blocksize]} {
+ set blocksize 4096
+ } elseif {$blocksize < 512} {
+ set blocksize 512
+ }
+ set blocksize [expr {($blocksize/4)*3}]
+
+ puts $channel ""
+
+ if {[string compare $converter ""]} {
+ puts $channel [$converter -mode encode -- $state(string)]
+ } else {
+ puts $channel $state(string)
+ }
+ }
+ default {
+ error "Unknown value \"$state(value)\""
+ }
+ }
+
+ flush $channel
+
+ if {[string compare $converter ""]} {
+ unstack $channel
+ }
+ if {[info exists state(error)]} {
+ error $state(error)
+ }
+}
+
+# ::mime::buildmessage --
+#
+# The following is a clone of the copymessage code to build up the
+# result in memory, and, unfortunately, without using a memory channel.
+# I considered parameterizing the "puts" calls in copy message, but
+# the need for this procedure may go away, so I'm living with it for
+# the moment.
+#
+# Arguments:
+# token The MIME token to parse.
+#
+# Results:
+# Returns the message that has been built up in memory.
+
+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]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ if {(!$openP) && ([info exists state(fd)])} {
+ if {![info exists state(root)]} {
+ catch { close $state(fd) }
+ }
+ unset state(fd)
+ }
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::mime::buildmessageaux --
+#
+# The following is a clone of the copymessageaux code to build up the
+# result in memory, and, unfortunately, without using a memory channel.
+# I considered parameterizing the "puts" calls in copy message, but
+# the need for this procedure may go away, so I'm living with it for
+# the moment.
+#
+# Arguments:
+# token The MIME token to parse.
+#
+# Results:
+# Returns the message that has been built up in memory.
+
+proc ::mime::buildmessageaux {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set header $state(header)
+
+ set result ""
+ if {[string compare $state(version) ""]} {
+ append result "MIME-Version: $state(version)\r\n"
+ }
+ foreach lower $state(lowerL) mixed $state(mixedL) {
+ foreach value $header($lower) {
+ append result "$mixed: $value\r\n"
+ }
+ }
+ if {(!$state(canonicalP)) \
+ && ([string compare [set encoding $state(encoding)] ""])} {
+ append result "Content-Transfer-Encoding: $encoding\r\n"
+ }
+
+ append result "Content-Type: $state(content)"
+ set boundary ""
+ foreach {k v} $state(params) {
+ if {![string compare $k boundary]} {
+ set boundary $v
+ }
+
+ append result ";\r\n $k=\"$v\""
+ }
+
+ set converter ""
+ set encoding ""
+ if {[string compare $state(value) parts]} {
+ append result \r\n
+
+ if {$state(canonicalP)} {
+ if {![string compare [set encoding $state(encoding)] ""]} {
+ set encoding [encoding $token]
+ }
+ if {[string compare $encoding ""]} {
+ append result "Content-Transfer-Encoding: $encoding\r\n"
+ }
+ switch -- $encoding {
+ base64
+ -
+ quoted-printable {
+ set converter $encoding
+ }
+ 7bit - 8bit - binary - "" {
+ # Bugfix for [#477088]
+ # Go ahead
+ }
+ default {
+ error "Can't handle content encoding \"$encoding\""
+ }
+ }
+ }
+ } elseif {([string match multipart/* $state(content)]) \
+ && (![string compare $boundary ""])} {
+# we're doing everything in one pass...
+ set key [clock seconds]$token[info hostname][array get state]
+ set seqno 8
+ while {[incr seqno -1] >= 0} {
+ set key [md5 -- $key]
+ }
+ set boundary "----- =_[string trim [base64 -mode encode -- $key]]"
+
+ append result ";\r\n boundary=\"$boundary\"\r\n"
+ } else {
+ append result "\r\n"
+ }
+
+ if {[info exists state(error)]} {
+ unset state(error)
+ }
+
+ switch -- $state(value) {
+ file {
+ set closeP 1
+ if {[info exists state(root)]} {
+ # FRINK: nocheck
+ variable $state(root)
+ upvar 0 $state(root) root
+
+ if {[info exists root(fd)]} {
+ set fd $root(fd)
+ set closeP 0
+ } else {
+ set fd [set state(fd) \
+ [open $state(file) { RDONLY }]]
+ }
+ set size $state(count)
+ } else {
+ set fd [set state(fd) [open $state(file) { RDONLY }]]
+ set size -1 ;# Read until EOF
+ }
+ seek $fd $state(offset) start
+ if {$closeP} {
+ fconfigure $fd -translation binary
+ }
+
+ append result "\r\n"
+
+ while {($size != 0) && (![eof $fd])} {
+ if {$size < 0 || $size > 32766} {
+ set X [read $fd 32766]
+ } else {
+ set X [read $fd $size]
+ }
+ if {$size > 0} {
+ set size [expr {$size - [string length $X]}]
+ }
+ if {[string compare $converter ""]} {
+ append result "[$converter -mode encode -- $X]\r\n"
+ } else {
+ append result "$X\r\n"
+ }
+ }
+
+ if {$closeP} {
+ catch { close $state(fd) }
+ unset state(fd)
+ }
+ }
+
+ parts {
+ if {(![info exists state(root)]) \
+ && ([info exists state(file)])} {
+ set state(fd) [open $state(file) { RDONLY }]
+ fconfigure $state(fd) -translation binary
+ }
+
+ switch -glob -- $state(content) {
+ message/* {
+ append result "\r\n"
+ foreach part $state(parts) {
+ append result [buildmessage $part]
+ break
+ }
+ }
+
+ default {
+ foreach part $state(parts) {
+ append result "\r\n--$boundary\r\n"
+ append result [buildmessage $part]
+ }
+ append result "\r\n--$boundary--\r\n"
+ }
+ }
+
+ if {[info exists state(fd)]} {
+ catch { close $state(fd) }
+ unset state(fd)
+ }
+ }
+
+ string {
+
+ append result "\r\n"
+
+ if {[string compare $converter ""]} {
+ append result "[$converter -mode encode -- $state(string)]\r\n"
+ } else {
+ append result "$state(string)\r\n"
+ }
+ }
+ default {
+ error "Unknown value \"$state(value)\""
+ }
+ }
+
+ if {[info exists state(error)]} {
+ error $state(error)
+ }
+ return $result
+}
+
+# ::mime::encoding --
+#
+# Determines how a token is encoded.
+#
+# Arguments:
+# token The MIME token to parse.
+#
+# Results:
+# Returns the encoding of the message (the null string, base64,
+# or quoted-printable).
+
+proc ::mime::encoding {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ switch -glob -- $state(content) {
+ audio/*
+ -
+ image/*
+ -
+ video/* {
+ return base64
+ }
+
+ message/*
+ -
+ multipart/* {
+ return ""
+ }
+ default {# Skip}
+ }
+
+ set asciiP 1
+ set lineP 1
+ switch -- $state(value) {
+ file {
+ set fd [open $state(file) { RDONLY }]
+ fconfigure $fd -translation binary
+
+ while {[gets $fd line] >= 0} {
+ if {$asciiP} {
+ set asciiP [encodingasciiP $line]
+ }
+ if {$lineP} {
+ set lineP [encodinglineP $line]
+ }
+ if {(!$asciiP) && (!$lineP)} {
+ break
+ }
+ }
+
+ catch { close $fd }
+ }
+
+ parts {
+ return ""
+ }
+
+ string {
+ foreach line [split $state(string) "\n"] {
+ if {$asciiP} {
+ set asciiP [encodingasciiP $line]
+ }
+ if {$lineP} {
+ set lineP [encodinglineP $line]
+ }
+ if {(!$asciiP) && (!$lineP)} {
+ break
+ }
+ }
+ }
+ default {
+ error "Unknown value \"$state(value)\""
+ }
+ }
+
+ switch -glob -- $state(content) {
+ text/* {
+ if {!$asciiP} {
+ foreach {k v} $state(params) {
+ if {![string compare $k charset]} {
+ set v [string tolower $v]
+ if {([string compare $v us-ascii]) \
+ && (![string match {iso-8859-[1-8]} $v])} {
+ return base64
+ }
+
+ break
+ }
+ }
+ }
+
+ if {!$lineP} {
+ return quoted-printable
+ }
+ }
+
+
+ default {
+ if {(!$asciiP) || (!$lineP)} {
+ return base64
+ }
+ }
+ }
+
+ return ""
+}
+
+# ::mime::encodingasciiP --
+#
+# Checks if a string is a pure ascii string, or if it has a non-standard
+# form.
+#
+# Arguments:
+# line The line to check.
+#
+# Results:
+# Returns 1 if \r only occurs at the end of lines, and if all
+# characters in the line are between the ASCII codes of 32 and 126.
+
+proc ::mime::encodingasciiP {line} {
+ foreach c [split $line ""] {
+ switch -- $c {
+ " " - "\t" - "\r" - "\n" {
+ }
+
+ default {
+ binary scan $c c c
+ if {($c < 32) || ($c > 126)} {
+ return 0
+ }
+ }
+ }
+ }
+ if {([set r [string first "\r" $line]] < 0) \
+ || ($r == [expr {[string length $line]-1}])} {
+ return 1
+ }
+
+ return 0
+}
+
+# ::mime::encodinglineP --
+#
+# Checks if a string is a line is valid to be processed.
+#
+# Arguments:
+# line The line to check.
+#
+# Results:
+# Returns 1 the line is less than 76 characters long, the line
+# contains more characters than just whitespace, the line does
+# not start with a '.', and the line does not start with 'From '.
+
+proc ::mime::encodinglineP {line} {
+ if {([string length $line] > 76) \
+ || ([string compare $line [string trimright $line]]) \
+ || ([string first . $line] == 0) \
+ || ([string first "From " $line] == 0)} {
+ return 0
+ }
+
+ return 1
+}
+
+# ::mime::fcopy --
+#
+# Appears to be unused.
+#
+# Arguments:
+#
+# Results:
+#
+
+proc ::mime::fcopy {token count {error ""}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[string compare $error ""]} {
+ set state(error) $error
+ }
+ set state(doneP) 1
+}
+
+# ::mime::scopy --
+#
+# Copy a portion of the contents of a mime token to a channel.
+#
+# Arguments:
+# token The token containing the data to copy.
+# channel The channel to write the data to.
+# offset The location in the string to start copying
+# from.
+# len The amount of data to write.
+# blocksize The block size for the write operation.
+#
+# Results:
+# The specified portion of the string in the mime token is
+# copied to the specified channel.
+
+proc ::mime::scopy {token channel offset len blocksize} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {$len <= 0} {
+ set state(doneP) 1
+ fileevent $channel writable ""
+ return
+ }
+
+ if {[set cc $len] > $blocksize} {
+ set cc $blocksize
+ }
+
+ 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]} {
+ set state(error) $result
+ set state(doneP) 1
+ fileevent $channel writable ""
+ }
+ return
+}
+
+# ::mime::qp_encode --
+#
+# Tcl version of quote-printable encode
+#
+# Arguments:
+# string The string to quote.
+# encoded_word Boolean value to determine whether or not encoded words
+# (RFC 2047) should be handled or not. (optional)
+#
+# Results:
+# The properly quoted string is returned.
+
+proc ::mime::qp_encode {string {encoded_word 0} {no_softbreak 0}} {
+ # 8.1+ improved string manipulation routines used.
+ # Replace outlying characters, characters that would normally
+ # be munged by EBCDIC gateways, and special Tcl characters "[\]{}
+ # with =xx sequence
+
+ regsub -all -- \
+ {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]} \
+ $string {[format =%02X [scan "\\&" %c]]} string
+
+ # Replace the format commands with their result
+
+ set string [subst -novariable $string]
+
+ # soft/hard newlines and other
+ # Funky cases for SMTP compatibility
+ set mapChars [list " \n" "=20\n" "\t\n" "=09\n" \
+ "\n\.\n" "\n=2E\n" "\nFrom " "\n=46rom "]
+ if {$encoded_word} {
+ # Special processing for encoded words (RFC 2047)
+ lappend mapChars " " "_"
+ }
+ set string [string map $mapChars $string]
+
+ # Break long lines - ugh
+
+ # Implementation of FR #503336
+ if {$no_softbreak} {
+ set result $string
+ } else {
+ set result ""
+ foreach line [split $string \n] {
+ while {[string length $line] > 72} {
+ set chunk [string range $line 0 72]
+ if {[regexp -- (=|=.)$ $chunk dummy end]} {
+
+ # Don't break in the middle of a code
+
+ set len [expr {72 - [string length $end]}]
+ set chunk [string range $line 0 $len]
+ incr len
+ set line [string range $line $len end]
+ } else {
+ set line [string range $line 73 end]
+ }
+ append result $chunk=\n
+ }
+ append result $line\n
+ }
+ }
+
+ # Trim off last \n, since the above code has the side-effect
+ # of adding an extra \n to the encoded string and return the result.
+
+ set result [string range $result 0 end-1]
+
+ # If the string ends in space or tab, replace with =xx
+
+ set lastChar [string index $result end]
+ if {$lastChar==" "} {
+ set result [string replace $result end end "=20"]
+ } elseif {$lastChar=="\t"} {
+ set result [string replace $result end end "=09"]
+ }
+
+ return $result
+}
+
+# ::mime::qp_decode --
+#
+# Tcl version of quote-printable decode
+#
+# Arguments:
+# string The quoted-prinatble string to decode.
+# encoded_word Boolean value to determine whether or not encoded words
+# (RFC 2047) should be handled or not. (optional)
+#
+# Results:
+# The decoded string is returned.
+
+proc ::mime::qp_decode {string {encoded_word 0}} {
+ # 8.1+ improved string manipulation routines used.
+ # Special processing for encoded words (RFC 2047)
+
+ if {$encoded_word} {
+ # _ == \x20, even if SPACE occupies a different code position
+ set string [string map [list _ \u0020] $string]
+ }
+
+ # smash the white-space at the ends of lines since that must've been
+ # generated by an MUA.
+
+ regsub -all -- {[ \t]+\n} $string "\n" string
+ set string [string trimright $string " \t"]
+
+ # Protect the backslash for later subst and
+ # smash soft newlines, has to occur after white-space smash
+ # and any encoded word modification.
+
+ set string [string map [list "\\" "\\\\" "=\n" ""] $string]
+
+ # Decode specials
+
+ regsub -all -nocase {=([a-f0-9][a-f0-9])} $string {\\u00\1} string
+
+ # process \u unicode mapped chars
+
+ return [subst -novar -nocommand $string]
+}
+
+# ::mime::parseaddress --
+#
+# This was originally written circa 1982 in C. we're still using it
+# because it recognizes virtually every buggy address syntax ever
+# generated!
+#
+# mime::parseaddress takes a string containing one or more 822-style
+# address specifications and returns a list of serialized arrays, one
+# element for each address specified in the argument.
+#
+# Each serialized array contains these properties:
+#
+# property value
+# ======== =====
+# address local@domain
+# comment 822-style comment
+# domain the domain part (rhs)
+# error non-empty on a parse error
+# group this address begins a group
+# friendly user-friendly rendering
+# local the local part (lhs)
+# memberP this address belongs to a group
+# phrase the phrase part
+# proper 822-style address specification
+# route 822-style route specification (obsolete)
+#
+# Note that one or more of these properties may be empty.
+#
+# Arguments:
+# string The address string to parse
+#
+# Results:
+# Returns a list of serialized arrays, one element for each address
+# specified in the argument.
+
+proc ::mime::parseaddress {string} {
+ global errorCode errorInfo
+
+ variable mime
+
+ set token [namespace current]::[incr mime(uid)]
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set code [catch { mime::parseaddressaux $token $string } result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ foreach name [array names state] {
+ unset state($name)
+ }
+ # FRINK: nocheck
+ catch { unset $token }
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::mime::parseaddressaux --
+#
+# This was originally written circa 1982 in C. we're still using it
+# because it recognizes virtually every buggy address syntax ever
+# generated!
+#
+# mime::parseaddressaux does the actually parsing for mime::parseaddress
+#
+# Each serialized array contains these properties:
+#
+# property value
+# ======== =====
+# address local@domain
+# comment 822-style comment
+# domain the domain part (rhs)
+# error non-empty on a parse error
+# group this address begins a group
+# friendly user-friendly rendering
+# local the local part (lhs)
+# memberP this address belongs to a group
+# phrase the phrase part
+# proper 822-style address specification
+# route 822-style route specification (obsolete)
+#
+# Note that one or more of these properties may be empty.
+#
+# Arguments:
+# token The MIME token to work from.
+# string The address string to parse
+#
+# Results:
+# Returns a list of serialized arrays, one element for each address
+# specified in the argument.
+
+proc ::mime::parseaddressaux {token string} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ variable addrtokenL
+ variable addrlexemeL
+
+ set state(input) $string
+ set state(glevel) 0
+ set state(buffer) ""
+ set state(lastC) LX_END
+ set state(tokenL) $addrtokenL
+ set state(lexemeL) $addrlexemeL
+
+ set result ""
+ while {[addr_next $token]} {
+ if {[string compare [set tail $state(domain)] ""]} {
+ set tail @$state(domain)
+ } else {
+ set tail @[info hostname]
+ }
+ if {[string compare [set address $state(local)] ""]} {
+ append address $tail
+ }
+
+ if {[string compare $state(phrase) ""]} {
+ set state(phrase) [string trim $state(phrase) "\""]
+ foreach t $state(tokenL) {
+ if {[string first $t $state(phrase)] >= 0} {
+ set state(phrase) \"$state(phrase)\"
+ break
+ }
+ }
+
+ set proper "$state(phrase) <$address>"
+ } else {
+ set proper $address
+ }
+
+ if {![string compare [set friendly $state(phrase)] ""]} {
+ if {[string compare [set note $state(comment)] ""]} {
+ if {[string first "(" $note] == 0} {
+ set note [string trimleft [string range $note 1 end]]
+ }
+ if {[string last ")" $note] \
+ == [set len [expr {[string length $note]-1}]]} {
+ set note [string range $note 0 [expr {$len-1}]]
+ }
+ set friendly $note
+ }
+
+ if {(![string compare $friendly ""]) \
+ && ([string compare [set mbox $state(local)] ""])} {
+ set mbox [string trim $mbox "\""]
+
+ if {[string first "/" $mbox] != 0} {
+ set friendly $mbox
+ } elseif {[string compare \
+ [set friendly [addr_x400 $mbox PN]] \
+ ""]} {
+ } elseif {([string compare \
+ [set friendly [addr_x400 $mbox S]] \
+ ""]) \
+ && ([string compare \
+ [set g [addr_x400 $mbox G]] \
+ ""])} {
+ set friendly "$g $friendly"
+ }
+
+ if {![string compare $friendly ""]} {
+ set friendly $mbox
+ }
+ }
+ }
+ set friendly [string trim $friendly "\""]
+
+ lappend result [list address $address \
+ comment $state(comment) \
+ domain $state(domain) \
+ error $state(error) \
+ friendly $friendly \
+ group $state(group) \
+ local $state(local) \
+ memberP $state(memberP) \
+ phrase $state(phrase) \
+ proper $proper \
+ route $state(route)]
+
+ }
+
+ unset state(input) \
+ state(glevel) \
+ state(buffer) \
+ state(lastC) \
+ state(tokenL) \
+ state(lexemeL)
+
+ return $result
+}
+
+# ::mime::addr_next --
+#
+# Locate the next address in a mime token.
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# 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
+
+ foreach prop {comment domain error group local memberP phrase route} {
+ catch { unset state($prop) }
+ }
+
+ switch -- [set code [catch { mime::addr_specification $token } result]] {
+ 0 {
+ if {!$result} {
+ return 0
+ }
+
+ switch -- $state(lastC) {
+ LX_COMMA
+ -
+ LX_END {
+ }
+ default {
+ # catch trailing comments...
+ set lookahead $state(input)
+ mime::parselexeme $token
+ set state(input) $lookahead
+ }
+ }
+ }
+
+ 7 {
+ set state(error) $result
+
+ while {1} {
+ switch -- $state(lastC) {
+ LX_COMMA
+ -
+ LX_END {
+ break
+ }
+
+ default {
+ mime::parselexeme $token
+ }
+ }
+ }
+ }
+
+ default {
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+ }
+ }
+
+ foreach prop {comment domain error group local memberP phrase route} {
+ if {![info exists state($prop)]} {
+ set state($prop) ""
+ }
+ }
+
+ return 1
+}
+
+# ::mime::addr_specification --
+#
+# Uses lookahead parsing to determine whether there is another
+# valid e-mail address or not. Throws errors if unrecognized
+# or invalid e-mail address syntax is used.
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns 1 if there is another address, and 0 if there is not.
+
+proc ::mime::addr_specification {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set lookahead $state(input)
+ switch -- [parselexeme $token] {
+ LX_ATOM
+ -
+ LX_QSTRING {
+ set state(phrase) $state(buffer)
+ }
+
+ LX_SEMICOLON {
+ if {[incr state(glevel) -1] < 0} {
+ return -code 7 "extraneous semi-colon"
+ }
+
+ catch { unset state(comment) }
+ return [addr_specification $token]
+ }
+
+ LX_COMMA {
+ catch { unset state(comment) }
+ return [addr_specification $token]
+ }
+
+ LX_END {
+ return 0
+ }
+
+ LX_LBRACKET {
+ return [addr_routeaddr $token]
+ }
+
+ LX_ATSIGN {
+ set state(input) $lookahead
+ return [addr_routeaddr $token 0]
+ }
+
+ default {
+ return -code 7 \
+ [format "unexpected character at beginning (found %s)" \
+ $state(buffer)]
+ }
+ }
+
+ switch -- [parselexeme $token] {
+ LX_ATOM
+ -
+ LX_QSTRING {
+ append state(phrase) " " $state(buffer)
+
+ return [addr_phrase $token]
+ }
+
+ LX_LBRACKET {
+ return [addr_routeaddr $token]
+ }
+
+ LX_COLON {
+ return [addr_group $token]
+ }
+
+ LX_DOT {
+ set state(local) "$state(phrase)$state(buffer)"
+ unset state(phrase)
+ mime::addr_routeaddr $token 0
+ mime::addr_end $token
+ }
+
+ LX_ATSIGN {
+ set state(memberP) $state(glevel)
+ set state(local) $state(phrase)
+ unset state(phrase)
+ mime::addr_domain $token
+ mime::addr_end $token
+ }
+
+ LX_SEMICOLON
+ -
+ LX_COMMA
+ -
+ LX_END {
+ set state(memberP) $state(glevel)
+ if {(![string compare $state(lastC) LX_SEMICOLON]) \
+ && ([incr state(glevel) -1] < 0)} {
+ return -code 7 "extraneous semi-colon"
+ }
+
+ set state(local) $state(phrase)
+ unset state(phrase)
+ }
+
+ default {
+ return -code 7 [format "expecting mailbox (found %s)" \
+ $state(buffer)]
+ }
+ }
+
+ return 1
+}
+
+# ::mime::addr_routeaddr --
+#
+# Parses the domain portion of an e-mail address. Finds the '@'
+# sign and then calls mime::addr_route to verify the domain.
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns 1 if there is another address, and 0 if there is not.
+
+proc ::mime::addr_routeaddr {token {checkP 1}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set lookahead $state(input)
+ if {![string compare [parselexeme $token] LX_ATSIGN]} {
+ mime::addr_route $token
+ } else {
+ set state(input) $lookahead
+ }
+
+ mime::addr_local $token
+
+ switch -- $state(lastC) {
+ LX_ATSIGN {
+ mime::addr_domain $token
+ }
+
+ LX_SEMICOLON
+ -
+ LX_RBRACKET
+ -
+ LX_COMMA
+ -
+ LX_END {
+ }
+
+ default {
+ return -code 7 \
+ [format "expecting at-sign after local-part (found %s)" \
+ $state(buffer)]
+ }
+ }
+
+ if {($checkP) && ([string compare $state(lastC) LX_RBRACKET])} {
+ return -code 7 [format "expecting right-bracket (found %s)" \
+ $state(buffer)]
+ }
+
+ return 1
+}
+
+# ::mime::addr_route --
+#
+# Attempts to parse the portion of the e-mail address after the @.
+# Tries to verify that the domain definition has a valid form.
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+proc ::mime::addr_route {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set state(route) @
+
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_ATOM
+ -
+ LX_DLITERAL {
+ append state(route) $state(buffer)
+ }
+
+ default {
+ return -code 7 \
+ [format "expecting sub-route in route-part (found %s)" \
+ $state(buffer)]
+ }
+ }
+
+ switch -- [parselexeme $token] {
+ LX_COMMA {
+ append state(route) $state(buffer)
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_COMMA {
+ }
+
+ LX_ATSIGN {
+ append state(route) $state(buffer)
+ break
+ }
+
+ default {
+ return -code 7 \
+ [format "expecting at-sign in route (found %s)" \
+ $state(buffer)]
+ }
+ }
+ }
+ }
+
+ LX_ATSIGN
+ -
+ LX_DOT {
+ append state(route) $state(buffer)
+ }
+
+ LX_COLON {
+ append state(route) $state(buffer)
+ return
+ }
+
+ default {
+ return -code 7 \
+ [format "expecting colon to terminate route (found %s)" \
+ $state(buffer)]
+ }
+ }
+ }
+}
+
+# ::mime::addr_domain --
+#
+# Attempts to parse the portion of the e-mail address after the @.
+# Tries to verify that the domain definition has a valid form.
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+proc ::mime::addr_domain {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_ATOM
+ -
+ LX_DLITERAL {
+ append state(domain) $state(buffer)
+ }
+
+ default {
+ return -code 7 \
+ [format "expecting sub-domain in domain-part (found %s)" \
+ $state(buffer)]
+ }
+ }
+
+ switch -- [parselexeme $token] {
+ LX_DOT {
+ append state(domain) $state(buffer)
+ }
+
+ LX_ATSIGN {
+ append state(local) % $state(domain)
+ unset state(domain)
+ }
+
+ default {
+ return
+ }
+ }
+ }
+}
+
+# ::mime::addr_local --
+#
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+proc ::mime::addr_local {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set state(memberP) $state(glevel)
+
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_ATOM
+ -
+ LX_QSTRING {
+ append state(local) $state(buffer)
+ }
+
+ default {
+ return -code 7 \
+ [format "expecting mailbox in local-part (found %s)" \
+ $state(buffer)]
+ }
+ }
+
+ switch -- [parselexeme $token] {
+ LX_DOT {
+ append state(local) $state(buffer)
+ }
+
+ default {
+ return
+ }
+ }
+ }
+}
+
+# ::mime::addr_phrase --
+#
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+
+proc ::mime::addr_phrase {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_ATOM
+ -
+ LX_QSTRING {
+ append state(phrase) " " $state(buffer)
+ }
+
+ default {
+ break
+ }
+ }
+ }
+
+ switch -- $state(lastC) {
+ LX_LBRACKET {
+ return [addr_routeaddr $token]
+ }
+
+ LX_COLON {
+ return [addr_group $token]
+ }
+
+ LX_DOT {
+ append state(phrase) $state(buffer)
+ return [addr_phrase $token]
+ }
+
+ default {
+ return -code 7 \
+ [format "found phrase instead of mailbox (%s%s)" \
+ $state(phrase) $state(buffer)]
+ }
+ }
+}
+
+# ::mime::addr_group --
+#
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+proc ::mime::addr_group {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[incr state(glevel)] > 1} {
+ return -code 7 [format "nested groups not allowed (found %s)" \
+ $state(phrase)]
+ }
+
+ set state(group) $state(phrase)
+ unset state(phrase)
+
+ set lookahead $state(input)
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_SEMICOLON
+ -
+ LX_END {
+ set state(glevel) 0
+ return 1
+ }
+
+ LX_COMMA {
+ }
+
+ default {
+ set state(input) $lookahead
+ return [addr_specification $token]
+ }
+ }
+ }
+}
+
+# ::mime::addr_end --
+#
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+proc ::mime::addr_end {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ switch -- $state(lastC) {
+ LX_SEMICOLON {
+ if {[incr state(glevel) -1] < 0} {
+ return -code 7 "extraneous semi-colon"
+ }
+ }
+
+ LX_COMMA
+ -
+ LX_END {
+ }
+
+ default {
+ return -code 7 [format "junk after local@domain (found %s)" \
+ $state(buffer)]
+ }
+ }
+}
+
+# ::mime::addr_x400 --
+#
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+proc ::mime::addr_x400 {mbox key} {
+ if {[set x [string first "/$key=" [string toupper $mbox]]] < 0} {
+ return ""
+ }
+ set mbox [string range $mbox [expr {$x+[string length $key]+2}] end]
+
+ if {[set x [string first "/" $mbox]] > 0} {
+ set mbox [string range $mbox 0 [expr {$x-1}]]
+ }
+
+ return [string trim $mbox "\""]
+}
+
+# ::mime::parsedatetime --
+#
+# Fortunately the clock command in the Tcl 8.x core does all the heavy
+# lifting for us (except for timezone calculations).
+#
+# mime::parsedatetime takes a string containing an 822-style date-time
+# specification and returns the specified property.
+#
+# The list of properties and their ranges are:
+#
+# property range
+# ======== =====
+# hour 0 .. 23
+# lmonth January, February, ..., December
+# lweekday Sunday, Monday, ... Saturday
+# mday 1 .. 31
+# min 0 .. 59
+# mon 1 .. 12
+# month Jan, Feb, ..., Dec
+# proper 822-style date-time specification
+# rclock elapsed seconds between then and now
+# sec 0 .. 59
+# wday 0 .. 6 (Sun .. Mon)
+# weekday Sun, Mon, ..., Sat
+# yday 1 .. 366
+# year 1900 ...
+# zone -720 .. 720 (minutes east of GMT)
+#
+# Arguments:
+# value Either a 822-style date-time specification or '-now'
+# if the current date/time should be used.
+# property The property (from the list above) to return
+#
+# Results:
+# Returns the string value of the 'property' for the date/time that was
+# specified in 'value'.
+
+proc ::mime::parsedatetime {value property} {
+ if {![string compare $value -now]} {
+ set clock [clock seconds]
+ } else {
+ set clock [clock scan $value]
+ }
+
+ switch -- $property {
+ hour {
+ set value [clock format $clock -format %H]
+ }
+
+ lmonth {
+ return [clock format $clock -format %B]
+ }
+
+ lweekday {
+ return [clock format $clock -format %A]
+ }
+
+ mday {
+ set value [clock format $clock -format %d]
+ }
+
+ min {
+ set value [clock format $clock -format %M]
+ }
+
+ mon {
+ set value [clock format $clock -format %m]
+ }
+
+ month {
+ return [clock format $clock -format %b]
+ }
+
+ proper {
+ set gmt [clock format $clock -format "%d %b %Y %H:%M:%S" \
+ -gmt true]
+ if {[set diff [expr {($clock-[clock scan $gmt])/60}]] < 0} {
+ set s -
+ set diff [expr {-($diff)}]
+ } else {
+ set s +
+ }
+ set zone [format %s%02d%02d $s [expr {$diff/60}] [expr {$diff%60}]]
+
+ return [clock format $clock \
+ -format "%a, %d %b %Y %H:%M:%S $zone"]
+ }
+
+ rclock {
+ if {![string compare $value -now]} {
+ return 0
+ } else {
+ return [expr {[clock seconds]-$clock}]
+ }
+ }
+
+ sec {
+ set value [clock format $clock -format %S]
+ }
+
+ wday {
+ return [clock format $clock -format %w]
+ }
+
+ weekday {
+ return [clock format $clock -format %a]
+ }
+
+ yday {
+ set value [clock format $clock -format %j]
+ }
+
+ year {
+ set value [clock format $clock -format %Y]
+ }
+
+ zone {
+ regsub -all -- "\t" $value " " value
+ set value [string trim $value]
+ if {[set x [string last " " $value]] < 0} {
+ return 0
+ }
+ set value [string range $value [expr {$x+1}] end]
+ switch -- [set s [string index $value 0]] {
+ + - - {
+ if {![string compare $s +]} {
+ set s ""
+ }
+ 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))} {
+ error "malformed timezone-specification: $value"
+ }
+ set value $s[expr {$h*60+$m}]
+ }
+
+ default {
+ set value [string toupper $value]
+ set z1 [list UT GMT EST EDT CST CDT MST MDT PST PDT]
+ set z2 [list 0 0 -5 -4 -6 -5 -7 -6 -8 -7]
+ if {[set x [lsearch -exact $z1 $value]] < 0} {
+ error "unrecognized timezone-mnemonic: $value"
+ }
+ set value [expr {[lindex $z2 $x]*60}]
+ }
+ }
+ }
+
+ date2gmt
+ -
+ date2local
+ -
+ dst
+ -
+ sday
+ -
+ szone
+ -
+ tzone
+ -
+ default {
+ error "unknown property $property"
+ }
+ }
+
+ if {![string compare [set value [string trimleft $value 0]] ""]} {
+ set value 0
+ }
+ return $value
+}
+
+# ::mime::uniqueID --
+#
+# Used to generate a 'globally unique identifier' for the content-id.
+# The id is built from the pid, the current time, the hostname, and
+# a counter that is incremented each time a message is sent.
+#
+# Arguments:
+#
+# Results:
+# Returns the a string that contains the globally unique identifier
+# that should be used for the Content-ID of an e-mail message.
+
+proc ::mime::uniqueID {} {
+ variable mime
+
+ return "<[pid].[clock seconds].[incr mime(cid)]@[info hostname]>"
+}
+
+# ::mime::parselexeme --
+#
+# Used to implement a lookahead parser.
+#
+# Arguments:
+# token The MIME token to operate on.
+#
+# Results:
+# Returns the next token found by the parser.
+
+proc ::mime::parselexeme {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set state(input) [string trimleft $state(input)]
+
+ set state(buffer) ""
+ if {![string compare $state(input) ""]} {
+ set state(buffer) end-of-input
+ return [set state(lastC) LX_END]
+ }
+
+ set c [string index $state(input) 0]
+ set state(input) [string range $state(input) 1 end]
+
+ if {![string compare $c "("]} {
+ set noteP 0
+ set quoteP 0
+
+ while {1} {
+ append state(buffer) $c
+
+ switch -- $c/$quoteP {
+ "(/0" {
+ incr noteP
+ }
+
+ "\\/0" {
+ set quoteP 1
+ }
+
+ ")/0" {
+ if {[incr noteP -1] < 1} {
+ if {[info exists state(comment)]} {
+ append state(comment) " "
+ }
+ append state(comment) $state(buffer)
+
+ return [parselexeme $token]
+ }
+ }
+
+ default {
+ set quoteP 0
+ }
+ }
+
+ if {![string compare [set c [string index $state(input) 0]] ""]} {
+ set state(buffer) "end-of-input during comment"
+ return [set state(lastC) LX_ERR]
+ }
+ set state(input) [string range $state(input) 1 end]
+ }
+ }
+
+ if {![string compare $c "\""]} {
+ set firstP 1
+ set quoteP 0
+
+ while {1} {
+ append state(buffer) $c
+
+ switch -- $c/$quoteP {
+ "\\/0" {
+ set quoteP 1
+ }
+
+ "\"/0" {
+ if {!$firstP} {
+ return [set state(lastC) LX_QSTRING]
+ }
+ set firstP 0
+ }
+
+ default {
+ set quoteP 0
+ }
+ }
+
+ if {![string compare [set c [string index $state(input) 0]] ""]} {
+ set state(buffer) "end-of-input during quoted-string"
+ return [set state(lastC) LX_ERR]
+ }
+ set state(input) [string range $state(input) 1 end]
+ }
+ }
+
+ if {![string compare $c "\["]} {
+ set quoteP 0
+
+ while {1} {
+ append state(buffer) $c
+
+ switch -- $c/$quoteP {
+ "\\/0" {
+ set quoteP 1
+ }
+
+ "\]/0" {
+ return [set state(lastC) LX_DLITERAL]
+ }
+
+ default {
+ set quoteP 0
+ }
+ }
+
+ if {![string compare [set c [string index $state(input) 0]] ""]} {
+ set state(buffer) "end-of-input during domain-literal"
+ return [set state(lastC) LX_ERR]
+ }
+ set state(input) [string range $state(input) 1 end]
+ }
+ }
+
+ if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} {
+ append state(buffer) $c
+
+ return [set state(lastC) [lindex $state(lexemeL) $x]]
+ }
+
+ while {1} {
+ append state(buffer) $c
+
+ switch -- [set c [string index $state(input) 0]] {
+ "" - " " - "\t" - "\n" {
+ break
+ }
+
+ default {
+ if {[lsearch -exact $state(tokenL) $c] >= 0} {
+ break
+ }
+ }
+ }
+
+ set state(input) [string range $state(input) 1 end]
+ }
+
+ return [set state(lastC) LX_ATOM]
+}
+
+# ::mime::mapencoding --
+#
+# mime::mapencodings maps tcl encodings onto the proper names for their
+# MIME charset type. This is only done for encodings whose charset types
+# were known. The remaining encodings return "" for now.
+#
+# Arguments:
+# enc The tcl encoding to map.
+#
+# Results:
+# Returns the MIME charset type for the specified tcl encoding, or ""
+# if none is known.
+
+proc ::mime::mapencoding {enc} {
+
+ variable encodings
+
+ if {[info exists encodings($enc)]} {
+ return $encodings($enc)
+ }
+ return ""
+}
+
+# ::mime::reversemapencoding --
+#
+# mime::reversemapencodings maps MIME charset types onto tcl encoding names.
+# Those that are unknown return "".
+#
+# Arguments:
+# mimeType The MIME charset to convert into a tcl encoding type.
+#
+# Results:
+# Returns the tcl encoding name for the specified mime charset, or ""
+# if none is known.
+
+proc ::mime::reversemapencoding {mimeType} {
+
+ variable reversemap
+
+ set lmimeType [string tolower $mimeType]
+ if {[info exists reversemap($lmimeType)]} {
+ return $reversemap($lmimeType)
+ }
+ return ""
+}
+
+# ::mime::word_encode --
+#
+# Word encodes strings as per RFC 2047.
+#
+# Arguments:
+# charset The character set to encode the message to.
+# method The encoding method (base64 or quoted-printable).
+# string The string to encode.
+#
+# Results:
+# Returns a word encoded string.
+
+proc ::mime::word_encode {charset method string} {
+
+ variable encodings
+
+ if {![info exists encodings($charset)]} {
+ error "unknown charset '$charset'"
+ }
+
+ if {$encodings($charset) == ""} {
+ error "invalid charset '$charset'"
+ }
+
+ if {$method != "base64" && $method != "quoted-printable"} {
+ error "unknown method '$method', must be base64 or quoted-printable"
+ }
+
+ set result "=?$encodings($charset)?"
+ switch -exact -- $method {
+ base64 {
+ append result "B?[string trimright [base64 -mode encode -- $string] \n]?="
+ }
+ quoted-printable {
+ append result "Q?[qp_encode $string 1]?="
+ }
+ "" {
+ # Go ahead
+ }
+ default {
+ error "Can't handle content encoding \"$method\""
+ }
+ }
+
+ return $result
+}
+
+# ::mime::word_decode --
+#
+# Word decodes strings that have been word encoded as per RFC 2047.
+#
+# Arguments:
+# encoded The word encoded string to decode.
+#
+# Results:
+# Returns the string that has been decoded from the encoded message.
+
+proc ::mime::word_decode {encoded} {
+
+ variable reversemap
+
+ if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded \
+ - charset method string] != 1} {
+ error "malformed word-encoded expression '$encoded'"
+ }
+
+ set enc [reversemapencoding $charset]
+ if {[string equal "" $enc]} {
+ error "unknown charset '$charset'"
+ }
+
+ switch -exact -- $method {
+ B {
+ set method base64
+ }
+ Q {
+ set method quoted-printable
+ }
+ default {
+ error "unknown method '$method', must be B or Q"
+ }
+ }
+
+ switch -exact -- $method {
+ base64 {
+ set result [base64 -mode decode -- $string]
+ }
+ quoted-printable {
+ set result [qp_decode $string 1]
+ }
+ "" {
+ # Go ahead
+ }
+ default {
+ error "Can't handle content encoding \"$method\""
+ }
+ }
+
+ return [list $enc $method $result]
+}
+
+# ::mime::field_decode --
+#
+# Word decodes strings that have been word encoded as per RFC 2047
+# and converts the string from UTF to the original encoding/charset.
+#
+# Arguments:
+# field The string to decode
+#
+# Results:
+# Returns the decoded string in its original encoding/charset..
+
+proc ::mime::field_decode {field} {
+ # ::mime::field_decode is broken. Here's a new version.
+ # This code is in the public domain. Don Libes <don@libes.com>
+
+ # Step through a field for mime-encoded words, building a new
+ # version with unencoded equivalents.
+
+ # Sorry about the grotesque regexp. Most of it is sensible. One
+ # notable fudge: the final $ is needed because of an apparent bug
+ # in the regexp engine where the preceding .* otherwise becomes
+ # non-greedy - perhaps because of the earlier ".*?", sigh.
+
+ while {[regexp {(.*?)(=\?(?:[^?]+)\?(?:.)\?(?:[^?]*)\?=)(.*)$} $field ignore prefix encoded field]} {
+ # don't allow whitespace between encoded words per RFC 2047
+ if {"" != $prefix} {
+ if {![string is space $prefix]} {
+ append result $prefix
+ }
+ }
+
+ set decoded [word_decode $encoded]
+ foreach {charset - string} $decoded break
+
+ append result [::encoding convertfrom $charset $string]
+ }
+
+ append result $field
+ return $result
+}
+
Fisheye: Tag 1.3 refers to a dead (removed) revision in file `openacs-4/packages/acs-tcl/tcl/mime.tcl'.
Fisheye: No comparison available. Pass `N' to diff?