H4CK3R 5/hacker05/05_HACK_05.ISO/programacao/freewrap/TCLLIBsampleApp.exe/sample/tcllib/tcllib1.0/mime/mime.tcl

Text File | 2001-08-17 | 95.7 KB | 3,581 lines

# 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.2

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

    # 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} {
        # md5 is just used to uniquify something - bail for the moment
        # 31 is completely random - just want something long for boundaries
        return [string range $string 0 31]
        }
        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 \
            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($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 - 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
            }

            -root {
                # the following are internal options

                set state(root) $value
            }

            -offset {
                set state(offset) $value
            }

            -count {
                set state(count) $value
            }

            default {
                error "unknown option $option"
            }
        }
    }

    set valueN 0
    foreach value [list file parts string] {
        if {[info exists state($value)]} {
            set state(value) $value
            incr valueN
        }
    }
    if {$valueN != 1} {
        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) [mime::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 {[string length $string] == 0} {
                set blankP 1
            } else {
                switch -- [set pos [string first "\n" $string]] {
                    -1 {
                        set line $string
                        set string ""
                    }

                    0 {
                        set blankP 1
                        set line ""
                        set string [string range $string 1 end]
                    }

                    default {
                        set line [string range $string 0 [expr {$pos-1}]]
                        set string [string range $string [expr {$pos+1}] end]
                    }
                }
                set x [string length $line]
            }
        }

        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 [mime::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 {
            set state(string) $string
        }

        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 -string $state(string)
            }
        }

        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 {[string length $string] == 0} {
                error "end-of-string encountered while parsing $state(content)"
            }
            switch -- [set pos [string first "\n" $string]] {
                -1 {
                    set line $string
                    set string ""
                }

                0 {
                    set line ""
                    set string [string range $string 1 end]
                }

                default {
                    set line [string range $string 0 [expr {$pos-1}]]
                    set string [string range $string [expr {$pos+1}] end]
                }
            }
            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} {
                append start $line "\n"
            }

            continue
        }

        if {!$inP} {
            if {![string compare $line "--$boundary"]} {
                set inP 1
                if {$fileP} {
                    set start $pos
                } else {
                    set start ""
                }
            }

            continue
        }

        if {([set moreP [string compare $line "--$boundary--"]]) \
                && ([string compare $line "--$boundary"])} {
            if {$inP && !$fileP} {
                append start $line "\n"
            }
            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 -string \
                    [string range $start 0 [expr {[string length $start]-2}]]

            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 [mime::parselexeme $token] LX_ATOM]} {
        error [format "expecting type (found %s)" $state(buffer)]
    }
    set type [string tolower $state(buffer)]

    switch -- [mime::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 [mime::parselexeme $token] LX_ATOM]} {
        error [format "expecting subtype (found %s)" $state(buffer)]
    }
    append type [string tolower /$state(buffer)]

    array set params ""
    while {1} {
        switch -- [mime::parselexeme $token] {
            LX_END {
                return [list $type [array get params]]
            }

            LX_SEMICOLON {
            }

            default {
                error [format "expecting \";\" (found %s)" $state(buffer)]
            }
        }

        if {[string compare [mime::parselexeme $token] LX_ATOM]} {
            error [format "expecting attribute (found %s)" $state(buffer)]
        }
        set attribute [string tolower $state(buffer)]

        if {[string compare [mime::parselexeme $token] LX_EQUALS]} {
            error [format "expecting \"=\" (found %s)" $state(buffer)]
        }

        switch -- [mime::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     [mime::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 [mime::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 [mime::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]
                        }
            "" {
                # 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 {
                    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 [mime::encoding $token]
            }
            if {[string compare $encoding ""]} {
                puts $channel "Content-Transfer-Encoding: $encoding"
            }
            switch -- $encoding {
                base64
                    -
                quoted-printable {
                    set converter $encoding
                }
        "" {
            # 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)\n"
    }
    foreach lower $state(lowerL) mixed $state(mixedL) {
        foreach value $header($lower) {
            append result "$mixed: $value\n"
        }
    }
    if {(!$state(canonicalP)) \
            && ([string compare [set encoding $state(encoding)] ""])} {
        append result "Content-Transfer-Encoding: $encoding\n"
    }

    append result "Content-Type: $state(content)"
    set boundary ""
    foreach {k v} $state(params) {
        if {![string compare $k boundary]} {
            set boundary $v
        }

        append result ";\n              $k=\"$v\""
    }

    set converter ""
    set encoding ""
    if {[string compare $state(value) parts]} {
        append result \n

        if {$state(canonicalP)} {
            if {![string compare [set encoding $state(encoding)] ""]} {
                set encoding [mime::encoding $token]
            }
            if {[string compare $encoding ""]} {
                append result "Content-Transfer-Encoding: $encoding\n"
            }
            switch -- $encoding {
                base64
                    -
                quoted-printable {
                    set converter $encoding
                }
        "" {
            # 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 ";\n              boundary=\"$boundary\"\n"
    } else {
        append result "\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 "\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]\n"
        } else {
            append result "$X\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 "\n"
                    foreach part $state(parts) {
                        append result [mime::buildmessage $part]
                        break
                    }
                }

                default {
                    foreach part $state(parts) {
                        append result "\n--$boundary\n"
                        append result [mime::buildmessage $part]
                    }
                    append result "\n--$boundary--\n"
                }
            }

            if {[info exists state(fd)]} {
                catch { close $state(fd) }
                unset state(fd)
            }
        }

        string {

            append result "\n"

        if {[string compare $converter ""]} {
        append result "[$converter -mode encode -- $state(string)]\n"
        } else {
        append result "$state(string)\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 [mime::encodingasciiP $line]
                }
                if {$lineP} {
                    set lineP [mime::encodinglineP $line]
                }
                if {(!$asciiP) && (!$lineP)} {
                    break
                }
            }

            catch { close $fd }
        }

        parts {
            return ""
        }

        string {
            foreach line [split $state(string) "\n"] {
                if {$asciiP} {
                    set asciiP [mime::encodingasciiP $line]
                }
                if {$lineP} {
                    set lineP [mime::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}} {
    # 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\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

    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 {[mime::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 [mime::addr_x400 $mbox PN]] \
                                  ""]} {
                } elseif {([string compare \
                                   [set friendly [mime::addr_x400 $mbox S]] \
                                   ""]) \
                            && ([string compare \
                                        [set g [mime::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 -- [mime::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 [mime::addr_specification $token]
        }

        LX_COMMA {
            catch { unset state(comment) }
            return [mime::addr_specification $token]
        }

        LX_END {
            return 0
        }

        LX_LBRACKET {
            return [mime::addr_routeaddr $token]
        }

        LX_ATSIGN {
            set state(input) $lookahead
            return [mime::addr_routeaddr $token 0]
        }

        default {
            return -code 7 \
                   [format "unexpected character at beginning (found %s)" \
                           $state(buffer)]
        }
    }

    switch -- [mime::parselexeme $token] {
        LX_ATOM
            -
        LX_QSTRING {
            append state(phrase) " " $state(buffer)

            return [mime::addr_phrase $token]
        }

        LX_LBRACKET {
            return [mime::addr_routeaddr $token]
        }

        LX_COLON {
            return [mime::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 [mime::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 -- [mime::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 -- [mime::parselexeme $token] {
            LX_COMMA {
                append state(route) $state(buffer)
                while {1} {
                    switch -- [mime::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 -- [mime::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 -- [mime::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 -- [mime::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 -- [mime::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 -- [mime::parselexeme $token] {
            LX_ATOM
                -
            LX_QSTRING {
                append state(phrase) " " $state(buffer)
            }

            default {
                break
            }
        }
    }

    switch -- $state(lastC) {
        LX_LBRACKET {
            return [mime::addr_routeaddr $token]
        }

        LX_COLON {
            return [mime::addr_group $token]
        }

        LX_DOT {
            append state(phrase) $state(buffer)
            return [mime::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 -- [mime::parselexeme $token] {
            LX_SEMICOLON
                -
            LX_END {
                set state(glevel) 0
                return 1
            }

            LX_COMMA {
            }

            default {
                set state(input) $lookahead
                return [mime::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 [mime::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

    if {[info exists reversemap($mimeType)]} {
        return $reversemap($mimeType)
    }
    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'"
    }

    if {![info exists reversemap($charset)]} {
    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 $reversemap($charset) $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} {

    # flatten the list of items to reconstruct the string

    set field [join $field]

    set result ""
    while {[regexp -indices -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $field indices]} {

    # get the indices

    foreach {start end} $indices break

    # extract first part of field not containing the encoded-word

    append result [string range $field 0 [expr {$start-1}]]

    # retrieve decoded string and convert it to Unicode
    # from the original enconding/charset

    set decoded [word_decode [string range $field $start $end]]
        foreach {charset - string} $decoded break
    append result [::encoding convertfrom $charset $string]

    # remove encoded-word and trailing space (RFC 2047, see part 8)
    # from the rest of the string

    incr end
    set field [string trimleft [string range $field $end end]]
    }

    # append last part of field to the result after a space (need because
    # of the trimleft above)

    if {[string length $field]} {
    append result " "
    append result $field
    }

    return $result
}