Attachment "mime.tcl" to
ticket [1889835fff]
added by
hume
2008-02-09 03:44:53.
# 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.4.1
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
set major [lindex [split [package require md5] .] 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]
}
if {$::major < 2} {
# md5 v1, result is hex string ready for use.
proc md5 {-- string} {
return [md5::md5 $string]
}
} else {
# md5 v2, need option to get hex string
proc md5 {-- string} {
return [md5::md5 -hex $string]
}
}
}
unset major
}
#
# 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 Windows-1250 \
cp1251 Windows-1251 \
cp1252 Windows-1252 \
cp1253 Windows-1253 \
cp1254 Windows-1254 \
cp1255 Windows-1255 \
cp1256 Windows-1256 \
cp1257 Windows-1257 \
cp1258 Windows-1258 \
cp437 IBM437 \
cp737 "" \
cp775 IBM775 \
cp850 IBM850 \
cp852 IBM852 \
cp855 IBM855 \
cp857 IBM857 \
cp860 IBM860 \
cp861 IBM861 \
cp862 IBM862 \
cp863 IBM863 \
cp864 IBM864 \
cp865 IBM865 \
cp866 IBM866 \
cp869 IBM869 \
cp874 "" \
cp932 "" \
cp936 GBK \
cp949 "" \
cp950 "" \
dingbats "" \
ebcdic "" \
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-10 ISO-8859-10 \
iso8859-13 ISO-8859-13 \
iso8859-14 ISO-8859-14 \
iso8859-15 ISO-8859-15 \
iso8859-16 ISO-8859-16 \
jis0201 JIS_X0201 \
jis0208 JIS_C6226-1983 \
jis0212 JIS_X0212-1990 \
koi8-r KOI8-R \
koi8-u KOI8-U \
ksc5601 KS_C_5601-1987 \
macCentEuro "" \
macCroatian "" \
macCyrillic "" \
macDingbats "" \
macGreek "" \
macIceland "" \
macJapan "" \
macRoman "" \
macRomania "" \
macThai "" \
macTurkish "" \
macUkraine "" \
shiftjis Shift_JIS \
symbol "" \
tis-620 TIS-620 \
unicode "" \
utf-8 UTF-8]
variable encodings
array set encodings $encList
variable reversemap
foreach {enc mimeType} $encList {
if {$mimeType != ""} {
set reversemap([string tolower $mimeType]) $enc
}
}
set encAliasList [list \
ascii ANSI_X3.4-1968 \
ascii iso-ir-6 \
ascii ANSI_X3.4-1986 \
ascii ISO_646.irv:1991 \
ascii ASCII \
ascii ISO646-US \
ascii us \
ascii IBM367 \
ascii cp367 \
cp437 cp437 \
cp437 437 \
cp775 cp775 \
cp850 cp850 \
cp850 850 \
cp852 cp852 \
cp852 852 \
cp855 cp855 \
cp855 855 \
cp857 cp857 \
cp857 857 \
cp860 cp860 \
cp860 860 \
cp861 cp861 \
cp861 861 \
cp861 cp-is \
cp862 cp862 \
cp862 862 \
cp863 cp863 \
cp863 863 \
cp864 cp864 \
cp865 cp865 \
cp865 865 \
cp866 cp866 \
cp866 866 \
cp869 cp869 \
cp869 869 \
cp869 cp-gr \
cp936 CP936 \
cp936 MS936 \
cp936 Windows-936 \
iso8859-1 ISO_8859-1:1987 \
iso8859-1 iso-ir-100 \
iso8859-1 ISO_8859-1 \
iso8859-1 latin1 \
iso8859-1 l1 \
iso8859-1 IBM819 \
iso8859-1 CP819 \
iso8859-2 ISO_8859-2:1987 \
iso8859-2 iso-ir-101 \
iso8859-2 ISO_8859-2 \
iso8859-2 latin2 \
iso8859-2 l2 \
iso8859-3 ISO_8859-3:1988 \
iso8859-3 iso-ir-109 \
iso8859-3 ISO_8859-3 \
iso8859-3 latin3 \
iso8859-3 l3 \
iso8859-4 ISO_8859-4:1988 \
iso8859-4 iso-ir-110 \
iso8859-4 ISO_8859-4 \
iso8859-4 latin4 \
iso8859-4 l4 \
iso8859-5 ISO_8859-5:1988 \
iso8859-5 iso-ir-144 \
iso8859-5 ISO_8859-5 \
iso8859-5 cyrillic \
iso8859-6 ISO_8859-6:1987 \
iso8859-6 iso-ir-127 \
iso8859-6 ISO_8859-6 \
iso8859-6 ECMA-114 \
iso8859-6 ASMO-708 \
iso8859-6 arabic \
iso8859-7 ISO_8859-7:1987 \
iso8859-7 iso-ir-126 \
iso8859-7 ISO_8859-7 \
iso8859-7 ELOT_928 \
iso8859-7 ECMA-118 \
iso8859-7 greek \
iso8859-7 greek8 \
iso8859-8 ISO_8859-8:1988 \
iso8859-8 iso-ir-138 \
iso8859-8 ISO_8859-8 \
iso8859-8 hebrew \
iso8859-9 ISO_8859-9:1989 \
iso8859-9 iso-ir-148 \
iso8859-9 ISO_8859-9 \
iso8859-9 latin5 \
iso8859-9 l5 \
iso8859-10 iso-ir-157 \
iso8859-10 l6 \
iso8859-10 ISO_8859-10:1992 \
iso8859-10 latin6 \
iso8859-14 iso-ir-199 \
iso8859-14 ISO_8859-14:1998 \
iso8859-14 ISO_8859-14 \
iso8859-14 latin8 \
iso8859-14 iso-celtic \
iso8859-14 l8 \
iso8859-15 ISO_8859-15 \
iso8859-15 Latin-9 \
iso8859-16 iso-ir-226 \
iso8859-16 ISO_8859-16:2001 \
iso8859-16 ISO_8859-16 \
iso8859-16 latin10 \
iso8859-16 l10 \
jis0201 X0201 \
jis0208 iso-ir-87 \
jis0208 x0208 \
jis0208 JIS_X0208-1983 \
jis0212 x0212 \
jis0212 iso-ir-159 \
ksc5601 iso-ir-149 \
ksc5601 KS_C_5601-1989 \
ksc5601 KSC5601 \
ksc5601 korean \
shiftjis MS_Kanji \
utf-8 UTF8]
foreach {enc mimeType} $encAliasList {
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 [linsert $args 0 mime::initializeaux $token] } \
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 [linsert $args 0 mime::finalize $part]
}
}
}
dynamic {
for {set cid $state(cid)} {$cid > 0} {incr cid -1} {
eval [linsert $args 0 mime::finalize $token-$cid]
}
}
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:
# ?-decode? ?-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
set decode 0
if {[set pos [lsearch -exact $args -decode]] >= 0} {
set decode 1
set args [lreplace $args $pos $pos]
}
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
if {$code} {
return -code $code -errorinfo $einfo -errorcode $ecode $result
}
if {$decode} {
array set params [mime::getproperty $token params]
if {[info exists params(charset)]} {
set charset $params(charset)
} else {
set charset US-ASCII
}
set enc [reversemapencoding $charset]
if {$enc != ""} {
set result [::encoding convertfrom $enc $result]
} else {
return -code error "-decode failed: can't reversemap charset $charset"
}
}
return $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 -nonewline $channel [$converter -mode encode -- $X]
} else {
puts -nonewline $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}]
# [893516]
fconfigure $channel -buffersize $blocksize
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 {[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"
# ECH fix - if binary do not mess up chunk boundaries
append result $X
}
}
# ECH fix - now add the \r\n after the data
if {![string compare $converter ""]} { append result "\r\n" } ;# ECH fix
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'.
namespace eval ::mime {
variable WDAYS_SHORT [list Sun Mon Tue Wed Thu Fri Sat]
variable WDAYS_LONG [list Sunday Monday Tuesday Wednesday Thursday \
Friday Saturday]
# variable MONTHS_SHORT [list Jan Feb Mar Apr May Jun \
Jul Aug Sep Oct Nov Dec]
# variable MONTHS_LONG [list January February March April May June July \
August Sepember October November December]
}
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 {
# variable MONTHS_LONG
return [clock format $clock -format %B]
}
lweekday {
variable WDAYS_LONG
return [lindex $WDAYS_LONG [clock format $clock -format %w]]
}
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 {
#variable MONTHS_SHORT
#return [lindex $MONTHS_SHORT [clock format $clock -format %e]]
# ECH bug fix
return [clock format $clock -format %b]
}
proper {
set gmt [clock format $clock -format "%Y-%m-%d %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}]]
variable WDAYS_SHORT
set wday [lindex $WDAYS_SHORT [clock format $clock -format %w]]
#variable MONTHS_SHORT
#set mon [lindex $MONTHS_SHORT [clock format $clock -format %e]]
# ECH bug fix
set mon [clock format $clock -format %h]
return [clock format $clock \
-format "$wday, %d $mon %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 {
variable WDAYS_SHORT
return [lindex $WDAYS_SHORT [clock format $clock -format %w]]
}
yday {
set value [clock format $clock -format %j]
}
year {
set value [clock format $clock -format %Y]
}
zone {
set value [string trim [string map [list "\t" " "] $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 -
B {
set method base64
}
q -
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 <[email protected]>
# 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
}
