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 , 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 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 + + # 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?