Tcl Library Source Code

# # ## ### ##### ######## #############
# copyright
#
#     2018
#
#     Poor Yorick
# # ## ### ##### ######## #############
package require ego
tcllib::ego .new ::tcllib::chan::base
::tcllib::chan::base .eval {

proc .init {_ channame args} {
    $_ .vars chan close
    if {$channame ni [::chan names]} {
	error [list {unknown channel} $channame]
    }
    set chan $channame

	proc $name {_ args} [string map [
	    list @name@ [list $name]] {
	    ::chan @name@ [$_ $ chan] {*}$args
	}]
	.my .method $name
    }
} [namespace current]]
}
namespace eval ::tcllib::chan {
	namespace export base
}
package provide {chan base} 0.1

#! /usr/bin/tclsh

# # ## ### ##### ######## #############
# copyright
#
#     2018
#
#     Poor Yorick
# # ## ### ##### ######## #############

package require coroutine
package require ego
namespace eval ::tcllib::chan::coroutine {

proc [namespace current] chan {
	if {![string match ::* $chan]} {
		set chan [uplevel 1 [list ::namespace which $chan]]
	}
	$chan .specialize
	foreach name {

}


proc read {_ args} {
	$_ .vars chan
	tailcall ::coroutine::util::read $chan {*}$args
}
}

package provide {chan coroutine} 0.1
namespace eval ::tcllib::chan {
	namespace export coroutine
}

# # ## ### ##### ######## #############
# copyright
#
#     2018
#
#     Poor Yorick
# # ## ### ##### ######## #############
package require ego
namespace eval ::tcllib::chan::getslimit {
variable buf bufcount eof getslimit

proc [namespace current] chan {
	if {![string match ::* $chan]} {
		set chan [uplevel 1 [list ::namespace which $chan]]
	}
	$chan .specialize

	    }
	}
    } elseif {[llength $args]} {
	dict size $args
	foreach {key val} $args[set args {}] {
	    if {$key eq {-getslimit}} {
		set getslimit $val
	    } else {
		lappend args $key $val
	    }
	}
	if {[llength $args]} {
	    uplevel 1 [list $_ .prototype configure {*}$args]
	}
	set res {}

proc  eof _ {
    $_ .vars bufcount eof
    return [expr {$eof || ( [$_ .prototype eof] && $bufcount == 0 )}]
}


proc gets {_ args} {
    $_ .vars buf bufcount chan eof getslimit
    switch [llength $args] {
	1 {
	    lassign $args varname
	    upvar 1 $varname resvar
	}
	0 {}
	default {

    } else {
	return $res
    }
}


proc read {_ args} {
    $_ .vars buf eof bufcount
    if {$eof} {
	return {}
    }
    if {$bufcount} {
	if {[llength $args]} {
	    lassign $args size
	    if {$size <= $bufcount} {

	    set res $buf[set buf {}][$_ .prototype read {*}$args]
	}
    } else {
	set res [$_ .prototype read {*}$args]
    }
    return $res
}
}

package provide tcllib::chan::getslimit 1
package provide {chan getslimit} 0.1
namespace eval ::tcllib::chan {
	namespace export getslimit
}

if {![package vsatisfies [package provide Tcl] 8.6]} {return}

package ifneeded {chan getslimit} 0.1 [list ::source [file join $dir getslimit.tcl]]









package ifneeded {chan base}      0.1 [list ::source [file join $dir base.tcl]]










package ifneeded {chan coroutine} 0.1 [list ::source [file join $dir coroutine.tcl]]

proc useLocal {fname pname args} {
    set nsname ::$pname
    if {[llength $args]} {set nsname [lindex $args 0]}

    package forget $pname
    catch {namespace delete $nsname}

    if {[catch {


	uplevel 1 [list useLocalFile $fname]
    } msg]} {
	puts "    Aborting the tests found in \"[file tail [info script]]\""
	puts "    Error in [file tail $fname]: $msg"
	return -code error ""
    }

    puts "$::tcllib::testutils::tag [list $pname] [package present $pname]"

    return
}

proc useLocalKeep {fname pname args} {
    set nsname ::$pname
    if {[llength $args]} {set nsname [lindex $args 0]}

    package forget $pname

	return -code return
    }
    return
}

proc testing {script} {
    InitializeTclTest
    set ::tcllib::testutils::tag "*"
    if {[catch {


	uplevel 1 $script
    } msg]} {
	set prefix "SETUP Error (Testing): "
	puts $prefix[join [split $::errorInfo \n] "\n$prefix"]

	return -code return
    }
    return
}

proc useTcllibC {} {
    set index [tcllibPath tcllibc/pkgIndex.tcl]
    if {![file exists $index]} {
	# Might have an external tcllibc
	if {![catch {

# # ## ### ##### ######## #############
# copyright
#
#     2018
#
#     Poor Yorick
# # ## ### ##### ######## #############

namespace eval ::tcllib::ego {
namespace ensemble create
namespace export *

proc .method {_ name args} {
	if {![llength $args]} {
		lappend args $name
	}
	set args [linsert $args[set args {}] 1 $_]
	set map [namespace ensemble configure $_ -map]
	dict set map $name $args
	uplevel 1 [list ::namespace ensemble configure $_ -map $map]
	return
}
.method [namespace current] .method


proc $ {_ name args} {

}
.method [namespace current] .as


proc .eval {_ args} {
	::tailcall ::namespace eval [$_ .namespace] {*}$args
}
.method [namespace current] .eval


proc .insert {_ name} {
	set unknown1 [namespace ensemble configure $_ -unknown]
	set prototype1 [namespace ensemble configure $_ -prototype]

	if {[llength $unknown1]} {
		namespace ensemble configure $name -prototype $prototype1 \
			-unknown $unknown1
	}

	namespace enemble configure $_ -prototype [list ::lindex $name] -unknown $unknown1
	return
}


proc .name _ {
	return $_
}
.method [namespace current] .name


proc .namespace _ {
	namespace ensemble configure $_ -namespace
}
.method [namespace current] .namespace


proc .new {_ name args} {
	global env
	set ns [uplevel 1 [list ::namespace eval $name {
		::namespace ensemble create
		::variable configured 0

	set prototype $_
	set map [namespace ensemble configure $_ -map]

	set prototypes {}
	while {[dict exists $map .prototype]} {
		set prototypes [list $map {*}$prototypes[set prototypes {}]]
		lassign [dict get $map .prototype] prototype
		set map [namespace ensemble configure $prototype -map]
	}

	set map {}
	foreach {key val} [namespace ensemble configure $prototype -map] {
		if {$key ne {.prototype}} {
			if {[lindex $val 1] eq $_} {
				set val [lreplace $val[set val {}] 1 1 $ns]
			}
		} else {
			error [list {how did we get to here?}]
		}
		lappend map $key $val
	}

	namespace ensemble configure $ns -map $map

	set prototype $ns
	foreach map $prototypes {
		$ns .specialize
		dict unset map .prototype
		dict for {name cmd} $map {
			if {[lindex $cmd 1] eq $_} {
				# remove the original name from index 1 because .method is
				# going to add it back
				$ns .method $name {*}[lreplace $cmd[set cmd {}] 1 1]
			} else {
				$ns .routine $name {*}$cmd
			}
		}
	}

	interp alias {} ${ns}::.my {} $ns

	if {[llength $args]} {
		tailcall $ns .init {*}$args
	} else {
		return $ns
	}
}
.method [namespace current] .new


proc .ondelete {_ trace args} {
    if {[llength $args] == 1} {
	lassign $args script
	trace remove command $_ delete $trace
	set trace {}

		lappend args $name
	}
	set map [namespace ensemble configure $_ -map]
	dict set map $name $args
	uplevel 1 [list ::namespace ensemble configure $_ -map $map]
	return
}
.method [namespace current] .routine


proc .specialize {_ args} {
	set ns [$_ .namespace]
	while {[namespace which [set name ${ns}::[
		info cmdcount]_prototype]] ne {}} {}
	rename $_ $name

	set new [namespace eval ${ns} [
		list namespace ensemble create -command $_ -map [list \
			.prototype [list $name]
		] -unknown [
			list ::apply {{_ name args} {

			set prototype [lindex [dict get [namespace ensemble configure $_ -map] .prototype] 0]
			list $prototype $name
		}}]]]

	::trace add command $new delete [list ::apply {{ns oldname newname op} {
		if {[namespace exists $ns]} {
			namespace delete $ns
		}
	}} $ns]
	return
}
.method [namespace current] .specialize


proc .vars {_ args} {
	set vars {}
	foreach arg $args {
		lassign $arg source target
		if {[llength $arg] == 1} {
			set target $source
		}
		lappend vars $source $target
	}
	uplevel 1 [list ::namespace upvar $_ {*}$vars]
}
.method [namespace current] .vars


proc = {_ name val} {
	set [$_ .namespace]::$name $val
}
.method [namespace current] =
}
package provide ego 0.1

#! /usr/bin/env tclsh

if {![package vsatisfies [package provide Tcl] 8.6]} {return}

package ifneeded ego 0.1 [list ::source [file join $dir ego.tcl]]

#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Originally by Brent Welch, with help from Dan Kuchler and Melissa Chawla

package require Tcl 8.2
package require ncgi 1.4
package provide html 1.4.5

namespace eval ::html {

    # State about the current page

    variable page

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.5
testsNeedTcltest 2.0

support {
    use           md5/md5x.tcl   md5
    use           mime/mime-1.6.tcl  mime
    use           ncgi/ncgi-1.4.tcl  ncgi
}
testing {
    useLocal html.tcl html
}

# -------------------------------------------------------------------------

test html-1.1 {html::init} -body {

    ncgi::parse
    html::textInput email [email protected]
} {<input type="text" name="email" value="[email protected]">
}

test html-13.6 {html::textInput} {
    html::init
    ncgi::reset
    ncgi::parse
    html::textInput email [email protected] size="80"
} {<input type="text" name="email" value="[email protected]" size="80">
}

test html-13.7 {html::textInput} {
    html::init {

test html-27.8 {html::foreach--subst body w/ nested foreach} {
    html::foreach x {a b} {
        [html::foreach y {c d} {$x$y}]
    }
} {
        acad

        bcbd
    }

test html-27.9 {html::foreach--subst body w/ multiple nested foreach's} {
    html::foreach x {a b} {
        [html::foreach y {c d} {$x$y
            [html::foreach z {e f} {$z}]
        }]}
} {
        ac
            ef
        ad
            ef

        bc
            ef
        bd
            ef
        }

test html-28.1 {html::for--1 iteration} {

# support the SCGI module
###

package require uri
package require dns
package require cron
package require coroutine
package require -exact mime 1.6
package require fileutil
package require websocket
package require Markdown
package require fileutil::magic::filetype
package require clay 0.7

namespace eval httpd::content {}

testsNeed TclOO 1

support {
  use [file join ${TCLLIBMOD} cmdline cmdline.tcl]      cmdline
  use [file join ${TCLLIBMOD} fileutil fileutil.tcl]    fileutil
  use [file join ${TCLLIBMOD} sha1 sha1.tcl]            sha1
  use [file join ${TCLLIBMOD} mime mime-1.6.tcl]            mime
  use [file join ${TCLLIBMOD} uri uri.tcl]              uri

  use [file join ${TCLLIBMOD} dns ip.tcl]               ip
  use [file join ${TCLLIBMOD} nettool nettool.tcl]      nettool
  use [file join ${TCLLIBMOD} coroutine coroutine.tcl]  coroutine
  use [file join ${TCLLIBMOD} cron cron.tcl]            cron
  #use [file join ${TCLLIBMOD} virtchannel_core core.tcl] tcl::chan::core
  #use [file join ${TCLLIBMOD} virtchannel_core events.tcl] tcl::chan::events
  use [file join ${TCLLIBMOD} virtchannel_base memchan.tcl] tcl::chan::memchan
  use [file join ${MODDIR} clay clay.tcl]               clay
}

testing {
  useLocal httpd.tcl httpd
}

#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: javascript.tcl,v 1.5 2005/09/30 05:36:39 andreas_kupries Exp $

package require Tcl 8
package require ncgi 1.4
package provide javascript 1.0.2


namespace eval ::javascript {

    # The SelectionObjList namespace variable is used to keep the list of
    # selection boxes that were created as parts of paired multi-selection

    # Empty the selection box for the next page.

    set SelectionObjList {}

    # Create the HTML submit button.

    append html "<input type=submit name=\"$name\" value=\"$value\"
    onClick=\"getSelections(this.form)\">"

    return $html
}

# ::javascript::makeProtectedSubmitButton --
#

    append html "        return false\n"
    append html "    \}\n"
    append html "\}\n"
    append html [EndJS]

    # Create the HTML submit button.

    append html "<input type=submit name=\"$name\" value=\"$value\"
    onClick=\"return areYouSure${name}(this.form)\">"

    return $html
}

# ::javascript::makeMasterButton --
#

    append html "        if (form.elements\[i\].name.match('$slavePattern')) \{\n"
    append html "            form.elements\[i\].checked = $boolean \n"
    append html "        \}\n"
    append html "    \}\n"

    append html "\}\n"
    append html [EndJS]

    # Create the HTML button object.

    append html "<input type=button name=\"$master\" value=\"$value\" " \
	    "onClick=\"checkMaster${master}(this.form)\">\n"

    return $html
}

# mime.tcl - MIME body parts
#
# (c) 1999-2000 Marshall T. Rose
# (c) 2000      Brent Welch
# (c) 2000      Sandeep Tamhankar
# (c) 2000      Dan Kuchler
# (c) 2000-2001 Eric Melski
# (c) 2001      Jeff Hobbs
# (c) 2001-2008 Andreas Kupries
# (c) 2002-2003 David Welton
# (c) 2003-2008 Pat Thoyts
# (c) 2005      Benjamin Riefenstahl
# (c) 2013      PoorYorick
#
#
# 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.5

package provide mime 1.6

if {[catch {package require Trf 2.0}]} {

    # Fall-back to tcl-based procedures of base64 and quoted-printable encoders
    # Warning!
    # These are a fragile emulations of the more general calling sequence
    # that appears to work with this code here.

    package require base64 2.0
    set ::major [lindex [split [package require md5] .] 0]

    # Create these commands in the mime namespace so that they
    # won't collide with things at the global namespace level

    namespace eval ::mime {
        proc base64 {-mode what -- chunk} {
            return [base64::$what $chunk]
        }
        proc quoted-printable {-mode what -- chunk} {
            return [mime::qp_$what $chunk]
        }

        if {$::major < 2} {
            # md5 v1, result is hex string ready for use.
            proc md5 {-- string} {
                return [md5::md5 $string]
            }
        } else {
            # md5 v2, need option to get hex string
            proc md5 {-- string} {
                return [md5::md5 -hex $string]
            }
        }
    }

    unset ::major
}

#
# state variables:
#
#     canonicalP: input is in its canonical form
#     content: type/subtype
#     params: seralized array of key/value pairs (keys are lower-case)
#     encoding: transfer encoding
#     version: MIME-version
#     header: serialized array of key/value pairs (keys are lower-case)
#     lowerL: list of header keys, lower-case
#     mixedL: list of header keys, mixed-case
#     value: either "file", "parts", or "string"
#
#     file: input file
#     fd: cached file-descriptor, typically for root
#     root: token for top-level part, for (distant) subordinates
#     offset: number of octets from beginning of file/string
#     count: length in octets of (encoded) content
#
#     parts: list of bodies (tokens)
#
#     string: input string
#
#     cid: last child-id assigned
#


namespace eval ::mime {
    variable mime
    array set mime {uid 0 cid 0}

    # RFC 822 lexemes
    variable addrtokenL
    lappend addrtokenL \; , < > : . ( ) @ \" \[ ] \\
    variable addrlexemeL {
        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
    }

    # RFC 2045 lexemes
    variable typetokenL
    lappend typetokenL \; , < > : ? ( ) @ \" \[ \] = / \\
    variable typelexemeL {
        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
    }

    variable encList {
        ascii US-ASCII
        big5 Big5
        cp1250 Windows-1250
        cp1251 Windows-1251
        cp1252 Windows-1252
        cp1253 Windows-1253
        cp1254 Windows-1254
        cp1255 Windows-1255
        cp1256 Windows-1256
        cp1257 Windows-1257
        cp1258 Windows-1258
        cp437 IBM437
        cp737 {}
        cp775 IBM775
        cp850 IBM850
        cp852 IBM852
        cp855 IBM855
        cp857 IBM857
        cp860 IBM860
        cp861 IBM861
        cp862 IBM862
        cp863 IBM863
        cp864 IBM864
        cp865 IBM865
        cp866 IBM866
        cp869 IBM869
        cp874 {}
        cp932 {}
        cp936 GBK
        cp949 {}
        cp950 {}
        dingbats {}
        ebcdic {}
        euc-cn EUC-CN
        euc-jp EUC-JP
        euc-kr EUC-KR
        gb12345 GB12345
        gb1988 GB1988
        gb2312 GB2312
        iso2022 ISO-2022
        iso2022-jp ISO-2022-JP
        iso2022-kr ISO-2022-KR
        iso8859-1 ISO-8859-1
        iso8859-2 ISO-8859-2
        iso8859-3 ISO-8859-3
        iso8859-4 ISO-8859-4
        iso8859-5 ISO-8859-5
        iso8859-6 ISO-8859-6
        iso8859-7 ISO-8859-7
        iso8859-8 ISO-8859-8
        iso8859-9 ISO-8859-9
        iso8859-10 ISO-8859-10
        iso8859-13 ISO-8859-13
        iso8859-14 ISO-8859-14
        iso8859-15 ISO-8859-15
        iso8859-16 ISO-8859-16
        jis0201 JIS_X0201
        jis0208 JIS_C6226-1983
        jis0212 JIS_X0212-1990
        koi8-r KOI8-R
        koi8-u KOI8-U
        ksc5601 KS_C_5601-1987
        macCentEuro {}
        macCroatian {}
        macCyrillic {}
        macDingbats {}
        macGreek {}
        macIceland {}
        macJapan {}
        macRoman {}
        macRomania {}
        macThai {}
        macTurkish {}
        macUkraine {}
        shiftjis Shift_JIS
        symbol {}
        tis-620 TIS-620
        unicode {}
        utf-8 UTF-8
    }

    variable encodings
    array set encodings $encList
    variable reversemap
    # Initialized at the bottom of the file

    variable encAliasList {
        ascii ANSI_X3.4-1968
        ascii iso-ir-6
        ascii ANSI_X3.4-1986
        ascii ISO_646.irv:1991
        ascii ASCII
        ascii ISO646-US
        ascii us
        ascii IBM367
        ascii cp367
        cp437 cp437
        cp437 437
        cp775 cp775
        cp850 cp850
        cp850 850
        cp852 cp852
        cp852 852
        cp855 cp855
        cp855 855
        cp857 cp857
        cp857 857
        cp860 cp860
        cp860 860
        cp861 cp861
        cp861 861
        cp861 cp-is
        cp862 cp862
        cp862 862
        cp863 cp863
        cp863 863
        cp864 cp864
        cp865 cp865
        cp865 865
        cp866 cp866
        cp866 866
        cp869 cp869
        cp869 869
        cp869 cp-gr
        cp936 CP936
        cp936 MS936
        cp936 Windows-936
        iso8859-1 ISO_8859-1:1987
        iso8859-1 iso-ir-100
        iso8859-1 ISO_8859-1
        iso8859-1 latin1
        iso8859-1 l1
        iso8859-1 IBM819
        iso8859-1 CP819
        iso8859-2 ISO_8859-2:1987
        iso8859-2 iso-ir-101
        iso8859-2 ISO_8859-2
        iso8859-2 latin2
        iso8859-2 l2
        iso8859-3 ISO_8859-3:1988
        iso8859-3 iso-ir-109
        iso8859-3 ISO_8859-3
        iso8859-3 latin3
        iso8859-3 l3
        iso8859-4 ISO_8859-4:1988
        iso8859-4 iso-ir-110
        iso8859-4 ISO_8859-4
        iso8859-4 latin4
        iso8859-4 l4
        iso8859-5 ISO_8859-5:1988
        iso8859-5 iso-ir-144
        iso8859-5 ISO_8859-5
        iso8859-5 cyrillic
        iso8859-6 ISO_8859-6:1987
        iso8859-6 iso-ir-127
        iso8859-6 ISO_8859-6
        iso8859-6 ECMA-114
        iso8859-6 ASMO-708
        iso8859-6 arabic
        iso8859-7 ISO_8859-7:1987
        iso8859-7 iso-ir-126
        iso8859-7 ISO_8859-7
        iso8859-7 ELOT_928
        iso8859-7 ECMA-118
        iso8859-7 greek
        iso8859-7 greek8
        iso8859-8 ISO_8859-8:1988
        iso8859-8 iso-ir-138
        iso8859-8 ISO_8859-8
        iso8859-8 hebrew
        iso8859-9 ISO_8859-9:1989
        iso8859-9 iso-ir-148
        iso8859-9 ISO_8859-9
        iso8859-9 latin5
        iso8859-9 l5
        iso8859-10 iso-ir-157
        iso8859-10 l6
        iso8859-10 ISO_8859-10:1992
        iso8859-10 latin6
        iso8859-14 iso-ir-199
        iso8859-14 ISO_8859-14:1998
        iso8859-14 ISO_8859-14
        iso8859-14 latin8
        iso8859-14 iso-celtic
        iso8859-14 l8
        iso8859-15 ISO_8859-15
        iso8859-15 Latin-9
        iso8859-16 iso-ir-226
        iso8859-16 ISO_8859-16:2001
        iso8859-16 ISO_8859-16
        iso8859-16 latin10
        iso8859-16 l10
        jis0201 X0201
        jis0208 iso-ir-87
        jis0208 x0208
        jis0208 JIS_X0208-1983
        jis0212 x0212
        jis0212 iso-ir-159
        ksc5601 iso-ir-149
        ksc5601 KS_C_5601-1989
        ksc5601 KSC5601
        ksc5601 korean
        shiftjis MS_Kanji
        utf-8 UTF8
    }

    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 -parts 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 {[catch {{*}[list mime::initializeaux $token {*}$args]} result eopts]} {
        catch {mime::finalize $token -subordinates dynamic}
        return -options $eopts $result
    }
    return $token
}

# ::mime::initializeaux --
#
#    Configures the MIME token created in mime::initialize based on
#       the arguments that mime::initialize supports.
#
# Arguments:
#       token  The MIME token to configure.
#    args   Args can be any one of the following:
#                  ?-canonical type/subtype
#                  ?-param    {key value}?...
#                  ?-encoding value?
#                  ?-header   {key value}?... ?
#                  (-file name | -string value | -parts {token1 ... tokenN})
#
# Results:
#       Either configures the mime token, or throws an error.

proc ::mime::initializeaux {token args} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set params [set state(params) {}]
    set state(encoding) {}
    set state(version) 1.0

    set state(header) {}
    set state(lowerL) {}
    set state(mixedL) {}

    set state(cid) 0

    set argc [llength $args]
    for {set argx 0} {$argx < $argc} {incr argx} {
        set option [lindex $args $argx]
        if {[incr argx] >= $argc} {
            error "missing argument to $option"
        }
        set value [lindex $args $argx]

        switch -- $option {
            -canonical {
                set state(content) [string tolower $value]
            }

            -param {
                if {[llength $value] != 2} {
                    error "-param expects a key and a value, not $value"
                }
                set lower [string tolower [set mixed [lindex $value 0]]]
                if {[info exists params($lower)]} {
                    error "the $mixed parameter may be specified at most once"
                }

                set params($lower) [lindex $value 1]
                set state(params) [array get params]
            }

            -encoding {
                switch -- [set state(encoding) [string tolower $value]] {
                    7bit - 8bit - binary - quoted-printable - base64 {
                    }

                    default {
                        error "unknown value for -encoding $state(encoding)"
                    }
                }
            }

            -header {
                if {[llength $value] != 2} {
                    error "-header expects a key and a value, not $value"
                }
                set lower [string tolower [set mixed [lindex $value 0]]]
                if {$lower eq "content-type"} {
                    error "use -canonical instead of -header $value"
                }
                if {$lower eq "content-transfer-encoding"} {
                    error "use -encoding instead of -header $value"
                }
                if {$lower in {content-md5 mime-version}} {
                    error "don't go there..."
                }
                if {$lower ni $state(lowerL)} {
                    lappend state(lowerL) $lower
                    lappend state(mixedL) $mixed
                }

                array set header $state(header)
                lappend header($lower) [lindex $value 1]
                set state(header) [array get header]
            }

            -file {
                set state(file) $value
            }

            -parts {
                set state(parts) $value
            }

            -string {
                set state(string) $value

                set state(lines) [split $value \n]
                set state(lines.count) [llength $state(lines)]
                set state(lines.current) 0
            }

            -root {
                # the following are internal options

                set state(root) $value
            }

            -offset {
                set state(offset) $value
            }

            -count {
                set state(count) $value
            }

            -lineslist {
                set state(lines) $value
                set state(lines.count) [llength $state(lines)]
                set state(lines.current) 0
                #state(string) is needed, but will be built when required
                set state(string) {}
            }

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

    #We only want one of -file, -parts or -string:
    set valueN 0
    foreach value {file parts string} {
        if {[info exists state($value)]} {
            set state(value) $value
            incr valueN
        }
    }
    if {$valueN != 1 && ![info exists state(lines)]} {
        error "specify exactly one of -file, -parts, or -string"
    }

    if {[set state(canonicalP) [info exists state(content)]]} {
        switch -- $state(value) {
            file {
                set state(offset) 0
            }

            parts {
                switch -glob -- $state(content) {
                    text/*
                        -
                    image/*
                        -
                    audio/*
                        -
                    video/* {
                        error "-canonical $state(content) and -parts do not mix"
                    }

                    default {
                        if {$state(encoding) ne {}} {
                            error "-encoding and -parts do not mix"
                        }
                    }
                }
            }
            default {# Go ahead}
        }

        if {[lsearch -exact $state(lowerL) content-id] < 0} {
            lappend state(lowerL) content-id
            lappend state(mixedL) Content-ID

            array set header $state(header)
            lappend header(content-id) [uniqueID]
            set state(header) [array get header]
        }

        set state(version) 1.0

        return
    }

    if {$state(params) ne {}} {
        error "-param requires -canonical"
    }
    if {$state(encoding) ne {}} {
        error "-encoding requires -canonical"
    }
    if {$state(header) ne {}} {
        error "-header requires -canonical"
    }
    if {[info exists state(parts)]} {
        error "-parts requires -canonical"
    }

    if {[set fileP [info exists state(file)]]} {
        if {[set openP [info exists state(root)]]} {
            # FRINK: nocheck
            variable $state(root)
            upvar 0 $state(root) root

            set state(fd) $root(fd)
        } else {
            set state(root) $token
            set state(fd) [open $state(file) RDONLY]
            set state(offset) 0
            seek $state(fd) 0 end
            set state(count) [tell $state(fd)]

            fconfigure $state(fd) -translation binary
        }
    }

    set code [catch {mime::parsepart $token} result]
    set ecode $errorCode
    set einfo $errorInfo

    if {$fileP} {
        if {!$openP} {
            unset state(root)
            catch {close $state(fd)}
        }
        unset state(fd)
    }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::parsepart --
#
#       Parses the MIME headers and attempts to break up the message
#       into its various parts, creating a MIME token for each part.
#
# Arguments:
#       token  The MIME token to parse.
#
# Results:
#       Throws an error if it has problems parsing the MIME token,
#       otherwise it just sets up the appropriate variables.

proc ::mime::parsepart {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[set fileP [info exists state(file)]]} {
        seek $state(fd) [set pos $state(offset)] start
        set last [expr {$state(offset) + $state(count) - 1}]
    } else {
        set string $state(string)
    }

    set vline {}
    while 1 {
        set blankP 0
        if {$fileP} {
            if {($pos > $last) || ([set x [gets $state(fd) line]] <= 0)} {
                set blankP 1
            } else {
                incr pos [expr {$x + 1}]
            }
        } else {

        if {$state(lines.current) >= $state(lines.count)} {
            set blankP 1
            set line {}
        } else {
            set line [lindex $state(lines) $state(lines.current)]
            incr state(lines.current)
            set x [string length $line]
            if {$x == 0} {set blankP 1}
        }

        }

         if {(!$blankP) && ([string last \r $line] == {$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 {$vline eq {}} {
            if {$blankP} {
                break
            }

            set vline $line
            continue
        }

        if {([set x [string first : $vline]] <= 0) \
                || ([set mixed [ string trimright [
                    string range $vline 0 [expr {$x - 1}]]
                ]] eq {})
            } {
            error "improper line in header: $vline"
        }
        set value [string trim [string range $vline [expr {$x + 1}] end]]
        switch -- [set lower [string tolower $mixed]] {
            content-type {
                if {[info exists state(content)]} {
                    error "multiple Content-Type fields starting with $vline"
                }

                if {![catch {set x [parsetype $token $value]}]} {
                    set state(content) [lindex $x 0]
                    set state(params) [lindex $x 1]
                }
            }

            content-md5 {
            }

            content-transfer-encoding {
                if {($state(encoding) ne {}) \
                        && ($state(encoding) ne [
                            string tolower $value])} {
                    error "multiple Content-Transfer-Encoding fields starting with $vline"
                }

                set state(encoding) [string tolower $value]
            }

            mime-version {
                set state(version) $value
            }

            default {
                if {[lsearch -exact $state(lowerL) $lower] < 0} {
                    lappend state(lowerL) $lower
                    lappend state(mixedL) $mixed
                }

                array set header $state(header)
                lappend header($lower) $value
                set state(header) [array get header]
            }
        }

        if {$blankP} {
            break
        }
        set vline $line
    }

    if {![info exists state(content)]} {
        set state(content) text/plain
        set state(params) [list charset us-ascii]
    }

    if {![string match multipart/* $state(content)]} {
        if {$fileP} {
            set x [tell $state(fd)]
            incr state(count) [expr {$state(offset) - $x}]
            set state(offset) $x
        } else {
            # rebuild string, this is cheap and needed by other functions
            set state(string) [join [
                lrange $state(lines) $state(lines.current) end] \n]
        }

        if {[string match message/* $state(content)]} {
            # FRINK: nocheck
            variable [set child $token-[incr state(cid)]]

            set state(value) parts
            set state(parts) $child
            if {$fileP} {
                mime::initializeaux $child \
                    -file $state(file) -root $state(root) \
                    -offset $state(offset) -count $state(count)
            } else {
                if {[info exists state(encoding)]} {
                    set strng [join [
                        lrange $state(lines) $state(lines.current) end] \n]
                    switch -- $state(encoding) {
                        base64 -
                        quoted-printable {
                            set strng [$state(encoding) -mode decode -- $strng]
                        }
                        default {}
                    }
                    mime::initializeaux $child -string $strng
                } else {
                    mime::initializeaux $child -lineslist [
                        lrange $state(lines) $state(lines.current) end]
                }
            }
        }

        return
    }

    set state(value) parts

    set boundary {}
    foreach {k v} $state(params) {
        if {$k eq "boundary"} {
            set boundary $v
            break
        }
    }
    if {$boundary eq {}} {
        error "boundary parameter is missing in $state(content)"
    }
    if {[string trim $boundary] eq {}} {
        error "boundary parameter is empty in $state(content)"
    }

    if {$fileP} {
        set pos [tell $state(fd)]
            # This variable is like 'start', for the reasons laid out
            # below, in the other branch of this conditional.
            set initialpos $pos
        } else {
            # This variable is like 'start', a list of lines in the
            # part. This record is made even before we find a starting
            # boundary and used if we run into the terminating boundary
            # before a starting boundary was found. In that case the lines
            # before the terminator as recorded by tracelines are seen as
            # the part, or at least we attempt to parse them as a
            # part. See the forceoctet and nochild flags later. We cannot
            # use 'start' as that records lines only after the starting
            # boundary was found.
            set tracelines [list]
    }

    set inP 0
    set moreP 1
    set forceoctet 0
    while {$moreP} {
        if {$fileP} {
            if {$pos > $last} {
                # We have run over the end of the part per the outer
                # information without finding a terminating boundary.
                # We now fake the boundary and force the parser to
                # give any new part coming of this a mime-type of
                # application/octet-stream regardless of header
                # information.
                set line "--$boundary--"
                set x [string length $line]
                set forceoctet 1
            } else {
                if {[set x [gets $state(fd) line]] < 0} {
                    error "end-of-file encountered while parsing $state(content)"
                }
            }
            incr pos [expr {$x + 1}]
        } else {
            if {$state(lines.current) >= $state(lines.count)} {
                error "end-of-string encountered while parsing $state(content)"
            } else {
                set line [lindex $state(lines) $state(lines.current)]
                incr state(lines.current)
                set x [string length $line]
            }
            set x [string length $line]
        }
        if {[string last \r $line] == $x - 1} {
            set line [string range $line 0 [expr {$x - 2}]]
            set crlf 2
        } else {
            set crlf 1
        }

        if {[string first --$boundary $line] != 0} {
             if {$inP && !$fileP} {
                 lappend start $line
             }
             continue
        } else {
            lappend tracelines $line
        }

        if {!$inP} {
            # Haven't seen the starting boundary yet. Check if the
            # current line contains this starting boundary.

            if {$line eq "--$boundary"} {
                # Yes. Switch parser state to now search for the
                # terminating boundary of the part and record where
                # the part begins (or initialize the recorder for the
                # lines in the part).
                set inP 1
                if {$fileP} {
                    set start $pos
                } else {
                    set start [list]
                }
                continue
            } elseif {$line eq "--$boundary--"} {
                # We just saw a terminating boundary before we ever
                # saw the starting boundary of a part. This forces us
                # to stop parsing, we do this by forcing the parser
                # into an accepting state. We will try to create a
                # child part based on faked start position or recorded
                # lines, or, if that fails, let the current part have
                # no children.

                # As an example note the test case mime-3.7 and the
                # referenced file "badmail1.txt".

                set inP 1
                if {$fileP} {
                    set start $initialpos
                } else {
                    set start $tracelines
                }
                set forceoctet 1
                # Fall through. This brings to the creation of the new
                # part instead of searching further and possible
                # running over the end.
            } else {
                continue
            }
        }

        # Looking for the end of the current part. We accept both a
        # terminating boundary and the starting boundary of the next
        # part as the end of the current part.

        if {[set moreP [string compare $line --$boundary--]] \
                && $line ne "--$boundary"} {
            # The current part has not ended, so we record the line
            # if we are inside a part and doing string parsing.
            if {$inP && !$fileP} {
                lappend start $line
            }
            continue
        }

        # The current part has ended. We now determine the exact
        # boundaries, create a mime part object for it and recursively
        # parse it deeper as part of that action.

        # FRINK: nocheck
        variable [set child $token-[incr state(cid)]]

        lappend state(parts) $child

        set nochild 0
        if {$fileP} {
            if {[set count [expr {$pos - ($start + $x + $crlf + 1)}]] < 0} {
                set count 0
            }
            if {$forceoctet} {
                set ::errorInfo {}
                if {[catch {
                    mime::initializeaux $child \
                        -file $state(file) -root $state(root) \
                        -offset $start -count $count
                }]} {
                    set nochild 1
                    set state(parts) [lrange $state(parts) 0 end-1]
                } } else {
                mime::initializeaux $child \
                    -file $state(file) -root $state(root) \
                    -offset $start -count $count
            }
            seek $state(fd) [set start $pos] start
        } else {
            if {$forceoctet} {
                if {[catch {
                    mime::initializeaux $child -lineslist $start
                }]} {
                    set nochild 1
                    set state(parts) [lrange $state(parts) 0 end-1]
                }
            } else {
                mime::initializeaux $child -lineslist $start
            }
            set start {}
        }
        if {$forceoctet && !$nochild} {
            variable $child
            upvar 0  $child childstate
            set childstate(content) application/octet-stream
        }
        set forceoctet 0
    }
}

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

    switch -- [parselexeme $token] {
        LX_SOLIDUS {
        }

        LX_END {
            if {$type ne "message"} {
                error "expecting type/subtype (found $type)"
            }

            return [list message/rfc822 {}]
        }

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

    if {[parselexeme $token] ne "LX_ATOM"} {
        error [format "expecting subtype (found %s)" $state(buffer)]
    }
    append type [string tolower /$state(buffer)]

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

            LX_SEMICOLON {
            }

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

        switch -- [parselexeme $token] {
            LX_END {
                return [list $type [array get params]]
            }

            LX_ATOM {
            }

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

        set attribute [string tolower $state(buffer)]

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

        switch -- [parselexeme $token] {
            LX_ATOM {
            }

            LX_QSTRING {
                set state(buffer) [
                    string range $state(buffer) 1 [
                        expr {[string length $state(buffer)] - 2}]]
            }

            default {
                error [format "expecting value (found %s)" $state(buffer)]
            }
        }
        set params($attribute) $state(buffer)
    }
}

# ::mime::finalize --
#
#   mime::finalize destroys a MIME part.
#
#   If the -subordinates option is present, it specifies which
#   subordinates should also be destroyed. The default value is
#   "dynamic".
#
# Arguments:
#       token  The MIME token to parse.
#       args   Args can be optionally be of the following form:
#              ?-subordinates "all" | "dynamic" | "none"?
#
# Results:
#       Returns an empty string.

proc ::mime::finalize {token args} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options [list -subordinates dynamic]
    array set options $args

    switch -- $options(-subordinates) {
        all {
            #TODO: this code path is untested
            if {$state(value) eq "parts"} {
                foreach part $state(parts) {
                    eval [linsert $args 0 mime::finalize $part]
                }
            }
        }

        dynamic {
            for {set cid $state(cid)} {$cid > 0} {incr cid -1} {
                eval [linsert $args 0 mime::finalize $token-$cid]
            }
        }

        none {
        }

        default {
            error "unknown value for -subordinates $options(-subordinates)"
        }
    }

    foreach name [array names state] {
        unset state($name)
    }
    # FRINK: nocheck
    unset $token
}

# ::mime::getproperty --
#
#   mime::getproperty returns the properties of a MIME part.
#
#   The properties are:
#
#       property    value
#       ========    =====
#       content     the type/subtype describing the content
#       encoding    the "Content-Transfer-Encoding"
#       params      a list of "Content-Type" parameters
#       parts       a list of tokens for the part's subordinates
#       size        the approximate size of the content (unencoded)
#
#   The "parts" property is present only if the MIME part has
#   subordinates.
#
#   If mime::getproperty is invoked with the name of a specific
#   property, then the corresponding value is returned; instead, if
#   -names is specified, a list of all properties is returned;
#   otherwise, a serialized array of properties and values is returned.
#
# Arguments:
#       token      The MIME token to parse.
#       property   One of 'content', 'encoding', 'params', 'parts', and
#                  'size'. Defaults to returning a serialized array of
#                  properties and values.
#
# Results:
#       Returns the properties of a MIME part

proc ::mime::getproperty {token {property {}}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $property {
        {} {
            array set properties [list content  $state(content) \
                                       encoding $state(encoding) \
                                       params   $state(params) \
                                       size     [getsize $token]]
            if {[info exists state(parts)]} {
                set properties(parts) $state(parts)
            }

            return [array get properties]
        }

        -names {
            set names [list content encoding params]
            if {[info exists state(parts)]} {
                lappend names parts
            }

            return $names
        }

        content
            -
        encoding
            -
        params {
            return $state($property)
        }

        parts {
            if {![info exists state(parts)]} {
                error "MIME part is a leaf"
            }

            return $state(parts)
        }

        size {
            return [getsize $token]
        }

        default {
            error "unknown property $property"
        }
    }
}

# ::mime::getsize --
#
#    Determine the size (in bytes) of a MIME part/token
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the size in bytes of the MIME token.

proc ::mime::getsize {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $state(value)/$state(canonicalP) {
        file/0 {
            set size $state(count)
        }

        file/1 {
            return [file size $state(file)]
        }

        parts/0
            -
        parts/1 {
            set size 0
            foreach part $state(parts) {
                incr size [getsize $part]
            }

            return $size
        }

        string/0 {
            set size [string length $state(string)]
        }

        string/1 {
            return [string length $state(string)]
        }
        default {
            error "Unknown combination \"$state(value)/$state(canonicalP)\""
        }
    }

    if {$state(encoding) eq "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} {
        #TODO: this code path is not tested
        if {$options(-mode) eq "delete"} {
            error "key $key not in header"
        }

        lappend state(lowerL) $lower
        lappend state(mixedL) $key

        set result {}
    } else {
        set result $header($lower)
    }
    switch -- $options(-mode) {
        append {
            lappend header($lower) $value
        }

        delete {
            unset header($lower)
            set state(lowerL) [lreplace $state(lowerL) $x $x]
            set state(mixedL) [lreplace $state(mixedL) $x $x]
        }

        write {
            set header($lower) [list $value]
        }

        default {
            error "unknown value for -mode $options(-mode)"
        }
    }

    set state(header) [array get header]

    return $result
}

# ::mime::getbody --
#
#    mime::getbody returns the body of a leaf MIME part in canonical form.
#
#    If the -command option is present, then it is repeatedly invoked
#    with a fragment of the body as this:
#
#        uplevel #0 $callback [list "data" $fragment]
#
#    (The -blocksize option, if present, specifies the maximum size of
#    each fragment passed to the callback.)
#    When the end of the body is reached, the callback is invoked as:
#
#        uplevel #0 $callback "end"
#
#    Alternatively, if an error occurs, the callback is invoked as:
#
#        uplevel #0 $callback [list "error" reason]
#
#    Regardless, the return value of the final invocation of the callback
#    is propagated upwards by mime::getbody.
#
#    If the -command option is absent, then the return value of
#    mime::getbody is a string containing the MIME part's entire body.
#
# Arguments:
#       token      The MIME token to parse.
#       args       Optional arguments of the form:
#                  ?-decode? ?-command callback ?-blocksize octets? ?
#
# Results:
#       Returns a string containing the MIME part's entire body, or
#       if '-command' is specified, the return value of the command
#       is returned.

proc ::mime::getbody {token args} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set decode 0
    if {[set pos [lsearch -exact $args -decode]] >= 0} {
        set decode 1
        set args [lreplace $args $pos $pos]
    }

    array set options [list -command [
        list mime::getbodyaux $token] -blocksize 4096]
    array set options $args
    if {$options(-blocksize) < 1} {
        error "-blocksize expects a positive integer, not $options(-blocksize)"
    }

    set code 0
    set ecode {}
    set einfo {}

    switch -- $state(value)/$state(canonicalP) {
        file/0 {
            set fd [open $state(file) RDONLY]

            set code [catch {
                fconfigure $fd -translation binary
                seek $fd [set pos $state(offset)] start
                set last [expr {$state(offset) + $state(count) - 1}]

                set fragment {}
                while {$pos <= $last} {
                    if {[set cc [
                        expr {($last - $pos) + 1}]] > $options(-blocksize)} {
                        set cc $options(-blocksize)
                    }
                    incr pos [set len [
                        string length [set chunk [read $fd $cc]]]]
                    switch -exact -- $state(encoding) {
                        base64
                            -
                        quoted-printable {
                            if {([set x [string last \n $chunk]] > 0) \
                                    && ($x + 1 != $len)} {
                                set chunk [string range $chunk 0 $x]
                                seek $fd [incr pos [expr {($x + 1) - $len}]] start
                            }
                            set chunk [
                                $state(encoding) -mode decode -- $chunk]
                        }
                        7bit - 8bit - binary - {} {
                            # Bugfix for [#477088]
                            # Go ahead, leave chunk alone
                        }
                        default {
                            error "Can't handle content encoding \"$state(encoding)\""
                        }
                    }
                    append fragment $chunk

                    set cc [expr {$options(-blocksize) - 1}]
                    while {[string length $fragment] > $options(-blocksize)} {
                        uplevel #0 $options(-command) [
                            list data [string range $fragment 0 $cc]]

                        set fragment [
                            string range $fragment $options(-blocksize) end]
                    }
                }
                if {[string length $fragment] > 0} {
                    uplevel #0 $options(-command) [list data $fragment]
                }
            } result]
            set ecode $errorCode
            set einfo $errorInfo

            catch {close $fd}
        }

        file/1 {
            set fd [open $state(file) RDONLY]

            set code [catch {
                fconfigure $fd -translation binary

                while {[string length [
                    set fragment [read $fd $options(-blocksize)]]] > 0} {
                        uplevel #0 $options(-command) [list data $fragment]
                    }
            } result]
            set ecode $errorCode
            set einfo $errorInfo

            catch {close $fd}
        }

        parts/0
            -
        parts/1 {
            error "MIME part isn't a leaf"
        }

        string/0
            -
        string/1 {
            switch -- $state(encoding)/$state(canonicalP) {
                base64/0
                    -
                quoted-printable/0 {
                    set fragment [
                        $state(encoding) -mode decode -- $state(string)]
                }

                default {
                    # Not a bugfix for [#477088], but clarification
                    # This handles no-encoding, 7bit, 8bit, and binary.
                    set fragment $state(string)
                }
            }

            set code [catch {
                set cc [expr {$options(-blocksize) -1}]
                while {[string length $fragment] > $options(-blocksize)} {
                    uplevel #0 $options(-command) [
                        list data [string range $fragment 0 $cc]]

                    set fragment [
                        string range $fragment $options(-blocksize) end]
                }
                if {[string length $fragment] > 0} {
                    uplevel #0 $options(-command) [list data $fragment]
                }
            } result]
            set ecode $errorCode
            set einfo $errorInfo
        }
        default {
            error "Unknown combination \"$state(value)/$state(canonicalP)\""
        }
    }

    set code [catch {
        if {$code} {
            uplevel #0 $options(-command) [list error $result]
        } else {
            uplevel #0 $options(-command) [list end]
        }
    } result]
    set ecode $errorCode
    set einfo $errorInfo

    if {$code} {
        return -code $code -errorinfo $einfo -errorcode $ecode $result
    }

    if {$decode} {
        array set params [mime::getproperty $token params]

        if {[info exists params(charset)]} {
            set charset $params(charset)
        } else {
            set charset US-ASCII
        }

        set enc [reversemapencoding $charset]
        if {$enc ne {}} {
            set result [::encoding convertfrom $enc $result]
        } else {
            return -code error "-decode failed: can't reversemap charset $charset"
        }
    }

    return $result
}

# ::mime::getbodyaux --
#
#    Builds up the body of the message, fragment by fragment.  When
#    the entire message has been retrieved, it is returned.
#
# Arguments:
#       token      The MIME token to parse.
#       reason     One of 'data', 'end', or 'error'.
#       fragment   The section of data data fragment to extract a
#                  string from.
#
# Results:
#       Returns nothing, except when called with the 'end' argument
#       in which case it returns a string that contains all of the
#       data that 'getbodyaux' has been called with.  Will throw an
#       error if it is called with the reason of 'error'.

proc ::mime::getbodyaux {token reason {fragment {}}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch $reason {
        data {
            append state(getbody) $fragment
            return {}
        }

        end {
            if {[info exists state(getbody)]} {
                set result $state(getbody)
                unset state(getbody)
            } else {
                set result {}
            }

            return $result
        }

        error {
            catch {unset state(getbody)}
            error $reason
        }

        default {
            error "Unknown reason \"$reason\""
        }
    }
}

# ::mime::copymessage --
#
#    mime::copymessage copies the MIME part to the specified channel.
#
#    mime::copymessage operates synchronously, and uses fileevent to
#    allow asynchronous operations to proceed independently.
#
# Arguments:
#       token      The MIME token to parse.
#       channel    The channel to copy the message to.
#
# Results:
#       Returns nothing unless an error is thrown while the message
#       is being written to the channel.

proc ::mime::copymessage {token channel} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set openP [info exists state(fd)]

    set code [catch {mime::copymessageaux $token $channel} result]
    set ecode $errorCode
    set einfo $errorInfo

    if {(!$openP) && ([info exists state(fd)])} {
        if {![info exists state(root)]} {
            catch {close $state(fd)}
        }
        unset state(fd)
    }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::copymessageaux --
#
#    mime::copymessageaux copies the MIME part to the specified channel.
#
# Arguments:
#       token      The MIME token to parse.
#       channel    The channel to copy the message to.
#
# Results:
#       Returns nothing unless an error is thrown while the message
#       is being written to the channel.

proc ::mime::copymessageaux {token channel} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set header $state(header)

    if {$state(version) ne {}} {
        puts $channel "MIME-Version: $state(version)"
    }
    foreach lower $state(lowerL) mixed $state(mixedL) {
        foreach value $header($lower) {
            puts $channel "$mixed: $value"
        }
    }
    if {(!$state(canonicalP)) \
            && ([set encoding $state(encoding)] ne {})} {
        puts $channel "Content-Transfer-Encoding: $encoding"
    }

    puts -nonewline $channel "Content-Type: $state(content)"
    set boundary {}
    foreach {k v} $state(params) {
        if {$k eq "boundary"} {
            set boundary $v
        }

        puts -nonewline $channel ";\n              $k=\"$v\""
    }

    set converter {}
    set encoding {}
    if {$state(value) ne "parts"} {
        puts $channel {}

        if {$state(canonicalP)} {
            if {[set encoding $state(encoding)] eq {}} {
                set encoding [encoding $token]
            }
            if {$encoding ne {}} {
                puts $channel "Content-Transfer-Encoding: $encoding"
            }
            switch -- $encoding {
                base64
                    -
                quoted-printable {
                    set converter $encoding
                }
                7bit - 8bit - binary - {} {
                    # Bugfix for [#477088], also [#539952]
                    # Go ahead
                }
                default {
                    error "Can't handle content encoding \"$encoding\""
                }
            }
        }
    } elseif {([string match multipart/* $state(content)]) \
        && ($boundary eq {})} {
        # 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 {$converter eq {}} {
                    puts -nonewline $channel $X
                } else {
                    puts -nonewline $channel [$converter -mode encode -- $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 {
                    # Note RFC 2046: See buildmessageaux for details.

                    foreach part $state(parts) {
                        puts $channel \n--$boundary
                        mime::copymessage $part $channel
                    }
                    puts $channel \n--$boundary--
                }
            }

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

        string {
            if {[catch {fconfigure $channel -buffersize} blocksize]} {
                set blocksize 4096
            } elseif {$blocksize < 512} {
                set blocksize 512
            }
            set blocksize [expr {($blocksize / 4) * 3}]

            # [893516]
            fconfigure $channel -buffersize $blocksize

            puts $channel {}

            #TODO: tests don't cover these paths
            if {$converter eq {}} {
                puts -nonewline $channel $state(string)
            } else {
                puts -nonewline $channel [$converter -mode encode -- $state(string)]
            }
        }
        default {
            error "Unknown value \"$state(value)\""
        }
    }

    flush $channel

    if {[info exists state(error)]} {
        error $state(error)
    }
}

# ::mime::buildmessage --
#
#     The following is a clone of the copymessage code to build up the
#     result in memory, and, unfortunately, without using a memory channel.
#     I considered parameterizing the "puts" calls in copy message, but
#     the need for this procedure may go away, so I'm living with it for
#     the moment.
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the message that has been built up in memory.

proc ::mime::buildmessage {token} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set openP [info exists state(fd)]

    set code [catch {mime::buildmessageaux $token} result]
    if {![info exists errorCode]} {
        set ecode {}
    } else {
        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 {$state(version) ne {}} {
        append result "MIME-Version: $state(version)\r\n"
    }
    foreach lower $state(lowerL) mixed $state(mixedL) {
        foreach value $header($lower) {
            append result "$mixed: $value\r\n"
        }
    }
    if {(!$state(canonicalP)) \
            && ([set encoding $state(encoding)] ne {})} {
        append result "Content-Transfer-Encoding: $encoding\r\n"
    }

    append result "Content-Type: $state(content)"
    set boundary {}
    foreach {k v} $state(params) {
        if {$k eq "boundary"} {
            set boundary $v
        }

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

    set converter {}
    set encoding {}
    if {$state(value) ne "parts"} {
        #TODO: the path is not covered by tests
        append result \r\n

        if {$state(canonicalP)} {
            if {[set encoding $state(encoding)] eq {}} {
                set encoding [encoding $token]
            }
            if {$encoding ne {}} {
                append result "Content-Transfer-Encoding: $encoding\r\n"
            }
            switch -- $encoding {
                base64
                    -
                quoted-printable {
                    set converter $encoding
                }
                7bit - 8bit - binary - {} {
                    # Bugfix for [#477088]
                    # Go ahead
                }
                default {
                    error "Can't handle content encoding \"$encoding\""
                }
            }
        }
    } elseif {([string match multipart/* $state(content)]) \
                    && ($boundary eq {})} {
        # we're doing everything in one pass...
        set key [clock seconds]$token[info hostname][array get state]
        set seqno 8
        while {[incr seqno -1] >= 0} {
            set key [md5 -- $key]
        }
        set boundary "----- =_[string trim [base64 -mode encode -- $key]]"

        append result ";\r\n              boundary=\"$boundary\"\r\n"
    } else {
        append result \r\n
    }

    if {[info exists state(error)]} {
        unset state(error)
    }

    switch -- $state(value) {
        file {
            set closeP 1
            if {[info exists state(root)]} {
                # FRINK: nocheck
                variable $state(root)
                upvar 0 $state(root) root

                if {[info exists root(fd)]} {
                    set fd $root(fd)
                    set closeP 0
                } else {
                    set fd [set state(fd) [open $state(file) RDONLY]]
                }
                set size $state(count)
            } else {
                set fd [set state(fd) [open $state(file) RDONLY]]
                set size -1 ;# Read until EOF
            }
            seek $fd $state(offset) start
            if {$closeP} {
                fconfigure $fd -translation binary
            }

            append result \r\n

            while {($size != 0) && (![eof $fd])} {
                if {$size < 0 || $size > 32766} {
                    set X [read $fd 32766]
                } else {
                    set X [read $fd $size]
                }
                if {$size > 0} {
                    set size [expr {$size - [string length $X]}]
                }
                if {$converter ne {}} {
                    append result [$converter -mode encode -- $X]
                } else {
                    append result $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/* {
                    append result "\r\n"
                    foreach part $state(parts) {
                        append result [buildmessage $part]
                        break
                    }
                }

                default {
                    # Note RFC 2046:
                    #
                    # The boundary delimiter MUST occur at the
                    # beginning of a line, i.e., following a CRLF, and
                    # the initial CRLF is considered to be attached to
                    # the boundary delimiter line rather than part of
                    # the preceding part.
                    #
                    # - The above means that the CRLF before $boundary
                    #   is needed per the RFC, and the parts must not
                    #   have a closing CRLF of their own. See Tcllib bug
                    #   1213527, and patch 1254934 for the problems when
                    #   both file/string brnaches added CRLF after the
                    #   body parts.

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

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

        string {
            append result "\r\n"

            if {$converter ne {}} {
                append result [$converter -mode encode -- $state(string)]
            } else {
                append result $state(string)
            }
        }
        default {
            error "Unknown value \"$state(value)\""
        }
    }

    if {[info exists state(error)]} {
        error $state(error)
    }
    return $result
}

# ::mime::encoding --
#
#     Determines how a token is encoded.
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the encoding of the message (the null string, base64,
#       or quoted-printable).

proc ::mime::encoding {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -glob -- $state(content) {
        audio/*
            -
        image/*
            -
        video/* {
            return base64
        }

        message/*
            -
        multipart/* {
            return {}
        }
        default {# Skip}
    }

    set asciiP 1
    set lineP 1
    switch -- $state(value) {
        file {
            set fd [open $state(file) RDONLY]
            fconfigure $fd -translation binary

            while {[gets $fd line] >= 0} {
                if {$asciiP} {
                    set asciiP [encodingasciiP $line]
                }
                if {$lineP} {
                    set lineP [encodinglineP $line]
                }
                if {(!$asciiP) && (!$lineP)} {
                    break
                }
            }

            catch {close $fd}
        }

        parts {
            return {}
        }

        string {
            foreach line [split $state(string) "\n"] {
                if {$asciiP} {
                    set asciiP [encodingasciiP $line]
                }
                if {$lineP} {
                    set lineP [encodinglineP $line]
                }
                if {(!$asciiP) && (!$lineP)} {
                    break
                }
            }
        }
        default {
            error "Unknown value \"$state(value)\""
        }
    }

    switch -glob -- $state(content) {
        text/* {
            if {!$asciiP} {
                #TODO: this path is not covered by tests
                foreach {k v} $state(params) {
                    if {$k eq "charset"} {
                        set v [string tolower $v]
                        if {($v ne "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 == {[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) \
            || ($line ne [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 {$error ne {}} {
        set state(error) $error
    }
    set state(doneP) 1
}

# ::mime::scopy --
#
#    Copy a portion of the contents of a mime token to a channel.
#
# Arguments:
#    token     The token containing the data to copy.
#       channel   The channel to write the data to.
#       offset    The location in the string to start copying
#                 from.
#       len       The amount of data to write.
#       blocksize The block size for the write operation.
#
# Results:
#    The specified portion of the string in the mime token is
#       copied to the specified channel.

proc ::mime::scopy {token channel offset len blocksize} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {$len <= 0} {
        set state(doneP) 1
        fileevent $channel writable {}
        return
    }

    if {[set cc $len] > $blocksize} {
        set cc $blocksize
    }

    if {[catch {
        puts -nonewline $channel [
            string range $state(string) $offset [expr {$offset + $cc - 1}]]
        fileevent $channel writable [
            list mime::scopy $token $channel [
                incr offset $cc] [incr len -$cc] $blocksize]
              } result]} {

        set state(error) $result
        set state(doneP) 1
        fileevent $channel writable {}
    }
    return
}

# ::mime::qp_encode --
#
#    Tcl version of quote-printable encode
#
# Arguments:
#    string        The string to quote.
#       encoded_word  Boolean value to determine whether or not encoded words
#                     (RFC 2047) should be handled or not. (optional)
#
# Results:
#    The properly quoted string is returned.

proc ::mime::qp_encode {string {encoded_word 0} {no_softbreak 0}} {
    # 8.1+ improved string manipulation routines used.
    # Replace outlying characters, characters that would normally
    # be munged by EBCDIC gateways, and special Tcl characters "[\]{}
    # with =xx sequence

    regsub -all -- \
        {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]} \
        $string {[format =%02X [scan "\\&" %c]]} string

    # Replace the format commands with their result

    set string [subst -novariables $string]

    # soft/hard newlines and other
    # Funky cases for SMTP compatibility
    set mapChars [
        list " \n" =20\n \t\n =09\n \n\.\n \=2E\n "\nFrom " "\n=46rom "]
    if {$encoded_word} {
        # Special processing for encoded words (RFC 2047)
        lappend mapChars { } _
    }
    set string [string map $mapChars $string]

    # Break long lines - ugh

    # Implementation of FR #503336
    if {$no_softbreak} {
        set result $string
    } else {
        set result {}
        foreach line [split $string \n] {
            while {[string length $line] > 72} {
                set chunk [string range $line 0 72]
                if {[regexp -- (=|=.)$ $chunk dummy end]} {

                    # Don't break in the middle of a code

                    set len [expr {72 - [string length $end]}]
                    set chunk [string range $line 0 $len]
                    incr len
                    set line [string range $line $len end]
                } else {
                    set line [string range $line 73 end]
                }
                append result $chunk=\n
            }
            append result $line\n
        }

        # Trim off last \n, since the above code has the side-effect
        # of adding an extra \n to the encoded string and return the
        # result.
        set result [string range $result 0 end-1]
    }

    # If the string ends in space or tab, replace with =xx

    set lastChar [string index $result end]
    if {$lastChar eq { }} {
        set result [string replace $result end end =20]
    } elseif {$lastChar eq "\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.

    #TODO: codepath not tested
    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 -novariables -nocommands $string]
}

# ::mime::parseaddress --
#
#       This was originally written circa 1982 in C. we're still using it
#       because it recognizes virtually every buggy address syntax ever
#       generated!
#
#       mime::parseaddress takes a string containing one or more 822-style
#       address specifications and returns a list of serialized arrays, one
#       element for each address specified in the argument.
#
#    Each serialized array contains these properties:
#
#       property    value
#       ========    =====
#       address     local@domain
#       comment     822-style comment
#       domain      the domain part (rhs)
#       error       non-empty on a parse error
#       group       this address begins a group
#       friendly    user-friendly rendering
#       local       the local part (lhs)
#       memberP     this address belongs to a group
#       phrase      the phrase part
#       proper      822-style address specification
#       route       822-style route specification (obsolete)
#
#    Note that one or more of these properties may be empty.
#
# Arguments:
#    string        The address string to parse
#
# Results:
#    Returns a list of serialized arrays, one element for each address
#       specified in the argument.

proc ::mime::parseaddress {string} {
    global errorCode errorInfo

    variable mime

    set token [namespace current]::[incr mime(uid)]
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set code [catch {mime::parseaddressaux $token $string} result]
    set ecode $errorCode
    set einfo $errorInfo

    foreach name [array names state] {
        unset state($name)
    }
    # FRINK: nocheck
    catch {unset $token}

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::mime::parseaddressaux --
#
#       This was originally written circa 1982 in C. we're still using it
#       because it recognizes virtually every buggy address syntax ever
#       generated!
#
#       mime::parseaddressaux does the actually parsing for mime::parseaddress
#
#    Each serialized array contains these properties:
#
#       property    value
#       ========    =====
#       address     local@domain
#       comment     822-style comment
#       domain      the domain part (rhs)
#       error       non-empty on a parse error
#       group       this address begins a group
#       friendly    user-friendly rendering
#       local       the local part (lhs)
#       memberP     this address belongs to a group
#       phrase      the phrase part
#       proper      822-style address specification
#       route       822-style route specification (obsolete)
#
#    Note that one or more of these properties may be empty.
#
# Arguments:
#       token         The MIME token to work from.
#    string        The address string to parse
#
# Results:
#    Returns a list of serialized arrays, one element for each address
#       specified in the argument.

proc ::mime::parseaddressaux {token string} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    variable addrtokenL
    variable addrlexemeL

    set state(input)   $string
    set state(glevel)  0
    set state(buffer)  {}
    set state(lastC)   LX_END
    set state(tokenL)  $addrtokenL
    set state(lexemeL) $addrlexemeL

    set result {}
    while {[addr_next $token]} {
        if {[set tail $state(domain)] ne {}} {
            set tail @$state(domain)
        } else {
            set tail @[info hostname]
        }
        if {[set address $state(local)] ne {}} {
            #TODO: this path is not covered by tests
            append address $tail
        }

        if {$state(phrase) ne {}} {
            #TODO: this path is not covered by tests
            set state(phrase) [string trim $state(phrase) \"]
            foreach t $state(tokenL) {
                if {[string first $t $state(phrase)] >= 0} {
                    #TODO:  is this quoting robust enough?
                    set state(phrase) \"$state(phrase)\"
                    break
                }
            }

            set proper "$state(phrase) <$address>"
        } else {
            set proper $address
        }

        if {[set friendly $state(phrase)] eq {}} {
            #TODO: this path is not covered by tests
            if {[set note $state(comment)] ne {}} {
                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 {($friendly eq {}) \
                    && ([set mbox $state(local)] ne {})} {
                #TODO: this path is not covered by tests
                set mbox [string trim $mbox \"]

                if {[string first / $mbox] != 0} {
                    set friendly $mbox
                } elseif {[set friendly [addr_x400 $mbox PN]] ne {}} {
                } elseif {([set friendly [addr_x400 $mbox S]] ne {}) \
                    && ([set g [addr_x400 $mbox G]] ne {})} {
                    set friendly "$g $friendly"
                }

                if {$friendly eq {}} {
                    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
    set nocomplain [package vsatisfies [package provide Tcl] 8.4]
    foreach prop {comment domain error group local memberP phrase route} {
        if {$nocomplain} {
            unset -nocomplain state($prop)
        } else {
            if {[catch {unset state($prop)}]} {set ::errorInfo {}}
        }
    }

    switch -- [set code [catch {mime::addr_specification $token} result]] {
        0 {
            if {!$result} {
                return 0
            }

            switch -- $state(lastC) {
                LX_COMMA
                    -
                LX_END {
                }
                default {
                    # catch trailing comments...
                    set lookahead $state(input)
                    mime::parselexeme $token
                    set state(input) $lookahead
                }
            }
        }

        7 {
            set state(error) $result

            while {1} {
                switch -- $state(lastC) {
                    LX_COMMA
                        -
                    LX_END {
                        break
                    }

                    default {
                        mime::parselexeme $token
                    }
                }
            }
        }

        default {
            set ecode $errorCode
            set einfo $errorInfo

            return -code $code -errorinfo $einfo -errorcode $ecode $result
        }
    }

    foreach prop {comment domain error group local memberP phrase route} {
        if {![info exists state($prop)]} {
            set state($prop) {}
        }
    }

    return 1
}

# ::mime::addr_specification --
#
#   Uses lookahead parsing to determine whether there is another
#   valid e-mail address or not.  Throws errors if unrecognized
#   or invalid e-mail address syntax is used.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#    Returns 1 if there is another address, and 0 if there is not.

proc ::mime::addr_specification {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set lookahead $state(input)
    switch -- [parselexeme $token] {
        LX_ATOM
            -
        LX_QSTRING {
            set state(phrase) $state(buffer)
        }

        LX_SEMICOLON {
            if {[incr state(glevel) -1] < 0} {
                return -code 7 "extraneous semi-colon"
            }

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

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

        LX_END {
            return 0
        }

        LX_LBRACKET {
            return [addr_routeaddr $token]
        }

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

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

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

            return [addr_phrase $token]
        }

        LX_LBRACKET {
            return [addr_routeaddr $token]
        }

        LX_COLON {
            return [addr_group $token]
        }

        LX_DOT {
            set state(local) "$state(phrase)$state(buffer)"
            unset state(phrase)
            mime::addr_routeaddr $token 0
            mime::addr_end $token
        }

        LX_ATSIGN {
            set state(memberP) $state(glevel)
            set state(local) $state(phrase)
            unset state(phrase)
            mime::addr_domain $token
            mime::addr_end $token
        }

        LX_SEMICOLON
            -
        LX_COMMA
            -
        LX_END {
            set state(memberP) $state(glevel)
            if {($state(lastC) eq "LX_SEMICOLON") \
                    && ([incr state(glevel) -1] < 0)} {
                #TODO: this path is not covered by tests
                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 {[parselexeme $token] eq "LX_ATSIGN"} {
        #TODO: this path is not covered by tests
        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) && ($state(lastC) ne "LX_RBRACKET")} {
        return -code 7 [
            format "expecting right-bracket (found %s)" $state(buffer)]
    }

    return 1
}

# ::mime::addr_route --
#
#    Attempts to parse the portion of the e-mail address after the @.
#    Tries to verify that the domain definition has a valid form.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#    Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_route {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set state(route) @

    while {1} {
        switch -- [parselexeme $token] {
            LX_ATOM
                -
            LX_DLITERAL {
                append state(route) $state(buffer)
            }

            default {
                return -code 7 \
                       [format "expecting sub-route in route-part (found %s)" \
                               $state(buffer)]
            }
        }

        switch -- [parselexeme $token] {
            LX_COMMA {
                append state(route) $state(buffer)
                while {1} {
                    switch -- [parselexeme $token] {
                        LX_COMMA {
                        }

                        LX_ATSIGN {
                            append state(route) $state(buffer)
                            break
                        }

                        default {
                            return -code 7 \
                                   [format "expecting at-sign in route (found %s)" \
                                           $state(buffer)]
                        }
                    }
                }
            }

            LX_ATSIGN
                -
            LX_DOT {
                append state(route) $state(buffer)
            }

            LX_COLON {
                append state(route) $state(buffer)
                return
            }

            default {
                return -code 7 \
                       [format "expecting colon to terminate route (found %s)" \
                               $state(buffer)]
            }
        }
    }
}

# ::mime::addr_domain --
#
#    Attempts to parse the portion of the e-mail address after the @.
#    Tries to verify that the domain definition has a valid form.
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#    Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_domain {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    while {1} {
        switch -- [parselexeme $token] {
            LX_ATOM
                -
            LX_DLITERAL {
                append state(domain) $state(buffer)
            }

            default {
                return -code 7 \
                       [format "expecting sub-domain in domain-part (found %s)" \
                               $state(buffer)]
            }
        }

        switch -- [parselexeme $token] {
            LX_DOT {
                append state(domain) $state(buffer)
            }

            LX_ATSIGN {
                append state(local) % $state(domain)
                unset state(domain)
            }

            default {
                return
            }
        }
    }
}

# ::mime::addr_local --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#    Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_local {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set state(memberP) $state(glevel)

    while {1} {
        switch -- [parselexeme $token] {
            LX_ATOM
                -
            LX_QSTRING {
                append state(local) $state(buffer)
            }

            default {
                return -code 7 \
                       [format "expecting mailbox in local-part (found %s)" \
                               $state(buffer)]
            }
        }

        switch -- [parselexeme $token] {
            LX_DOT {
                append state(local) $state(buffer)
            }

            default {
                return
            }
        }
    }
}

# ::mime::addr_phrase --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#    Returns nothing if successful, and throws an error if invalid
#       syntax is found.


proc ::mime::addr_phrase {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    while {1} {
        switch -- [parselexeme $token] {
            LX_ATOM
                -
            LX_QSTRING {
                append state(phrase) " " $state(buffer)
            }

            default {
                break
            }
        }
    }

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

        LX_COLON {
            return [addr_group $token]
        }

        LX_DOT {
            append state(phrase) $state(buffer)
            return [addr_phrase $token]
        }

        default {
            return -code 7 \
                   [format "found phrase instead of mailbox (%s%s)" \
                           $state(phrase) $state(buffer)]
        }
    }
}

# ::mime::addr_group --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#    Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_group {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[incr state(glevel)] > 1} {
        return -code 7 [format "nested groups not allowed (found %s)" \
                               $state(phrase)]
    }

    set state(group) $state(phrase)
    unset state(phrase)

    set lookahead $state(input)
    while {1} {
        switch -- [parselexeme $token] {
            LX_SEMICOLON
                -
            LX_END {
                set state(glevel) 0
                return 1
            }

            LX_COMMA {
            }

            default {
                set state(input) $lookahead
                return [addr_specification $token]
            }
        }
    }
}

# ::mime::addr_end --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#    Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_end {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $state(lastC) {
        LX_SEMICOLON {
            if {[incr state(glevel) -1] < 0} {
                return -code 7 "extraneous semi-colon"
            }
        }

        LX_COMMA
            -
        LX_END {
        }

        default {
            return -code 7 [format "junk after local@domain (found %s)" \
                                   $state(buffer)]
        }
    }
}

# ::mime::addr_x400 --
#
#
# Arguments:
#       token         The MIME token to work from.
#
# Results:
#    Returns nothing if successful, and throws an error if invalid
#       syntax is found.

proc ::mime::addr_x400 {mbox key} {
    if {[set x [string first /$key= [string toupper $mbox]]] < 0} {
        return {}
    }
    set mbox [string range $mbox [expr {$x + [string length $key] + 2}] end]

    if {[set x [string first / $mbox]] > 0} {
        set mbox [string range $mbox 0 [expr {$x - 1}]]
    }

    return [string trim $mbox \"]
}

# ::mime::parsedatetime --
#
#    Fortunately the clock command in the Tcl 8.x core does all the heavy
#    lifting for us (except for timezone calculations).
#
#    mime::parsedatetime takes a string containing an 822-style date-time
#    specification and returns the specified property.
#
#    The list of properties and their ranges are:
#
#       property     range
#       ========     =====
#       clock        raw result of "clock scan"
#       hour         0 .. 23
#       lmonth       January, February, ..., December
#       lweekday     Sunday, Monday, ... Saturday
#       mday         1 .. 31
#       min          0 .. 59
#       mon          1 .. 12
#       month        Jan, Feb, ..., Dec
#       proper       822-style date-time specification
#       rclock       elapsed seconds between then and now
#       sec          0 .. 59
#       wday         0 .. 6 (Sun .. Mon)
#       weekday      Sun, Mon, ..., Sat
#       yday         1 .. 366
#       year         1900 ...
#       zone         -720 .. 720 (minutes east of GMT)
#
# Arguments:
#       value       Either a 822-style date-time specification or '-now'
#                   if the current date/time should be used.
#       property    The property (from the list above) to return
#
# Results:
#    Returns the string value of the 'property' for the date/time that was
#       specified in 'value'.

namespace eval ::mime {
        variable WDAYS_SHORT  [list Sun Mon Tue Wed Thu Fri Sat]
        variable WDAYS_LONG   [list Sunday Monday Tuesday Wednesday Thursday \
                                    Friday Saturday]

        # Counting months starts at 1, so just insert a dummy element
        # at index 0.
        variable MONTHS_SHORT [list {} \
                                    Jan Feb Mar Apr May Jun \
                                    Jul Aug Sep Oct Nov Dec]
        variable MONTHS_LONG  [list {} \
                                    January February March April May June July \
                                    August Sepember October November December]
}
proc ::mime::parsedatetime {value property} {
    if {$value eq "-now"} {
        set clock [clock seconds]
    } elseif {[regexp {^(.*) ([+-])([0-9][0-9])([0-9][0-9])$} $value \
            -> value zone_sign zone_hour zone_min]} {
        set clock [clock scan $value -gmt 1]
        if {[info exists zone_min]} {
            set zone_min [scan $zone_min %d]
            set zone_hour [scan $zone_hour %d]
            set zone [expr {60 * ($zone_min + 60 * $zone_hour)}]
            if {$zone_sign eq "+"} {
                set zone -$zone
            }
            incr clock $zone
        }
    } else {
        set clock [clock scan $value]
    }

    switch -- $property {
        clock {
            return $clock
        }

        hour {
            set value [clock format $clock -format %H]
        }

        lmonth {
            variable MONTHS_LONG
            return [lindex $MONTHS_LONG \
                            [scan [clock format $clock -format %m] %d]]
        }

        lweekday {
            variable WDAYS_LONG
            return [lindex $WDAYS_LONG [clock format $clock -format %w]]
        }

        mday {
            set value [clock format $clock -format %d]
        }

        min {
            set value [clock format $clock -format %M]
        }

        mon {
            set value [clock format $clock -format %m]
        }

        month {
            variable MONTHS_SHORT
            return [lindex $MONTHS_SHORT \
                            [scan [clock format $clock -format %m] %d]]
        }

        proper {
            set gmt [clock format $clock -format "%Y-%m-%d %H:%M:%S" \
                           -gmt true]
            if {[set diff [expr {($clock-[clock scan $gmt]) / 60}]] < 0} {
                set s -
                set diff [expr {-($diff)}]
            } else {
                set s +
            }
            set zone [format %s%02d%02d $s [
                expr {$diff / 60}] [expr {$diff % 60}]]

            variable WDAYS_SHORT
            set wday [lindex $WDAYS_SHORT [clock format $clock -format %w]]
            variable MONTHS_SHORT
            set mon [lindex $MONTHS_SHORT \
                [scan [clock format $clock -format %m] %d]]

            return [clock format $clock \
                -format "$wday, %d $mon %Y %H:%M:%S $zone"]
        }

        rclock {
            #TODO: these paths are not covered by tests
            if {$value eq "-now"} {
                return 0
            } else {
                return [expr {[clock seconds] - $clock}]
            }
        }

        sec {
            set value [clock format $clock -format %S]
        }

        wday {
            return [clock format $clock -format %w]
        }

        weekday {
            variable WDAYS_SHORT
            return [lindex $WDAYS_SHORT [clock format $clock -format %w]]
        }

        yday {
            set value [clock format $clock -format %j]
        }

        year {
            set value [clock format $clock -format %Y]
        }

        zone {
            set value [string trim [string map [list \t { }] $value]]
            if {[set x [string last { } $value]] < 0} {
                return 0
            }
            set value [string range $value [expr {$x + 1}] end]
            switch -- [set s [string index $value 0]] {
                + - - {
                    if {$s eq "+"} {
                        #TODO: This path is not covered by tests
                        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 {[set value [string trimleft $value 0]] eq {}} {
        #TODO: this path is not covered by tests
        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 {$state(input) eq {}} {
        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 {$c eq "("} {
        set noteP 0
        set quoteP 0

        while 1 {
            append state(buffer) $c

            #TODO: some of these paths are not covered by tests
            switch -- $c/$quoteP {
                (/0 {
                    incr noteP
                }

                \\/0 {
                    set quoteP 1
                }

                )/0 {
                    if {[incr noteP -1] < 1} {
                        if {[info exists state(comment)]} {
                            append state(comment) { }
                        }
                        append state(comment) $state(buffer)

                        return [parselexeme $token]
                    }
                }

                default {
                    set quoteP 0
                }
            }

            if {[set c [string index $state(input) 0]] eq {}} {
                set state(buffer) "end-of-input during comment"
                return [set state(lastC) LX_ERR]
            }
            set state(input) [string range $state(input) 1 end]
        }
    }

    if {$c eq "\""} {
        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 {[set c [string index $state(input) 0]] eq {}} {
                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 {$c eq {[}} {
        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 {[set c [string index $state(input) 0]] eq {}} {
                set state(buffer) "end-of-input during domain-literal"
                return [set state(lastC) LX_ERR]
            }
            set state(input) [string range $state(input) 1 end]
        }
    }

    if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} {
        append state(buffer) $c

        return [set state(lastC) [lindex $state(lexemeL) $x]]
    }

    while {1} {
        append state(buffer) $c

        switch -- [set c [string index $state(input) 0]] {
            {} - " " - "\t" - "\n" {
                break
            }

            default {
                if {[lsearch -exact $state(tokenL) $c] >= 0} {
                    break
                }
            }
        }

        set state(input) [string range $state(input) 1 end]
    }

    return [set state(lastC) LX_ATOM]
}

# ::mime::mapencoding --
#
#    mime::mapencodings maps tcl encodings onto the proper names for their
#    MIME charset type.  This is only done for encodings whose charset types
#    were known.  The remaining encodings return {} for now.
#
# Arguments:
#       enc      The tcl encoding to map.
#
# Results:
#    Returns the MIME charset type for the specified tcl encoding, or {}
#       if none is known.

proc ::mime::mapencoding {enc} {

    variable encodings

    if {[info exists encodings($enc)]} {
        return $encodings($enc)
    }
    return {}
}

# ::mime::reversemapencoding --
#
#    mime::reversemapencodings maps MIME charset types onto tcl encoding names.
#    Those that are unknown return {}.
#
# Arguments:
#       mimeType  The MIME charset to convert into a tcl encoding type.
#
# Results:
#    Returns the tcl encoding name for the specified mime charset, or {}
#       if none is known.

proc ::mime::reversemapencoding {mimeType} {

    variable reversemap

    set lmimeType [string tolower $mimeType]
    if {[info exists reversemap($lmimeType)]} {
        return $reversemap($lmimeType)
    }
    return {}
}

# ::mime::word_encode --
#
#    Word encodes strings as per RFC 2047.
#
# Arguments:
#       charset   The character set to encode the message to.
#       method    The encoding method (base64 or quoted-printable).
#       string    The string to encode.
#       ?-charset_encoded   0 or 1      Whether the data is already encoded
#                                       in the specified charset (default 1)
#       ?-maxlength         maxlength   The maximum length of each encoded
#                                       word to return (default 66)
#
# Results:
#    Returns a word encoded string.

proc ::mime::word_encode {charset method string {args}} {

    variable encodings

    if {![info exists encodings($charset)]} {
        error "unknown charset '$charset'"
    }

    if {$encodings($charset) eq {}} {
        error "invalid charset '$charset'"
    }

    if {$method ne "base64" && $method ne "quoted-printable"} {
        error "unknown method '$method', must be base64 or quoted-printable"
    }

    # default to encoded and a length that won't make the Subject header to long
    array set options [list -charset_encoded 1 -maxlength 66]
    array set options $args

    if {$options(-charset_encoded)} {
        set unencoded_string [::encoding convertfrom $charset $string]
    } else {
        set unencoded_string $string
    }

    set string_length [string length $unencoded_string]

    if {!$string_length} {
        return {}
    }

    set string_bytelength [string bytelength $unencoded_string]

    # the 7 is for =?, ?Q?, ?= delimiters of the encoded word
    set maxlength [expr {$options(-maxlength) - [string length $encodings($charset)] - 7}]
    switch -exact -- $method {
        base64 {
            if {$maxlength < 4} {
                error "maxlength $options(-maxlength) too short for chosen charset and encoding"
            }
            set count 0
            set maxlength [expr {($maxlength / 4) * 3}]
            while {$count < $string_length} {
                set length 0
                set enc_string {}
                while {($length < $maxlength) && ($count < $string_length)} {
                    set char [string range $unencoded_string $count $count]
                    set enc_char [::encoding convertto $charset $char]
                    if {($length + [string length $enc_char]) > $maxlength} {
                        set length $maxlength
                    } else {
                        append enc_string $enc_char
                        incr count
                        incr length [string length $enc_char]
                    }
                }
                set encoded_word [string map [
                    list \n {}] [base64 -mode encode -- $enc_string]]
                append result "=?$encodings($charset)?B?$encoded_word?=\n "
            }
            # Trim off last "\n ", since the above code has the side-effect
            # of adding an extra "\n " to the encoded string.

            set result [string range $result 0 end-2]
        }
        quoted-printable {
            if {$maxlength < 1} {
                error "maxlength $options(-maxlength) too short for chosen charset and encoding"
            }
            set count 0
            while {$count < $string_length} {
                set length 0
                set encoded_word {}
                while {($length < $maxlength) && ($count < $string_length)} {
                    set char [string range $unencoded_string $count $count]
                    set enc_char [::encoding convertto $charset $char]
                    set qp_enc_char [qp_encode $enc_char 1]
                    set qp_enc_char_length [string length $qp_enc_char]
                    if {$qp_enc_char_length > $maxlength} {
                        error "maxlength $options(-maxlength) too short for chosen charset and encoding"
                    }
                    if {($length + [
                        string length $qp_enc_char]) > $maxlength} {

                        set length $maxlength
                    } else {
                        append encoded_word $qp_enc_char
                        incr count
                        incr length [string length $qp_enc_char]
                    }
                }
                append result "=?$encodings($charset)?Q?$encoded_word?=\n "
            }
            # Trim off last "\n ", since the above code has the side-effect
            # of adding an extra "\n " to the encoded string.

            set result [string range $result 0 end-2]
        }
        {} {
            # Go ahead
        }
        default {
            error "Can't handle content encoding \"$method\""
        }
    }
    return $result
}

# ::mime::word_decode --
#
#    Word decodes strings that have been word encoded as per RFC 2047.
#
# Arguments:
#       encoded   The word encoded string to decode.
#
# Results:
#    Returns the string that has been decoded from the encoded message.

proc ::mime::word_decode {encoded} {

    variable reversemap

    if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded \
                - charset method string] != 1} {
        error "malformed word-encoded expression '$encoded'"
    }

    set enc [reversemapencoding $charset]
    if {$enc eq {}} {
        error "unknown charset '$charset'"
    }

    switch -exact -- $method {
        b -
        B {
            set method base64
        }
        q -
        Q {
            set method quoted-printable
        }
        default {
            error "unknown method '$method', must be B or Q"
        }
    }

    switch -exact -- $method {
        base64 {
            set result [base64 -mode decode -- $string]
        }
        quoted-printable {
            set result [qp_decode $string 1]
        }
        {} {
            # Go ahead
        }
        default {
            error "Can't handle content encoding \"$method\""
        }
    }

    return [list $enc $method $result]
}

# ::mime::field_decode --
#
#    Word decodes strings that have been word encoded as per RFC 2047
#    and converts the string from the original encoding/charset to UTF.
#
# Arguments:
#       field     The string to decode
#
# Results:
#    Returns the decoded string in UTF.

proc ::mime::field_decode {field} {
    # ::mime::field_decode is broken.  Here's a new version.
    # This code is in the public domain.  Don Libes <[email protected]>

    # Step through a field for mime-encoded words, building a new
    # version with unencoded equivalents.

    # Sorry about the grotesque regexp.  Most of it is sensible.  One
    # notable fudge: the final $ is needed because of an apparent bug
    # in the regexp engine where the preceding .* otherwise becomes
    # non-greedy - perhaps because of the earlier ".*?", sigh.

    while {[regexp {(.*?)(=\?(?:[^?]+)\?(?:.)\?(?:[^?]*)\?=)(.*)$} $field ignore prefix encoded field]} {
        # don't allow whitespace between encoded words per RFC 2047
        if {{} != $prefix} {
            if {![string is space $prefix]} {
                append result $prefix
            }
        }

        set decoded [word_decode $encoded]
        foreach {charset - string} $decoded break

        append result [::encoding convertfrom $charset $string]
    }
    append result $field
    return $result
}

## One-Shot Initialization

::apply {{} {
    variable encList
    variable encAliasList
    variable reversemap

    foreach {enc mimeType} $encList {
        if {$mimeType eq {}} continue
	set reversemap([string tolower $mimeType]) $enc
    }

    foreach {enc mimeType} $encAliasList {
        set reversemap([string tolower $mimeType]) $enc
    }

    # Drop the helper variables
    unset encList encAliasList

} ::mime}

# mime.test - Test suite for TclMIME                     -*- tcl -*-
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
# RCS: @(#) $Id: mime.test,v 1.31 2012/02/23 17:35:17 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.5
testsNeedTcltest 2.0

support {
    # This code loads md5x, i.e. md5 v2. Proper testing should do one
    # run using md5 v1, aka md5.tcl as well.
    use md5/md5x.tcl md5
}
testing {
    useLocal mime.tcl mime
}

# -------------------------------------------------------------------------

namespace import mime::*

# -------------------------------------------------------------------------

test mime-1.1 {initialize with no args} {
    catch {initialize} res
    subst $res
} {specify exactly one of -file, -parts, or -string}

test mime-2.1 {Generate a MIME message} {
    set tok [initialize -canonical "Text/plain" -string "jack and jill"]
    set msg [mime::buildmessage $tok]
    # The generated message is predictable except for the Content-ID
    regexp "MIME-Version: 1.0\r
Content-ID: \[^\n]+\r
Content-Type: text/plain\r
\r
jack and jill" $msg
} 1

test mime-2.2 {Generate a multi-part MIME message} {
    set tok1 [initialize -canonical "Text/plain" -string "jack and jill"]
    set tok2 [initialize -canonical "Text/plain" -string "james"]
    set bigTok [mime::initialize -canonical Multipart/MyType \
	    -param [list MyParam foo] \
	    -param [list boundary bndry] \
	    -header [list Content-Description "Test Multipart"] \
	    -parts [list $tok1 $tok2]]
    set msg [mime::buildmessage $bigTok]
    # The generated message is predictable except for the Content-ID
    list [regexp "MIME-Version: 1.0\r
Content-Description: Test Multipart\r
Content-ID: \[^\n]+\r
Content-Type: multipart/mytype;\r
              \[^\n]+;\r
              \[^\n]+\r
\r
--bndry\r
MIME-Version: 1.0\r
Content-ID: \[^\n]+\r
Content-Type: text/plain\r
\r
jack and jill\r
--bndry\r
MIME-Version: 1.0\r
Content-ID: \[^\n]+\r
Content-Type: text/plain\r
\r
james\r
--bndry--\r
" $msg] [regexp "boundary=\"bndry\"" $msg] [regexp "myparam=\"foo\"" $msg]
} {1 1 1}

test mime-3.1 {Parse a MIME message} {
    set msg {MIME-Version: 1.0
Content-Type: Text/plain

I'm the message.}
    set tok [mime::initialize -string $msg]
    mime::getbody $tok
} "I'm the message."

test mime-3.2 {Parse a multi-part MIME message} {
    set msg {MIME-Version: 1.0
Content-Type: Multipart/foo; boundary="bar"

--bar
MIME-Version: 1.0
Content-Type: Text/plain

part1
--bar
MIME-Version: 1.0
Content-Type: Text/plain

part2
--bar
MIME-Version: 1.0
Content-Type: Text/plain

part3
--bar--
}

    set tok [mime::initialize -string $msg]
    set partToks [mime::getproperty $tok parts]

    set res ""
    foreach childTok $partToks {
	lappend res [mime::getbody $childTok]
    }
    set res
} {part1 part2 part3}

test mime-3.3 {Try to parse a totally invalid message} {
    catch {mime::initialize -string "blah"} err0
    set err0
} {improper line in header: blah}

test mime-3.4 {Try to parse a MIME message with an invalid version} {
    set msg1 {MIME-Version: 2.0
Content-Type: text/plain

msg1}

    set tok [mime::initialize -string $msg1]
    catch {mime::getbody $tok} err1
    catch {mime::buildmessage $tok} err1a
    list $err1 $err1a
} "msg1 {MIME-Version: 2.0\r
Content-Type: text/plain\r
\r
msg1}"

test mime-3.5 {Try to parse a MIME message with no newline between headers and data} {
    set msg2 {MIME-Version: 1.0
Content-Type: foobar
data without newline}

    catch {mime::initialize -string $msg2} err2
    set err2
} {improper line in header: data without newline}

test mime-3.6 {Try to parse a MIME message with no MIME version and generate a new message from it} {

    # No MIME version
    set msg3 {Content-Type: text/plain

foo}

    set tok [mime::initialize -string $msg3]
    catch {mime::getbody $tok} err3
    catch {mime::buildmessage $tok} err3a
    list $err3 $err3a
} "foo {MIME-Version: 1.0\r
Content-Type: text/plain\r
\r
foo}"

test mime-3.7 {Test mime with a bad email [SF Bug 631314 ]} {
    set tok [mime::initialize -file \
		 [file join $tcltest::testsDirectory badmail1.txt]]

    set res {}
    set ctok [lindex [mime::getproperty $tok parts] 0]
    lappend res [dictsort [mime::getproperty $tok]]
    lappend res [dictsort [mime::getproperty $ctok]]
    mime::finalize $tok
    string map [list $ctok CHILD] $res
} {{content multipart/mixed encoding {} params {boundary ----------CSFNU9QKPGZL79} parts CHILD size 0} {content application/octet-stream encoding {} params {charset us-ascii} size 0}}

test mime-3.8 {Test mime with another bad email [SF Bug 631314 ]} {
    set tok [mime::initialize -file \
		 [file join $tcltest::testsDirectory badmail2.txt]]
    set res {}
    set ctok [lindex [mime::getproperty $tok parts] 0]
    lappend res [dictsort [mime::getproperty $tok]]
    lappend res [dictsort [mime::getproperty $ctok]]
    mime::finalize $tok
    string map [list $ctok CHILD] $res
} {{content multipart/related encoding {} params {boundary ----=_NextPart_000_0000_2CBA2CBA.150C56D2} parts CHILD size 659} {content application/octet-stream encoding base64 params {} size 659}}

test mime-3.9 {Parse a MIME message with a charset encoded body and use getbody -decode to get it back} {
    set msg {MIME-Version: 1.0
Content-Type: text/plain; charset=ISO-8859-1

Fran\xE7ois
}
    set tok [mime::initialize -string $msg]
    mime::getbody $tok -decode
} {Fran\xE7ois
}

test mime-3.10 {Parse a MIME message with a charset encoded body and use getbody -decode to get it back (example from encoding man page)} {
    set msg {MIME-Version: 1.0
Content-Type: text/plain; charset=EUC-JP
Content-Transfer-Encoding: quoted-printable

=A4=CF}
    set tok [mime::initialize -string $msg]
    mime::getbody $tok -decode
} "\u306F"

test mime-3.11 {Parse a MIME message without a charset encoded body and use getbody -decode to get it back} {
    set msg {MIME-Version: 1.0
Content-Type: text/plain
Content-Transfer-Encoding: quoted-printable

A plain text message.}
    set tok [mime::initialize -string $msg]
    mime::getbody $tok -decode
} "A plain text message."

test mime-3.12 {Parse a MIME message with a charset encoded body in an unrecognised charset and use getbody -decode to attempt to get it back} {
    set msg {MIME-Version: 1.0
Content-Type: text/plain; charset=SCRIBBLE
Content-Transfer-Encoding: quoted-printable

This is a message in the scribble charset that tcl does not recognise.}
    set tok [mime::initialize -string $msg]
    catch {mime::getbody $tok -decode} errmsg
    set errmsg
} "-decode failed: can't reversemap charset SCRIBBLE"

test mime-3.13 {Parse a MIME message with a charset encoded body in an unrecognised charset but don't use -decode so we get it back raw} {
    set msg {MIME-Version: 1.0
Content-Type: text/plain; charset=SCRIBBLE
Content-Transfer-Encoding: quoted-printable

This is a message in the scribble charset that tcl does not recognise.}
    set tok [mime::initialize -string $msg]
    mime::getbody $tok
} "This is a message in the scribble charset that tcl does not recognise."

test mime-4.1 {Test qp_encode with a > 76 character string containing special chars.} {
    set str1 "foo!\"\t barbaz \$ ` \{ # jack and jill went up a hill to fetch a pail of water. Jack fell down and said !\"\#\$@\[\\\]^`\{\|\}\~  \nJill said, \"Oh my\""
    mime::qp_encode $str1
} "foo=21=22\t barbaz =24 =60 =7B =23 jack and jill went up a hill to fetch a=\n pail of water. Jack fell down and said =21=22=23=24=40=5B=5C=5D=5E=60=7B=\n=7C=7D=7E =20\nJill said, =22Oh my=22"

test mime-4.2 {Check that encode/decode yields original string} {
    set str1 "foo!\"\t barbaz \$ ` \{ # jack and jill went up a hill to fetch a pail of water. Jack fell down and said !\"\#\$@\[\\\]^`\{\|\}\~  \nJill said, \"Oh my\"  "
    set enc [mime::qp_encode $str1]
    set dec [mime::qp_decode $enc]
    string equal $dec $str1
} {1}

test mime-4.3 {mime::decode data that might come from an MUA} {
    set enc "I'm the =22 message =\nwith some new lines=  \n but with some extra space, too.   "
    mime::qp_decode $enc
} "I'm the \" message with some new lines but with some extra space, too."

test mime-4.4 {Test qp_encode with non-US_ASCCI characters.} {
    set str1 "Test de caract�res accentu�s : � � � � et quelques contr�les \"\[|\]()\""
    mime::qp_encode $str1
} "Test de caract=E8res accentu=E9s : =E2 =EE =E9 =E7 et quelques contr=F4le=\ns =22=5B=7C=5D()=22"


test mime-4.5 {Test qp_encode with softbreak} {
    set str1 [string repeat abc 40]
    mime::qp_encode $str1
} "abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabca=
bcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc"

test mime-4.6 {Test qp_encode with softbreak} {
    set str1 [string repeat abc 40]
    mime::qp_encode $str1 0 1
} [string repeat abc 40]




test mime-5.1 {Test word_encode with quoted-printable method} {
    mime::word_encode iso8859-1 quoted-printable "Test de contr�le effectu�"
} "=?ISO-8859-1?Q?Test_de_contr=F4le_effectu=E9?="

test mime-5.2 {Test word_encode with base64 method} {
    mime::word_encode iso8859-1 base64 "Test de contr�le effectu�"
} "=?ISO-8859-1?B?VGVzdCBkZSBjb250cvRsZSBlZmZlY3R16Q==?="

test mime-5.3 {Test encode+decode with quoted-printable method} {
    set enc [mime::word_encode iso8859-1 quoted-printable "Test de contr�le effectu�"]
    mime::word_decode $enc
} {iso8859-1 quoted-printable {Test de contr�le effectu�}}

test mime-5.4 {Test encode+decode with base64 method} {
    set enc [mime::word_encode iso8859-1 base64 "Test de contr�le effectu�"]
    mime::word_decode $enc
} {iso8859-1 base64 {Test de contr�le effectu�}}

test mime-5.5 {Test decode with lowercase quoted-printable method} {
	mime::word_decode "=?ISO-8859-1?q?Test_lowercase_q?="
} {iso8859-1 quoted-printable {Test lowercase q}}

test mime-5.6 {Test decode with lowercase base64 method} {
	mime::word_decode "=?ISO-8859-1?b?VGVzdCBsb3dlcmNhc2UgYg==?="
} {iso8859-1 base64 {Test lowercase b}}

test mime-5.7 {Test word_encode with quoted-printable method across encoded word boundaries} {
    mime::word_encode iso8859-1 quoted-printable "Test de contr�le effectu�" -maxlength 31
} "=?ISO-8859-1?Q?Test_de_contr?=
 =?ISO-8859-1?Q?=F4le_effectu?=
 =?ISO-8859-1?Q?=E9?="

test mime-5.8 {Test word_encode with quoted-printable method across encoded word boundaries} {
    mime::word_encode iso8859-1 quoted-printable "Test de contr�le effectu�" -maxlength 32
} "=?ISO-8859-1?Q?Test_de_contr?=
 =?ISO-8859-1?Q?=F4le_effectu?=
 =?ISO-8859-1?Q?=E9?="

test mime-5.9 {Test word_encode with quoted-printable method and multibyte character} {
    mime::word_encode euc-jp quoted-printable "Following me is a multibyte character \xA4\xCF"
} "=?EUC-JP?Q?Following_me_is_a_multibyte_character_=A4=CF?="

set n 10
while {$n < 14} {
    test mime-5.$n {Test word_encode with quoted-printable method and multibyte character across encoded word boundary} {
        mime::word_encode euc-jp quoted-printable "Following me is a multibyte character \xA4\xCF" -maxlength [expr 42 + $n]
    } "=?EUC-JP?Q?Following_me_is_a_multibyte_character_?=
 =?EUC-JP?Q?=A4=CF?="
    incr n
}

test mime-5.14 {Test word_encode with quoted-printable method and multibyte character (triple)} {
    mime::word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF"
} "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_=E3=81=AF?="

set n 15
while {$n < 23} {
    test mime-5.$n {Test word_encode with quoted-printable method and triple byte character across encoded word boundary} {
        mime::word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" -maxlength [expr 38 + $n]
    } "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_?=
 =?UTF-8?Q?=E3=81=AF?="
    incr n
}

while {$n < 25} {
    test mime-5.$n {Test word_encode with quoted-printable method and triple byte character across encoded word boundary} {
        mime::word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" -maxlength [expr 38 + $n]
    } "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_=E3=81=AF?="
    incr n
}

while {$n < 29} {
    test mime-5.$n {Test word_encode with base64 method across encoded word boundaries} {
        mime::word_encode euc-jp base64 "There is a multibyte character \xA4\xCF" -maxlength [expr 28 + $n]
    } "=?EUC-JP?B?VGhlcmUgaXMgYSBtdWx0aWJ5dGUgY2hhcmFjdGVy?=
 =?EUC-JP?B?IKTP?="
    incr n
}

while {$n < 33} {
    test mime-5.$n {Test word_encode with base64 method and triple byte character across encoded word boundary} {
        mime::word_encode utf-8 base64 "Here is a multibyte character \xE3\x81\xAF" -maxlength [expr 23 + $n]
    } "=?UTF-8?B?SGVyZSBpcyBhIG11bHRpYnl0ZSBjaGFyYWN0ZXIg?=
 =?UTF-8?B?44Gv?="
    incr n
}

test mime-5.33 {Test word_encode with quoted-printable method and -maxlength set to same length as will the result} {
    mime::word_encode iso8859-1 quoted-printable "123" -maxlength 20
} "=?ISO-8859-1?Q?123?="

test mime-5.34 {Test word_encode with base64 method and -maxlength set to same length as will the result} {
    mime::word_encode iso8859-1 base64 "123" -maxlength 21
} "=?ISO-8859-1?B?MTIz?="

test mime-5.35 {Test word_encode with quoted-printable method and non charset encoded string} {
    mime::word_encode utf-8 quoted-printable "\u306F" -charset_encoded 0
} "=?UTF-8?Q?=E3=81=AF?="

test mime-5.36 {Test word_encode with base64 method and non charset encoded string} {
    mime::word_encode utf-8 base64 "\u306F" -charset_encoded 0
} "=?UTF-8?B?44Gv?="

test mime-5.36 {Test word_encode with base64 method and one byte} {
    mime::word_encode iso8859-1 base64 "a"
} "=?ISO-8859-1?B?YQ==?="

test mime-5.37 {Test word_encode with base64 method and two bytes} {
    mime::word_encode euc-jp base64 "\xA4\xCF"
} "=?EUC-JP?B?pM8=?="

test mime-5.38 {Test word_encode with unknown charset} {
    catch {mime::word_encode scribble  quoted-printable "scribble is an unknown charset"} errmsg
    set errmsg
} "unknown charset 'scribble'"

test mime-5.39 {Test word_encode with invalid charset} {
    catch {mime::word_encode unicode quoted-printable "unicode is not a valid charset"} errmsg
    set errmsg
} "invalid charset 'unicode'"

test mime-5.40 {Test word_encode with invalid method} {
    catch {mime::word_encode iso8859-1 tea-leaf "tea-leaf is not a valid method"} errmsg
    set errmsg
} "unknown method 'tea-leaf', must be base64 or quoted-printable"

test mime-5.41 {Test word_encode with maxlength to short for method quoted-printable} {
    catch {mime::word_encode iso8859-1 quoted-printable "1" -maxlength 17} errmsg
    set errmsg
} "maxlength 17 too short for chosen charset and encoding"

test mime-5.42 {Test word_encode with maxlength on the limit for quoted_printable and an unquoted character} {
   catch {mime::word_encode iso8859-1 quoted-printable "_" -maxlength 18} errmsg
   set errmsg
} "=?ISO-8859-1?Q?_?="

test mime-5.43 {Test word_encode with maxlength to short for method quoted_printable and a character to be quoted} {
   catch {mime::word_encode iso8859-1 quoted-printable "=" -maxlength 18} errmsg
   set errmsg
} "maxlength 18 too short for chosen charset and encoding"


test mime-5.44 {Test word_encode with maxlength to short for method quoted-printable and multibyte character} {
    catch {mime::word_encode euc-jp quoted-printable "\xA4\xCF" -maxlength 17} errmsg
    set errmsg
} "maxlength 17 too short for chosen charset and encoding"

test mime-5.45 {Test word_encode with maxlength to short for method base64} {
    catch {mime::word_encode iso8859-1 base64 "1" -maxlength 20} errmsg
    set errmsg
} "maxlength 20 too short for chosen charset and encoding"

test mime-6.1 {Test field_decode (from RFC 2047, part 8)} {
    mime::field_decode {=?US-ASCII?Q?Keith_Moore?= <[email protected]>}
} {Keith Moore <[email protected]>}

test mime-6.2 {Test field_decode (from RFC 2047, part 8)} {
    mime::field_decode {=?ISO-8859-1?Q?Patrik_F=E4ltstr=F6m?= <[email protected]>}
} {Patrik F�ltstr�m <[email protected]>}

test mime-6.3 {Test field_decode (from RFC 2047, part 8)} {
    mime::field_decode {=?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?=
			=?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?=}
} {If you can read this you understand the example.}

foreach {n encoded expected} {
    4 "(=?ISO-8859-1?Q?a?=)"
    "(a)"
    5 "(=?ISO-8859-1?Q?a?= b)"
    "(a b)"
    6 "(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)"
    "(ab)"
    7 "(=?ISO-8859-1?Q?a?=  =?ISO-8859-1?Q?b?=)"
    "(ab)"
    8 "(=?ISO-8859-1?Q?a?=
    =?ISO-8859-1?Q?b?=)"
    "(ab)"
    9 "(=?ISO-8859-1?Q?a_b?=)"
    "(a b)"
    10 "(=?ISO-8859-1?Q?a?= =?ISO-8859-2?Q?_b?=)"
    "(a b)"
    11 "(=?ISO-8859-1?Q?a?=x=?ISO-8859-2?Q?_b?=)"
    "(ax b)"
    12 "a         b         c"
    "a         b         c"
    13 ""
    ""
} {
    test mime-6.$n {Test field_decode (from RFC 2047, part 8)} {
	mime::field_decode $encoded
    } $expected ; # {}
}

foreach {bug n encoded expected} {
    764702 1 "(=?utf-8?Q?H=C3=BCrz?=)" "(H�rz)"
} {
    test mime-7.$n "Test field_decode (from SF Tcllib bug $bug)" {
	mime::field_decode $encoded
    } $expected ; # {}
}

test mime-8.1 {Test reversemapencoding+mapencoding with preferred name} {
    set charset [mime::reversemapencoding "US-ASCII"]
    mime::mapencoding $charset
} {US-ASCII}

test mime-8.2 {Test reversemapencoding+mapencoding with alias} {
    set charset [mime::reversemapencoding "UTF8"]
    mime::mapencoding $charset
} {UTF-8}


test mime-9.0 {Test chunk handling of copymessage and helpers} {
    set in [makeFile [set data [string repeat [string repeat "123456789 " 10]\n 350]] input.txt]
    set mi [makeFile {} mime.txt]

    set token [mime::initialize -canonical text/plain -file $in]

    set f [open $mi w]
    fconfigure $f -translation binary
    mime::copymessage $token $f
    close $f

    set token [mime::initialize -file $mi]
    set newdata [mime::getbody $token]
    set res [string compare $data $newdata]

    removeFile input.txt
    removeFile mime.txt
    unset data newdata token f in mi
    set res
} 0

set ::env(TZ) "UTC0"
set epoch [clock scan 2000-01-01]
foreach {n stamp date} {
    1     86340 {Sat, 01 Jan 2000 23:59:00 +0000}
    2   5176620 {Tue, 29 Feb 2000 21:57:00 +0000}
    3  31610520 {Sun, 31 Dec 2000 20:42:00 +0000}
    4  31708740 {Mon, 01 Jan 2001 23:59:00 +0000}
    5  68248620 {Thu, 28 Feb 2002 21:57:00 +0000}
    6 126218520 {Wed, 31 Dec 2003 20:42:00 +0000}
} {
    test mime-10.$n "Test formatting dates (RFC 822)" {
        # To verify that clock scan gets the expected value.
        set stamp_test [expr {[mime::parsedatetime $date clock] - $epoch}]
        # Parse and re-format should get us the original.
        set parsed_test [mime::parsedatetime $date proper]
        list $stamp_test $parsed_test
    } [list $stamp $date]
}


test mime-11.0 {Bug 1825092} {
    set in [makeFile {From [email protected]  Sat Oct 20 17:58:49 2007
Return-Path: <[email protected]>
Message-ID: <[email protected]>
From: Somwhere <[email protected]>
MIME-Version: 1.0
To: Here <[email protected]>
Subject: test
Content-Type: multipart/mixed;
 boundary="------------090305080603000703000106"

This is a multi-part message in MIME format.
--------------090305080603000703000106
Content-Type: text/plain; charset=ISO-8859-15
Content-Transfer-Encoding: 8bit

XXX

--------------090305080603000703000106
Content-Disposition: attachment;
 filename="a0036.dss"
Content-Transfer-Encoding: base64
Content-Type: application/octet-stream;
 name="a0036.dss"

BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAZ
--------------090305080603000703000106--
} mail_part]
    set token [mime::initialize -file $in]
    set allparts [mime::getproperty $token parts]
    set attachment [lindex $allparts 1]

    set out [makeFile {} mail_att]
    set ofh [open $out w]
    fconfigure $ofh -translation binary
    mime::copymessage $attachment $ofh
    close $ofh

    set data [viewFile $out]
    file delete $in $out
    set data
} {MIME-Version: 1.0
Content-Disposition: attachment;
 filename="a0036.dss"
Content-Transfer-Encoding: base64
Content-Type: application/octet-stream;
              name="a0036.dss"

BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAZ}

# -------------------------------------------------------------------------

test mime-12.0 {Bug 3483716} {
    set token [mime::initialize -string {Content-Type: message/delivery-status; name="deliverystatus.txt"
Content-Disposition: attachment; filename="deliverystatus.txt"; size=138;
creation-date="Thu, 02 Feb 2012 13:50:05 GMT";
modification-date="Thu, 02 Feb 2012 13:50:05 GMT"
Content-Description: deliverystatus.txt
Content-Transfer-Encoding: base64

T3JpZ2luYWwtUmVjaXBpZW50OiA8L2ZheD1ibHViYkBndW1taS5ib290PgpBY3Rpb246IGZhaWxl
ZApEaWFnbm9zdGljLUNvZGU6IHNtdHA7IDU1MCAjNS4xLjAgQWRkcmVzcyByZWplY3RlZC4KUmVt
b3RlLU1UQTogNTMuMjQuMjgyLjE1MA==
}]
    set parts [mime::getproperty $token parts]
    mime::getheader [lindex $parts end] Remote-MTA
} 53.24.282.150

# -------------------------------------------------------------------------

testsuiteCleanup
return

if {![package vsatisfies [package provide Tcl] 8.6.9]} {return}
package ifneeded smtp 1.4.5 [list source [file join $dir smtp-1.4.tcl]]
package ifneeded mime 1.6 [list source [file join $dir mime-1.6.tcl]]

if {![package vsatisfies [package provide Tcl] 8.6.9]} {return}
package ifneeded smtp 1.5 [list source [file join $dir smtp.tcl]]
package ifneeded mime 1.7 [list source [file join $dir mime.tcl]]
package ifneeded {mime qp} 1.7 [list source [file join $dir qp.tcl]]

# smtp.tcl - SMTP client
#
# Copyright (c) 1999-2000 Marshall T. Rose
# Copyright (c) 2003-2006 Pat Thoyts
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require Tcl 8.3
package require -exact mime 1.6

catch {
    package require SASL 1.0;           # tcllib 1.8
    package require SASL::NTLM 1.0;     # tcllib 1.8
}

#
# state variables:
#
#    sd: socket to server
#    afterID: afterID associated with ::smtp::timer
#    options: array of user-supplied options
#    readable: semaphore for vwait
#    addrs: number of recipients negotiated
#    error: error during read
#    line: response read from server
#    crP: just put a \r in the data
#    nlP: just put a \n in the data
#    size: number of octets sent in DATA
#

namespace eval ::smtp {
    variable  trf 1
    variable  smtp
    array set smtp { uid 0 }

    namespace export sendmessage
}

if {[catch {package require Trf  2.0}]} {
    # Trf is not available, but we can live without it as long as the
    # transform and unstack procs are defined.

    # Warning!
    # This is a fragile emulation of the more general calling sequence
    # that appears to work with this code here.

    proc transform {args} {
	upvar state mystate
	set mystate(size) 1
    }
    proc unstack {channel} {
        # do nothing
        return
    }
    set ::smtp::trf 0
}


# ::smtp::sendmessage --
#
#	Sends a mime object (containing a message) to some recipients
#
# Arguments:
#	part  The MIME object containing the message to send
#       args  A list of arguments specifying various options for sending the
#             message:
#             -atleastone  A boolean specifying whether or not to send the
#                          message at all if any of the recipients are
#                          invalid.  A value of false (as defined by
#                          ::smtp::boolean) means that ALL recipients must be
#                          valid in order to send the message.  A value of
#                          true means that as long as at least one recipient
#                          is valid, the message will be sent.
#             -debug       A boolean specifying whether or not debugging is
#                          on.  If debugging is enabled, status messages are
#                          printed to stderr while trying to send mail.
#             -queue       A boolean specifying whether or not the message
#                          being sent should be queued for later delivery.
#             -header      A single RFC 822 header key and value (as a list),
#                          used to specify to whom to send the message
#                          (To, Cc, Bcc), the "From", etc.
#             -originator  The originator of the message (equivalent to
#                          specifying a From header).
#             -recipients  A string containing recipient e-mail addresses.
#                          NOTE: This option overrides any recipient addresses
#                          specified with -header.
#             -servers     A list of mail servers that could process the
#                          request.
#             -ports       A list of SMTP ports to use for each SMTP server
#                          specified
#             -client      The string to use as our host name for EHLO or HELO
#                          This defaults to 'localhost' or [info hostname]
#             -maxsecs     Maximum number of seconds to allow the SMTP server
#                          to accept the message. If not specified, the default
#                          is 120 seconds.
#             -usetls      A boolean flag. If the server supports it and we
#                          have the package, use TLS to secure the connection.
#             -tlspolicy   A command to call if the TLS negotiation fails for
#                          some reason. Return 'insecure' to continue with
#                          normal SMTP or 'secure' to close the connection and
#                          try another server.
#             -username    These are needed if your SMTP server requires
#             -password    authentication.
#
# Results:
#	Message is sent.  On success, return "".  On failure, throw an
#       exception with an error code and error message.

proc ::smtp::sendmessage {part args} {
    global errorCode errorInfo

    # Here are the meanings of the following boolean variables:
    # aloP -- value of -atleastone option above.
    # debugP -- value of -debug option above.
    # origP -- 1 if -originator option was specified, 0 otherwise.
    # queueP -- value of -queue option above.

    set aloP 0
    set debugP 0
    set origP 0
    set queueP 0
    set maxsecs 120
    set originator ""
    set recipients ""
    set servers [list localhost]
    set client "" ;# default is set after options processing
    set ports [list 25]
    set tlsP 1
    set tlspolicy {}
    set username {}
    set password {}

    array set header ""

    # lowerL will contain the list of header keys (converted to lower case)
    # specified with various -header options.  mixedL is the mixed-case version
    # of the list.
    set lowerL ""
    set mixedL ""

    # Parse options (args).

    if {[expr {[llength $args]%2}]} {
        # Some option didn't get a value.
        error "Each option must have a value!  Invalid option list: $args"
    }

    foreach {option value} $args {
        switch -- $option {
            -atleastone {set aloP   [boolean $value]}
            -debug      {set debugP [boolean $value]}
            -queue      {set queueP [boolean $value]}
            -usetls     {set tlsP   [boolean $value]}
            -tlspolicy  {set tlspolicy $value}
	    -maxsecs    {set maxsecs [expr {$value < 0 ? 0 : $value}]}
            -header {
                if {[llength $value] != 2} {
                    error "-header expects a key and a value, not $value"
                }
                set mixed [lindex $value 0]
                set lower [string tolower $mixed]
                set disallowedHdrList \
                    [list content-type \
                          content-transfer-encoding \
                          content-md5 \
                          mime-version]
                if {[lsearch -exact $disallowedHdrList $lower] > -1} {
                    error "Content-Type, Content-Transfer-Encoding,\
                        Content-MD5, and MIME-Version cannot be user-specified."
                }
                if {[lsearch -exact $lowerL $lower] < 0} {
                    lappend lowerL $lower
                    lappend mixedL $mixed
                }

                lappend header($lower) [lindex $value 1]
            }

            -originator {
                set originator $value
                if {$originator == ""} {
                    set origP 1
                }
            }

            -recipients {
                set recipients $value
            }

            -servers {
                set servers $value
            }

            -client {
                set client $value
            }

            -ports {
                set ports $value
            }

            -username { set username $value }
            -password { set password $value }

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

    if {[lsearch -glob $lowerL resent-*] >= 0} {
        set prefixL resent-
        set prefixM Resent-
    } else {
        set prefixL ""
        set prefixM ""
    }

    # Set a bunch of variables whose value will be the real header to be used
    # in the outbound message (with proper case and prefix).

    foreach mixed {From Sender To cc Dcc Bcc Date Message-ID} {
        set lower [string tolower $mixed]
	# FRINK: nocheck
        set ${lower}L $prefixL$lower
	# FRINK: nocheck
        set ${lower}M $prefixM$mixed
    }

    if {$origP} {
        # -originator was specified with "", so SMTP sender should be marked "".
        set sender ""
    } else {
        # -originator was specified with a value, OR -originator wasn't
        # specified at all.

        # If no -originator was provided, get the originator from the "From"
        # header.  If there was no "From" header get it from the username
        # executing the script.

        set who "-originator"
        if {$originator == ""} {
            if {![info exists header($fromL)]} {
                set originator $::tcl_platform(user)
            } else {
                set originator [join $header($fromL) ,]

                # Indicate that we're using the From header for the originator.

                set who $fromM
            }
        }

	# If there's no "From" header, create a From header with the value
	# of -originator as the value.

        if {[lsearch -exact $lowerL $fromL] < 0} {
            lappend lowerL $fromL
            lappend mixedL $fromM
            lappend header($fromL) $originator
        }

	# ::mime::parseaddress returns a list whose elements are huge key-value
	# lists with info about the addresses.  In this case, we only want one
	# originator, so we want the length of the main list to be 1.

        set addrs [::mime::parseaddress $originator]
        if {[llength $addrs] > 1} {
            error "too many mailboxes in $who: $originator"
        }
        array set aprops {error "invalid address \"$from\""}
        array set aprops [lindex $addrs 0]
        if {$aprops(error) != ""} {
            error "error in $who: $aprops(error)"
        }

	# sender = validated originator or the value of the From header.

        set sender $aprops(address)

	# If no Sender header has been specified and From is different from
	# originator, then set the sender header to the From.  Otherwise, don't
	# specify a Sender header.
        set from [join $header($fromL) ,]
        if {[lsearch -exact $lowerL $senderL] < 0 && \
                [string compare $originator $from]} {
            if {[info exists aprops]} {
                unset aprops
            }
            array set aprops {error "invalid address \"$from\""}
            array set aprops [lindex [::mime::parseaddress $from] 0]
            if {$aprops(error) != ""} {
                error "error in $fromM: $aprops(error)"
            }
            if {[string compare $aprops(address) $sender]} {
                lappend lowerL $senderL
                lappend mixedL $senderM
                lappend header($senderL) $aprops(address)
            }
        }
    }

    # We're done parsing the arguments.

    if {$recipients != ""} {
        set who -recipients
    } elseif {![info exists header($toL)]} {
        error "need -header \"$toM ...\""
    } else {
        set recipients [join $header($toL) ,]
	# Add Cc values to recipients list
	set who $toM
        if {[info exists header($ccL)]} {
            append recipients ,[join $header($ccL) ,]
            append who /$ccM
        }

        set dccInd [lsearch -exact $lowerL $dccL]
        if {$dccInd >= 0} {
	    # Add Dcc values to recipients list, and get rid of Dcc header
	    # since we don't want to output that.
            append recipients ,[join $header($dccL) ,]
            append who /$dccM

            unset header($dccL)
            set lowerL [lreplace $lowerL $dccInd $dccInd]
            set mixedL [lreplace $mixedL $dccInd $dccInd]
        }
    }

    set brecipients ""
    set bccInd [lsearch -exact $lowerL $bccL]
    if {$bccInd >= 0} {
        set bccP 1

	# Build valid bcc list and remove bcc element of header array (so that
	# bcc info won't be sent with mail).
        foreach addr [::mime::parseaddress [join $header($bccL) ,]] {
            if {[info exists aprops]} {
                unset aprops
            }
            array set aprops {error "invalid address \"$from\""}
            array set aprops $addr
            if {$aprops(error) != ""} {
                error "error in $bccM: $aprops(error)"
            }
            lappend brecipients $aprops(address)
        }

        unset header($bccL)
        set lowerL [lreplace $lowerL $bccInd $bccInd]
        set mixedL [lreplace $mixedL $bccInd $bccInd]
    } else {
        set bccP 0
    }

    # If there are no To headers, add "" to bcc list.  WHY??
    if {[lsearch -exact $lowerL $toL] < 0} {
        lappend lowerL $bccL
        lappend mixedL $bccM
        lappend header($bccL) ""
    }

    # Construct valid recipients list from recipients list.

    set vrecipients ""
    foreach addr [::mime::parseaddress $recipients] {
        if {[info exists aprops]} {
            unset aprops
        }
        array set aprops {error "invalid address \"$from\""}
        array set aprops $addr
        if {$aprops(error) != ""} {
            error "error in $who: $aprops(error)"
        }
        lappend vrecipients $aprops(address)
    }

    # If there's no date header, get the date from the mime message.  Same for
    # the message-id.

    if {([lsearch -exact $lowerL $dateL] < 0) \
            && ([catch { ::mime::getheader $part $dateL }])} {
        lappend lowerL $dateL
        lappend mixedL $dateM
        lappend header($dateL) [::mime::parsedatetime -now proper]
    }

    if {([lsearch -exact $lowerL ${message-idL}] < 0) \
            && ([catch { ::mime::getheader $part ${message-idL} }])} {
        lappend lowerL ${message-idL}
        lappend mixedL ${message-idM}
        lappend header(${message-idL}) [::mime::uniqueID]

    }

    # Get all the headers from the MIME object and save them so that they can
    # later be restored.
    set savedH [::mime::getheader $part]

    # Take all the headers defined earlier and add them to the MIME message.
    foreach lower $lowerL mixed $mixedL {
        foreach value $header($lower) {
            ::mime::setheader $part $mixed $value -mode append
        }
    }

    if {[string length $client] < 1} {
        if {![string compare $servers localhost]} {
            set client localhost
        } else {
            set client [info hostname]
        }
    }

    # Create smtp token, which essentially means begin talking to the SMTP
    # server.
    set token [initialize -debug $debugP -client $client \
		                -maxsecs $maxsecs -usetls $tlsP \
                                -multiple $bccP -queue $queueP \
                                -servers $servers -ports $ports \
                                -tlspolicy $tlspolicy \
                                -username $username -password $password]

    if {![string match "::smtp::*" $token]} {
	# An error occurred and $token contains the error info
	array set respArr $token
	return -code error $respArr(diagnostic)
    }

    set code [catch { sendmessageaux $token $part \
                                           $sender $vrecipients $aloP } \
                    result]
    set ecode $errorCode
    set einfo $errorInfo

    # Send the message to bcc recipients as a MIME attachment.

    if {($code == 0) && ($bccP)} {
        set inner [::mime::initialize -canonical message/rfc822 \
                                    -header [list Content-Description \
                                                  "Original Message"] \
                                    -parts [list $part]]

        set subject "\[$bccM\]"
        if {[info exists header(subject)]} {
            append subject " " [lindex $header(subject) 0]
        }

        set outer [::mime::initialize \
                         -canonical multipart/digest \
                         -header [list From $originator] \
                         -header [list Bcc ""] \
                         -header [list Date \
                                       [::mime::parsedatetime -now proper]] \
                         -header [list Subject $subject] \
                         -header [list Message-ID [::mime::uniqueID]] \
                         -header [list Content-Description \
                                       "Blind Carbon Copy"] \
                         -parts [list $inner]]


        set code [catch { sendmessageaux $token $outer \
                                               $sender $brecipients \
                                               $aloP } result2]
        set ecode $errorCode
        set einfo $errorInfo

        if {$code == 0} {
            set result [concat $result $result2]
        } else {
            set result $result2
        }

        catch { ::mime::finalize $inner -subordinates none }
        catch { ::mime::finalize $outer -subordinates none }
    }

    # Determine if there was any error in prior operations and set errorcodes
    # and error messages appropriately.

    switch -- $code {
        0 {
            set status orderly
        }

        7 {
            set code 1
            array set response $result
            set result "$response(code): $response(diagnostic)"
            set status abort
        }

        default {
            set status abort
        }
    }

    # Destroy SMTP token 'cause we're done with it.

    catch { finalize $token -close $status }

    # Restore provided MIME object to original state (without the SMTP headers).

    foreach key [::mime::getheader $part -names] {
        mime::setheader $part $key "" -mode delete
    }
    foreach {key values} $savedH {
        foreach value $values {
            ::mime::setheader $part $key $value -mode append
        }
    }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::smtp::sendmessageaux --
#
#	Sends a mime object (containing a message) to some recipients using an
#       existing SMTP token.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	part        The MIME object containing the message to send.
#       originator  The e-mail address of the entity sending the message,
#                   usually the From clause.
#       recipients  List of e-mail addresses to whom message will be sent.
#       aloP        Boolean "atleastone" setting; see the -atleastone option
#                   in ::smtp::sendmessage for details.
#
# Results:
#	Message is sent.  On success, return "".  On failure, throw an
#       exception with an error code and error message.

proc ::smtp::sendmessageaux {token part originator recipients aloP} {
    global errorCode errorInfo

    winit $token $part $originator

    set goodP 0
    set badP 0
    set oops ""
    foreach recipient $recipients {
        set code [catch { waddr $token $recipient } result]
        set ecode $errorCode
        set einfo $errorInfo

        switch -- $code {
            0 {
                incr goodP
            }

            7 {
                incr badP

                array set response $result
                lappend oops [list $recipient $response(code) \
                                   $response(diagnostic)]
            }

            default {
                return -code $code -errorinfo $einfo -errorcode $ecode $result
            }
        }
    }

    if {($goodP) && ((!$badP) || ($aloP))} {
        wtext $token $part
    } else {
        catch { talk $token 300 RSET }
    }

    return $oops
}

# ::smtp::initialize --
#
#	Create an SMTP token and open a connection to the SMTP server.
#
# Arguments:
#       args  A list of arguments specifying various options for sending the
#             message:
#             -debug       A boolean specifying whether or not debugging is
#                          on.  If debugging is enabled, status messages are
#                          printed to stderr while trying to send mail.
#             -client      Either localhost or the name of the local host.
#             -multiple    Multiple messages will be sent using this token.
#             -queue       A boolean specifying whether or not the message
#                          being sent should be queued for later delivery.
#             -servers     A list of mail servers that could process the
#                          request.
#             -ports       A list of ports on mail servers that could process
#                          the request (one port per server-- defaults to 25).
#             -usetls      A boolean to indicate we will use TLS if possible.
#             -tlspolicy   Command called if TLS setup fails.
#             -username    These provide the authentication information
#             -password    to be used if needed by the SMTP server.
#
# Results:
#	On success, return an smtp token.  On failure, throw
#       an exception with an error code and error message.

proc ::smtp::initialize {args} {
    global errorCode errorInfo

    variable smtp

    set token [namespace current]::[incr smtp(uid)]
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set state [list afterID "" options "" readable 0]
    array set options [list -debug 0 -client localhost -multiple 1 \
                            -maxsecs 120 -queue 0 -servers localhost \
                            -ports 25 -usetls 1 -tlspolicy {} \
                            -username {} -password {}]
    array set options $args
    set state(options) [array get options]

    # Iterate through servers until one accepts a connection (and responds
    # nicely).

    set index 0
    foreach server $options(-servers) {
	set state(readable) 0
        if {[llength $options(-ports)] >= $index} {
            set port [lindex $options(-ports) $index]
        } else {
            set port 25
        }
        if {$options(-debug)} {
            puts stderr "Trying $server..."
            flush stderr
        }

        if {[info exists state(sd)]} {
            unset state(sd)
        }

        if {[set code [catch {
            set state(sd) [socket -async $server $port]
            fconfigure $state(sd) -blocking off -translation binary
            fileevent $state(sd) readable [list ::smtp::readable $token]
        } result]]} {
            set ecode $errorCode
            set einfo $errorInfo

            catch { close $state(sd) }
            continue
        }

        if {[set code [catch { hear $token 600 } result]]} {
            array set response [list code 400 diagnostic $result]
        } else {
            array set response $result
        }
        set ecode $errorCode
        set einfo $errorInfo
        switch -- $response(code) {
            220 {
            }

            421 - default {
                # 421 - Temporary problem on server
                catch {close $state(sd)}
                continue
            }
        }

        set r [initialize_ehlo $token]
        if {$r != {}} {
            return $r
        }
        incr index
    }

    # None of the servers accepted our connection, so close everything up and
    # return an error.
    finalize $token -close drop

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# If we cannot load the tls package, ignore the error
proc ::smtp::load_tls {} {
    set r [catch {package require tls}]
    if {$r} {set ::errorInfo ""}
    return $r
}

proc ::smtp::initialize_ehlo {token} {
    global errorCode errorInfo
    upvar einfo einfo
    upvar ecode ecode
    upvar code  code

    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)

    # Try enhanced SMTP first.

    if {[set code [catch {smtp::talk $token 300 "EHLO $options(-client)"} \
                       result]]} {
        array set response [list code 400 diagnostic $result args ""]
    } else {
        array set response $result
    }
    set ecode $errorCode
    set einfo $errorInfo
    if {(500 <= $response(code)) && ($response(code) <= 599)} {
        if {[set code [catch { talk $token 300 \
                                   "HELO $options(-client)" } \
                           result]]} {
            array set response [list code 400 diagnostic $result args ""]
        } else {
            array set response $result
        }
        set ecode $errorCode
        set einfo $errorInfo
    }

    if {$response(code) == 250} {
        # Successful response to HELO or EHLO command, so set up queuing
        # and whatnot and return the token.

        set state(esmtp) $response(args)

        if {(!$options(-multiple)) \
                && ([lsearch $response(args) ONEX] >= 0)} {
            catch {smtp::talk $token 300 ONEX}
        }
        if {($options(-queue)) \
                && ([lsearch $response(args) XQUE] >= 0)} {
            catch {smtp::talk $token 300 QUED}
        }

        # Support STARTTLS extension.
        # The state(tls) item is used to see if we have already tried this.
        if {($options(-usetls)) && ![info exists state(tls)] \
                && (([lsearch $response(args) STARTTLS] >= 0)
                    || ([lsearch $response(args) TLS] >= 0))} {
            if {![load_tls]} {
                set state(tls) 0
                if {![catch {smtp::talk $token 300 STARTTLS} resp]} {
                    array set starttls $resp
                    if {$starttls(code) == 220} {
                        fileevent $state(sd) readable {}
                        catch {
                            ::tls::import $state(sd)
                            catch {::tls::handshake $state(sd)} msg
                            set state(tls) 1
                        }
                        fileevent $state(sd) readable \
                            [list ::smtp::readable $token]
                        return [initialize_ehlo $token]
                    } else {
                        # Call a TLS client policy proc here
                        #  returns secure close and try another server.
                        #  returns insecure continue on current socket
                        set policy insecure
                        if {$options(-tlspolicy) != {}} {
                            catch {
                                eval $options(-tlspolicy) \
                                    [list $starttls(code)] \
                                    [list $starttls(diagnostic)]
                            } policy
                        }
                        if {$policy != "insecure"} {
                            set code error
                            set ecode $starttls(code)
                            set einfo $starttls(diagnostic)
                            catch {close $state(sd)}
                            return {}
                        }
                    }
                }
            }
        }

        # If we have not already tried and the server supports it and we
        # have a username -- lets try to authenticate.
        #
        if {![info exists state(auth)]
            && [llength [package provide SASL]] != 0
            && [set andx [lsearch -glob $response(args) "AUTH*"]] >= 0
            && [string length $options(-username)] > 0 } {

            # May be AUTH mech or AUTH=mech
            # We want to use the strongest mechanism that has been offered
            # and that we support. If we cannot find a mechanism that
            # succeeds, we will go ahead and try to carry on unauthenticated.
            # This may still work else we'll get an unauthorised error later.

            set mechs [string range [lindex $response(args) $andx] 5 end]
            foreach mech [SASL::mechanisms] {
                if {[lsearch -exact $mechs $mech] == -1} { continue }
                if {[catch {
                    Authenticate $token $mech
                } msg]} {
                    if {$options(-debug)} {
                        puts stderr "AUTH $mech failed: $msg "
                        flush stderr
                    }
                }
                if {[info exists state(auth)] && $state(auth)} {
                    if {$state(auth) == 1} {
                        break
                    } else {
                        # After successful AUTH we are supposed to redo
                        # our connection for mechanisms that setup a new
                        # security layer -- these should set state(auth)
                        # greater than 1
                        fileevent $state(sd) readable \
                            [list ::smtp::readable $token]
                        return [initialize_ehlo $token]
                    }
                }
            }
        }

        return $token
    } else {
        # Bad response; close the connection and hope the next server
        # is happier.
        catch {close $state(sd)}
    }
    return {}
}

proc ::smtp::SASLCallback {token context command args} {
    upvar #0 $token state
    upvar #0 $context ctx
    array set options $state(options)
    switch -exact -- $command {
        login    { return "" }
        username { return $options(-username) }
        password { return $options(-password) }
        hostname { return [info host] }
        realm    {
            if {[string equal $ctx(mech) "NTLM"] \
                    && [info exists ::env(USERDOMAIN)]} {
                return $::env(USERDOMAIN)
            } else {
                return ""
            }
        }
        default  {
            return -code error "error: unsupported SASL information requested"
        }
    }
}

proc ::smtp::Authenticate {token mechanism} {
    upvar 0 $token state
    package require base64
    set ctx [SASL::new -mechanism $mechanism \
                 -callback [list [namespace origin SASLCallback] $token]]

    set state(auth) 0
    set result [smtp::talk $token 300 "AUTH $mechanism"]
    array set response $result

    while {$response(code) == 334} {
        # The NTLM initial response is not base64 encoded so handle it.
        if {[catch {base64::decode $response(diagnostic)} challenge]} {
            set challenge $response(diagnostic)
        }
        SASL::step $ctx $challenge
        set result [smtp::talk $token 300 \
                        [base64::encode -maxlen 0 [SASL::response $ctx]]]
        array set response $result
    }

    if {$response(code) == 235} {
        set state(auth) 1
        return $result
    } else {
        return -code 7 $result
    }
}

# ::smtp::finalize --
#
#	Deletes an SMTP token by closing the connection to the SMTP server,
#       cleanup up various state.
#
# Arguments:
#       token   SMTP token that has an open connection to the SMTP server.
#       args    Optional arguments, where the only useful option is -close,
#               whose valid values are the following:
#               orderly     Normal successful completion.  Close connection and
#                           clear state variables.
#               abort       A connection exists to the SMTP server, but it's in
#                           a weird state and needs to be reset before being
#                           closed.  Then clear state variables.
#               drop        No connection exists, so we just need to clean up
#                           state variables.
#
# Results:
#	SMTP connection is closed and state variables are cleared.  If there's
#       an error while attempting to close the connection to the SMTP server,
#       throw an exception with the error code and error message.

proc ::smtp::finalize {token args} {
    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options [list -close orderly]
    array set options $args

    switch -- $options(-close) {
        orderly {
            set code [catch { talk $token 120 QUIT } result]
        }

        abort {
            set code [catch {
                talk $token 0 RSET
                talk $token 0 QUIT
            } result]
        }

        drop {
            set code 0
            set result ""
        }

        default {
            error "unknown value for -close $options(-close)"
        }
    }
    set ecode $errorCode
    set einfo $errorInfo

    catch { close $state(sd) }

    if {$state(afterID) != ""} {
        catch { after cancel $state(afterID) }
    }

    foreach name [array names state] {
        unset state($name)
    }
    # FRINK: nocheck
    unset $token

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::smtp::winit --
#
#	Send originator info to SMTP server.  This occurs after HELO/EHLO
#       command has completed successfully (in ::smtp::initialize).  This function
#       is called by ::smtp::sendmessageaux.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#       part        MIME token for the message to be sent. May be used for
#                   handling some SMTP extensions.
#       originator  The e-mail address of the entity sending the message,
#                   usually the From clause.
#       mode        SMTP command specifying the mode of communication.  Default
#                   value is MAIL.
#
# Results:
#	Originator info is sent and SMTP server's response is returned.  If an
#       error occurs, throw an exception.

proc ::smtp::winit {token part originator {mode MAIL}} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} {
        error "unknown origination mode $mode"
    }

    set from "$mode FROM:<$originator>"

    # RFC 1870 -  SMTP Service Extension for Message Size Declaration
    if {[info exists state(esmtp)]
        && [lsearch -glob $state(esmtp) "SIZE*"] != -1} {
        catch {
            set size [string length [mime::buildmessage $part]]
            append from " SIZE=$size"
        }
    }

    array set response [set result [talk $token 600 $from]]

    if {$response(code) == 250} {
        set state(addrs) 0
        return $result
    } else {
        return -code 7 $result
    }
}

# ::smtp::waddr --
#
#	Send recipient info to SMTP server.  This occurs after originator info
#       is sent (in ::smtp::winit).  This function is called by
#       ::smtp::sendmessageaux.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#       recipient   One of the recipients to whom the message should be
#                   delivered.
#
# Results:
#	Recipient info is sent and SMTP server's response is returned.  If an
#       error occurs, throw an exception.

proc ::smtp::waddr {token recipient} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set result [talk $token 3600 "RCPT TO:<$recipient>"]
    array set response $result

    switch -- $response(code) {
        250 - 251 {
            incr state(addrs)
            return $result
        }

        default {
            return -code 7 $result
        }
    }
}

# ::smtp::wtext --
#
#	Send message to SMTP server.  This occurs after recipient info
#       is sent (in ::smtp::winit).  This function is called by
#       ::smtp::sendmessageaux.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	part        The MIME object containing the message to send.
#
# Results:
#	MIME message is sent and SMTP server's response is returned.  If an
#       error occurs, throw an exception.

proc ::smtp::wtext {token part} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state
    array set options $state(options)

    set result [talk $token 300 DATA]
    array set response $result
    if {$response(code) != 354} {
        return -code 7 $result
    }

    if {[catch { wtextaux $token $part } result]} {
        catch { puts -nonewline $state(sd) "\r\n.\r\n" ; flush $state(sd) }
        return -code 7 [list code 400 diagnostic $result]
    }

    set secs $options(-maxsecs)

    set result [talk $token $secs .]
    array set response $result
    switch -- $response(code) {
        250 - 251 {
            return $result
        }

        default {
            return -code 7 $result
        }
    }
}

# ::smtp::wtextaux --
#
#	Helper function that coordinates writing the MIME message to the socket.
#       In particular, it stacks the channel leading to the SMTP server, sets up
#       some file events, sends the message, unstacks the channel, resets the
#       file events to their original state, and returns.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	part        The MIME object containing the message to send.
#
# Results:
#	Message is sent.  If anything goes wrong, throw an exception.

proc ::smtp::wtextaux {token part} {
    global errorCode errorInfo

    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    # Workaround a bug with stacking channels on top of TLS.
    # FRINK: nocheck
    set trf [set [namespace current]::trf]
    if {[info exists state(tls)] && $state(tls)} {
        set trf 0
    }

    flush $state(sd)
    fileevent $state(sd) readable ""
    if {$trf} {
        transform -attach $state(sd) -command [list ::smtp::wdata $token]
    } else {
        set state(size) 1
    }
    fileevent $state(sd) readable [list ::smtp::readable $token]

    # If trf is not available, get the contents of the message,
    # replace all '.'s that start their own line with '..'s, and
    # then write the mime body out to the filehandle. Do not forget to
    # deal with bare LF's here too (SF bug #499242).

    if {$trf} {
        set code [catch { ::mime::copymessage $part $state(sd) } result]
    } else {
        set code [catch { ::mime::buildmessage $part } result]
        if {$code == 0} {
	    # Detect and transform bare LF's into proper CR/LF
	    # sequences.

	    while {[regsub -all -- {([^\r])\n} $result "\\1\r\n" result]} {}
            regsub -all -- {\n\.}      $result "\n.."   result

            # Fix for bug #827436 - mail data must end with CRLF.CRLF
            if {[string compare [string index $result end] "\n"] != 0} {
                append result "\r\n"
            }
            set state(size) [string length $result]
            puts -nonewline $state(sd) $result
            set result ""
	}
    }
    set ecode $errorCode
    set einfo $errorInfo

    flush $state(sd)
    fileevent $state(sd) readable ""
    if {$trf} {
        unstack $state(sd)
    }
    fileevent $state(sd) readable [list ::smtp::readable $token]

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

# ::smtp::wdata --
#
#	This is the custom transform using Trf to do CR/LF translation.  If Trf
#       is not installed on the system, then this function never gets called and
#       no translation occurs.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#       command     Trf provided command for manipulating socket data.
#	buffer      Data to be converted.
#
# Results:
#	buffer is translated, and state(size) is set.  If Trf is not installed
#       on the system, the transform proc defined at the top of this file sets
#       state(size) to 1.  state(size) is used later to determine a timeout
#       value.

proc ::smtp::wdata {token command buffer} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    switch -- $command {
        create/write -
        clear/write  -
        delete/write {
            set state(crP) 0
            set state(nlP) 1
            set state(size) 0
        }

        write {
            set result ""

            foreach c [split $buffer ""] {
                switch -- $c {
                    "." {
                        if {$state(nlP)} {
                            append result .
                        }
                        set state(crP) 0
                        set state(nlP) 0
                    }

                    "\r" {
                        set state(crP) 1
                        set state(nlP) 0
                    }

                    "\n" {
                        if {!$state(crP)} {
                            append result "\r"
                        }
                        set state(crP) 0
                        set state(nlP) 1
                    }

                    default {
                        set state(crP) 0
                        set state(nlP) 0
                    }
                }

                append result $c
            }

            incr state(size) [string length $result]
            return $result
        }

        flush/write {
            set result ""

            if {!$state(nlP)} {
                if {!$state(crP)} {
                    append result "\r"
                }
                append result "\n"
            }

            incr state(size) [string length $result]
            return $result
        }

	create/read -
        delete/read {
	    # Bugfix for [#539952]
        }

	query/ratio {
	    # Indicator for unseekable channel,
	    # for versions of Trf which ask for
	    # this.
	    return {0 0}
	}
	query/maxRead {
	    # No limits on reading bytes from the channel below, for
	    # versions of Trf which ask for this information
	    return -1
	}

	default {
	    # Silently pass all unknown commands.
	    #error "Unknown command \"$command\""
	}
    }

    return ""
}

# ::smtp::talk --
#
#	Sends an SMTP command to a server
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	secs        Timeout after which command should be aborted.
#       command     Command to send to SMTP server.
#
# Results:
#	command is sent and response is returned.  If anything goes wrong, throw
#       an exception.

proc ::smtp::talk {token secs command} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options $state(options)

    if {$options(-debug)} {
        puts stderr "--> $command (wait upto $secs seconds)"
        flush stderr
    }

    if {[catch { puts -nonewline $state(sd) "$command\r\n"
                 flush $state(sd) } result]} {
        return [list code 400 diagnostic $result]
    }

    if {$secs == 0} {
        return ""
    }

    return [hear $token $secs]
}

# ::smtp::hear --
#
#	Listens for SMTP server's response to some prior command.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#	secs        Timeout after which we should stop waiting for a response.
#
# Results:
#	Response is returned.

proc ::smtp::hear {token secs} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options $state(options)

    array set response [list args ""]

    set firstP 1
    while {1} {
        if {$secs >= 0} {
	    ## SF [ 836442 ] timeout with large data
	    ## correction, aotto 031105 -
	    if {$secs > 600} {set secs 600}
            set state(afterID) [after [expr {$secs*1000}] \
                                      [list ::smtp::timer $token]]
        }

        if {!$state(readable)} {
            vwait ${token}(readable)
        }

        # Wait until socket is readable.
        if {$state(readable) !=  -1} {
            catch { after cancel $state(afterID) }
            set state(afterID) ""
        }

        if {$state(readable) < 0} {
            array set response [list code 400 diagnostic $state(error)]
            break
        }
        set state(readable) 0

        if {$options(-debug)} {
            puts stderr "<-- $state(line)"
            flush stderr
        }

        if {[string length $state(line)] < 3} {
            array set response \
                  [list code 500 \
                        diagnostic "response too short: $state(line)"]
            break
        }

        if {$firstP} {
            set firstP 0

            if {[scan [string range $state(line) 0 2] %d response(code)] \
                    != 1} {
                array set response \
                      [list code 500 \
                            diagnostic "unrecognizable code: $state(line)"]
                break
            }

            set response(diagnostic) \
                [string trim [string range $state(line) 4 end]]
        } else {
            lappend response(args) \
                    [string trim [string range $state(line) 4 end]]
        }

        # When status message line ends in -, it means the message is complete.

        if {[string compare [string index $state(line) 3] -]} {
            break
        }
    }

    return [array get response]
}

# ::smtp::readable --
#
#	Reads a line of data from SMTP server when the socket is readable.  This
#       is the callback of "fileevent readable".
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#
# Results:
#	state(line) contains the line of data and state(readable) is reset.
#       state(readable) gets the following values:
#       -3  if there's a premature eof,
#       -2  if reading from socket fails.
#       1   if reading from socket was successful

proc ::smtp::readable {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    if {[catch { array set options $state(options) }]} {
        return
    }

    set state(line) ""
    if {[catch { gets $state(sd) state(line) } result]} {
        set state(readable) -2
        set state(error) $result
    } elseif {$result == -1} {
        if {[eof $state(sd)]} {
            set state(readable) -3
            set state(error) "premature end-of-file from server"
        }
    } else {
        # If the line ends in \r, remove the \r.
        if {![string compare [string index $state(line) end] "\r"]} {
            set state(line) [string range $state(line) 0 end-1]
        }
        set state(readable) 1
    }

    if {$state(readable) < 0} {
        if {$options(-debug)} {
            puts stderr "    ... $state(error) ..."
            flush stderr
        }

        catch { fileevent $state(sd) readable "" }
    }
}

# ::smtp::timer --
#
#	Handles timeout condition on any communication with the SMTP server.
#
# Arguments:
#       token       SMTP token that has an open connection to the SMTP server.
#
# Results:
#	Sets state(readable) to -1 and state(error) to an error message.

proc ::smtp::timer {token} {
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    array set options $state(options)

    set state(afterID) ""
    set state(readable) -1
    set state(error) "read from server timed out"

    if {$options(-debug)} {
        puts stderr "    ... $state(error) ..."
        flush stderr
    }
}

# ::smtp::boolean --
#
#	Helper function for unifying boolean values to 1 and 0.
#
# Arguments:
#       value   Some kind of value that represents true or false (i.e. 0, 1,
#               false, true, no, yes, off, on).
#
# Results:
#	Return 1 if the value is true, 0 if false.  If the input value is not
#       one of the above, throw an exception.

proc ::smtp::boolean {value} {
    switch -- [string tolower $value] {
        0 - false - no - off {
            return 0
        }

        1 - true - yes - on {
            return 1
        }

        default {
            error "unknown boolean value: $value"
        }
    }
}

# -------------------------------------------------------------------------

package provide smtp 1.4.5

# -------------------------------------------------------------------------
# Local variables:
# indent-tabs-mode: nil
# End:

# ncgi.tcl
#
# Basic support for CGI programs
#
# Copyright (c) 2000 Ajuba Solutions.
# Copyright (c) 2012 Richard Hipp, Andreas Kupries
# Copyright (c) 2013-2014 Andreas Kupries
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.


# Please note that Don Libes' has a "cgi.tcl" that implements version 1.0
# of the cgi package.  That implementation provides a bunch of cgi_ procedures
# (it doesn't use the ::cgi:: namespace) and has a wealth of procedures for
# generating HTML.  In contract, the package provided here is primarly
# concerned with processing input to CGI programs.  I have tried to mirror his
# API's where possible.  So, ncgi::input is equivalent to cgi_input, and so
# on.  There are also some different APIs for accessing values (ncgi::list,
# ncgi::parse and ncgi::value come to mind)

# Note, I use the term "query data" to refer to the data that is passed in
# to a CGI program.  Typically this comes from a Form in an HTML browser.
# The query data is composed of names and values, and the names can be
# repeated.  The names and values are encoded, and this module takes care
# of decoding them.

# We use newer string routines
package require Tcl 8.4
package require fileutil ; # Required by importFile.
package require uri
package provide ncgi 1.4.3

namespace eval ::ncgi {

    # "query" holds the raw query (i.e., form) data
    # This is treated as a cache, too, so you can call ncgi::query more than
    # once

    variable query

    # This is the content-type which affects how the query is parsed

    variable contenttype

    # value is an array of parsed query data.  Each array element is a list
    # of values, and the array index is the form element name.
    # See the differences among ncgi::parse, ncgi::input, ncgi::value
    # and ncgi::valuelist for the various approaches to handling these values.

    variable value

    # This lists the names that appear in the query data

    variable varlist

    # This holds the URL coresponding to the current request
    # This does not include the server name.

    variable urlStub

    # This flags compatibility with Don Libes cgi.tcl when dealing with
    # form values that appear more than once.  This bit gets flipped when
    # you use the ncgi::input procedure to parse inputs.

    variable listRestrict 0

    # This is the set of cookies that are pending for output

    variable cookieOutput

    # Support for x-www-urlencoded character mapping
    # The spec says: "non-alphanumeric characters are replaced by '%HH'"

    variable i
    variable c
    variable map

    for {set i 1} {$i <= 256} {incr i} {
	set c [format %c $i]
	if {![string match \[a-zA-Z0-9\] $c]} {
	    set map($c) %[format %.2X $i]
	}
    }

    # These are handled specially
    array set map {
	" " +   \n %0D%0A
    }

    # Map of transient files

    variable  _tmpfiles
    array set _tmpfiles {}

    # I don't like importing, but this makes everything show up in
    # pkgIndex.tcl

    namespace export reset urlStub query type decode encode
    namespace export nvlist parse input value valueList names
    namespace export setValue setValueList setDefaultValue setDefaultValueList
    namespace export empty import importAll importFile redirect header
    namespace export parseMimeValue multipart cookie setCookie
}

# ::ncgi::reset
#
#	This resets the state of the CGI input processor.  This is primarily
#	used for tests, although it is also designed so that TclHttpd can
#	call this with the current query data
#	so the ncgi package can be shared among TclHttpd and CGI scripts.
#
#	DO NOT CALL this in a standard cgi environment if you have not
#	yet processed the query data, which will not be used after a
#	call to ncgi::reset is made.  Instead, just call ncgi::parse
#
# Arguments:
#	newquery	The query data to be used instead of external CGI.
#	newtype		The raw content type.
#
# Side Effects:
#	Resets the cached query data and wipes any environment variables
#	associated with CGI inputs (like QUERY_STRING)

proc ::ncgi::reset {args} {
    global env
    variable _tmpfiles
    variable query
    variable contenttype
    variable cookieOutput

    # array unset _tmpfiles -- Not a Tcl 8.2 idiom
    unset _tmpfiles ; array set _tmpfiles {}

    set cookieOutput {}
    if {[llength $args] == 0} {

	# We use and test args here so we can detect the
	# difference between empty query data and a full reset.

	if {[info exists query]} {
	    unset query
	}
	if {[info exists contenttype]} {
	    unset contenttype
	}
    } else {
	set query [lindex $args 0]
	set contenttype [lindex $args 1]
    }
}

# ::ncgi::urlStub
#
#	Set or return the URL associated with the current page.
#	This is for use by TclHttpd to override the default value
#	that otherwise comes from the CGI environment
#
# Arguments:
#	url	(option) The url of the page, not counting the server name.
#		If not specified, the current urlStub is returned
#
# Side Effects:
#	May affects future calls to ncgi::urlStub

proc ::ncgi::urlStub {{url {}}} {
    global   env
    variable urlStub
    if {[string length $url]} {
	set urlStub $url
	return ""
    } elseif {[info exists urlStub]} {
	return $urlStub
    } elseif {[info exists env(SCRIPT_NAME)]} {
	set urlStub $env(SCRIPT_NAME)
	return $urlStub
    } else {
	return ""
    }
}

# ::ncgi::query
#
#	This reads the query data from the appropriate location, which depends
#	on if it is a POST or GET request.
#
# Arguments:
#	none
#
# Results:
#	The raw query data.

proc ::ncgi::query {} {
    global env
    variable query

    if {[info exists query]} {
	# This ensures you can call ncgi::query more than once,
	# and that you can use it with ncgi::reset
	return $query
    }

    set query ""
    if {[info exists env(REQUEST_METHOD)]} {
	if {$env(REQUEST_METHOD) == "GET"} {
	    if {[info exists env(QUERY_STRING)]} {
		set query $env(QUERY_STRING)
	    }
	} elseif {$env(REQUEST_METHOD) == "POST"} {
	    if {[info exists env(CONTENT_LENGTH)] &&
		    [string length $env(CONTENT_LENGTH)] != 0} {
 		## added by Steve Cassidy to try to fix binary file upload
 		fconfigure stdin -translation binary -encoding binary
		set query [read stdin $env(CONTENT_LENGTH)]
	    }
	}
    }
    return $query
}

# ::ncgi::type
#
#	This returns the content type of the query data.
#
# Arguments:
#	none
#
# Results:
#	The content type of the query data.

proc ::ncgi::type {} {
    global env
    variable contenttype

    if {![info exists contenttype]} {
	if {[info exists env(CONTENT_TYPE)]} {
	    set contenttype $env(CONTENT_TYPE)
	} else {
	    return ""
	}
    }
    return $contenttype
}

# ::ncgi::decode
#
#	This decodes data in www-url-encoded format.
#
# Arguments:
#	An encoded value
#
# Results:
#	The decoded value

if {[package vsatisfies [package present Tcl] 8.6]} {
    # 8.6+, use 'binary decode hex'
    proc ::ncgi::DecodeHex {hex} {
	return [binary decode hex $hex]
    }
} else {
    # 8.4+. More complex way of handling the hex conversion.
    proc ::ncgi::DecodeHex {hex} {
	return [binary format H* $hex]
    }
}

proc ::ncgi::decode {str} {
    # rewrite "+" back to space
    # protect \ from quoting another '\'
    set str [string map [list + { } "\\" "\\\\" \[ \\\[ \] \\\]] $str]

    # prepare to process all %-escapes
    regsub -all -- {%([Ee][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \
	$str {[encoding convertfrom utf-8 [DecodeHex \1\2\3]]} str
    regsub -all -- {%([CDcd][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])}                     \
	$str {[encoding convertfrom utf-8 [DecodeHex \1\2]]} str
    regsub -all -- {%([0-7][A-Fa-f0-9])} $str {\\u00\1} str

    # process \u unicode mapped chars
    return [subst -novar $str]
}

# ::ncgi::encode
#
#	This encodes data in www-url-encoded format.
#
# Arguments:
#	A string
#
# Results:
#	The encoded value

proc ::ncgi::encode {string} {
    variable map

    # 1 leave alphanumerics characters alone
    # 2 Convert every other character to an array lookup
    # 3 Escape constructs that are "special" to the tcl parser
    # 4 "subst" the result, doing all the array substitutions

    regsub -all -- \[^a-zA-Z0-9\] $string {$map(&)} string
    # This quotes cases like $map([) or $map($) => $map(\[) ...
    regsub -all -- {[][{})\\]\)} $string {\\&} string
    return [subst -nocommand $string]
}

# ::ncgi::names
#
#	This parses the query data and returns a list of the names found therein.
#
# 	Note: If you use ncgi::setValue or ncgi::setDefaultValue, this
#	names procedure doesn't see the effect of that.
#
# Arguments:
#	none
#
# Results:
#	A list of names

proc ::ncgi::names {} {
    array set names {}
    foreach {name val} [nvlist] {
        if {![string equal $name "anonymous"]} {
            set names($name) 1
        }
    }
    return [array names names]
}

# ::ncgi::nvlist
#
#	This parses the query data and returns it as a name, value list
#
# 	Note: If you use ncgi::setValue or ncgi::setDefaultValue, this
#	nvlist procedure doesn't see the effect of that.
#
# Arguments:
#	none
#
# Results:
#	An alternating list of names and values

proc ::ncgi::nvlist {} {
    set query [query]
    set type  [type]
    switch -glob -- $type {
	"" -
	text/xml* -
	application/x-www-form-urlencoded* -
	application/x-www-urlencoded* {
	    set result {}

	    # Any whitespace at the beginning or end of urlencoded data is not
	    # considered to be part of that data, so we trim it off.  One special
	    # case in which post data is preceded by a \n occurs when posting
	    # with HTTPS in Netscape.

	    foreach {x} [split [string trim $query] &] {
		# Turns out you might not get an = sign,
		# especially with <isindex> forms.

		set pos [string first = $x]
		set len [string length $x]

		if { $pos>=0 } {
		    if { $pos == 0 } { # if the = is at the beginning ...
		        if { $len>1 } {
                            # ... and there is something to the right ...
		            set varname anonymous
		            set val [string range $x 1 end]
		        } else {
                            # ... otherwise, all we have is an =
		            set varname anonymous
		            set val ""
		        }
		    } elseif { $pos==[expr {$len-1}] } {
                        # if the = is at the end ...
		        set varname [string range $x 0 [expr {$pos-1}]]
			set val ""
		    } else {
		        set varname [string range $x 0 [expr {$pos-1}]]
		        set val [string range $x [expr {$pos+1}] end]
		    }
		} else { # no = was found ...
		    set varname anonymous
		    set val $x
		}
		lappend result [decode $varname] [decode $val]
	    }
	    return $result
	}
	multipart/* {
	    return [multipart $type $query]
	}
	default {
	    return -code error "Unknown Content-Type: $type"
	}
    }
}

# ::ncgi::parse
#
#	The parses the query data and stores it into an array for later retrieval.
#	You should use the ncgi::value or ncgi::valueList procedures to get those
#	values, or you are allowed to access the ncgi::value array directly.
#
#	Note - all values have a level of list structure associated with them
#	to allow for multiple values for a given form element (e.g., a checkbox)
#
# Arguments:
#	none
#
# Results:
#	A list of names of the query values

proc ::ncgi::parse {} {
    variable value
    variable listRestrict 0
    variable varlist {}
    if {[info exists value]} {
	unset value
    }
    foreach {name val} [nvlist] {
	if {![info exists value($name)]} {
	    lappend varlist $name
	}
	lappend value($name) $val
    }
    return $varlist
}

# ::ncgi::input
#
#	Like ncgi::parse, but with Don Libes cgi.tcl semantics.
#	Form elements must have a trailing "List" in their name to be
#	listified, otherwise this raises errors if an element appears twice.
#
# Arguments:
#	fakeinput	See ncgi::reset
#	fakecookie	The raw cookie string to use when testing.
#
# Results:
#	The list of element names in the form

proc ::ncgi::input {{fakeinput {}} {fakecookie {}}} {
    variable value
    variable varlist {}
    variable listRestrict 1
    if {[info exists value]} {
	unset value
    }
    if {[string length $fakeinput]} {
	ncgi::reset $fakeinput
    }
    foreach {name val} [nvlist] {
	set exists [info exists value($name)]
	if {!$exists} {
	    lappend varlist $name
	}
	if {[string match "*List" $name]} {
	    # Accumulate a list of values for this name
	    lappend value($name) $val
	} elseif {$exists} {
	    error "Multiple definitions of $name encountered in input.\
	    If you're trying to do this intentionally (such as with select),\
	    the variable must have a \"List\" suffix."
	} else {
	    # Capture value with no list structure
	    set value($name) $val
	}
    }
    return $varlist
}

# ::ncgi::value
#
#	Return the value of a named query element, or the empty string if
#	it was not not specified.  This only returns the first value of
#	associated with the name.  If you want them all (like all values
#	of a checkbox), use ncgi::valueList
#
# Arguments:
#	key	The name of the query element
#	default	The value to return if the value is not present
#
# Results:
#	The first value of the named element, or the default

proc ::ncgi::value {key {default {}}} {
    variable value
    variable listRestrict
    variable contenttype
    if {[info exists value($key)]} {
	if {$listRestrict} {

	    # ::ncgi::input was called, and it already figured out if the
	    # user wants list structure or not.

	    set val $value($key)
	} else {

	    # Undo the level of list structure done by ncgi::parse

	    set val [lindex $value($key) 0]
	}
	if {[string match multipart/* [type]]} {

	    # Drop the meta-data information associated with each part

	    set val [lindex $val 1]
	}
	return $val
    } else {
	return $default
    }
}

# ::ncgi::valueList
#
#	Return all the values of a named query element as a list, or
#	the empty list if it was not not specified.  This always returns
#	lists - if you do not want the extra level of listification, use
#	ncgi::value instead.
#
# Arguments:
#	key	The name of the query element
#
# Results:
#	The first value of the named element, or ""

proc ::ncgi::valueList {key {default {}}} {
    variable value
    if {[info exists value($key)]} {
	return $value($key)
    } else {
	return $default
    }
}

# ::ncgi::setValue
#
#	Jam a new value into the CGI environment.  This is handy for preliminary
#	processing that does data validation and cleanup.
#
# Arguments:
#	key	The name of the query element
#	value	This is a single value, and this procedure wraps it up in a list
#		for compatibility with the ncgi::value array usage.  If you
#		want a list of values, use ngci::setValueList
#
#
# Side Effects:
#	Alters the ncgi::value and possibly the ncgi::valueList variables

proc ::ncgi::setValue {key value} {
    variable listRestrict
    if {$listRestrict} {
	ncgi::setValueList $key $value
    } else {
	ncgi::setValueList $key [list $value]
    }
}

# ::ncgi::setValueList
#
#	Jam a list of new values into the CGI environment.
#
# Arguments:
#	key		The name of the query element
#	valuelist	This is a list of values, e.g., for checkbox or multiple
#			selections sets.
#
# Side Effects:
#	Alters the ncgi::value and possibly the ncgi::valueList variables

proc ::ncgi::setValueList {key valuelist} {
    variable value
    variable varlist
    if {![info exists value($key)]} {
	lappend varlist $key
    }

    # This if statement is a workaround for another hack in
    # ::ncgi::value that treats multipart form data
    # differently.
    if {[string match multipart/* [type]]} {
	set value($key) [list [list {} [join $valuelist]]]
    } else {
	set value($key) $valuelist
    }
    return ""
}

# ::ncgi::setDefaultValue
#
#	Set a new value into the CGI environment if there is not already one there.
#
# Arguments:
#	key	The name of the query element
#	value	This is a single value, and this procedure wraps it up in a list
#		for compatibility with the ncgi::value array usage.
#
#
# Side Effects:
#	Alters the ncgi::value and possibly the ncgi::valueList variables

proc ::ncgi::setDefaultValue {key value} {
    ncgi::setDefaultValueList $key [list $value]
}

# ::ncgi::setDefaultValueList
#
#	Jam a list of new values into the CGI environment if the CGI value
#	is not already defined.
#
# Arguments:
#	key		The name of the query element
#	valuelist	This is a list of values, e.g., for checkbox or multiple
#			selections sets.
#
# Side Effects:
#	Alters the ncgi::value and possibly the ncgi::valueList variables

proc ::ncgi::setDefaultValueList {key valuelist} {
    variable value
    if {![info exists value($key)]} {
	ncgi::setValueList $key $valuelist
	return ""
    } else {
	return ""
    }
}

# ::ncgi::exists --
#
#	Return false if the CGI variable doesn't exist.
#
# Arguments:
#	name	Name of the CGI variable
#
# Results:
#	0 if the variable doesn't exist

proc ::ncgi::exists {var} {
    variable value
    return [info exists value($var)]
}

# ::ncgi::empty --
#
#	Return true if the CGI variable doesn't exist or is an empty string
#
# Arguments:
#	name	Name of the CGI variable
#
# Results:
#	1 if the variable doesn't exist or has the empty value

proc ::ncgi::empty {name} {
    return [expr {[string length [string trim [value $name]]] == 0}]
}

# ::ncgi::import
#
#	Map a CGI input into a Tcl variable.  This creates a Tcl variable in
#	the callers scope that has the value of the CGI input.  An alternate
#	name for the Tcl variable can be specified.
#
# Arguments:
#	cginame		The name of the form element
#	tclname		If present, an alternate name for the Tcl variable,
#			otherwise it is the same as the form element name

proc ::ncgi::import {cginame {tclname {}}} {
    if {[string length $tclname]} {
	upvar 1 $tclname var
    } else {
	upvar 1 $cginame var
    }
    set var [value $cginame]
}

# ::ncgi::importAll
#
#	Map a CGI input into a Tcl variable.  This creates a Tcl variable in
#	the callers scope for every CGI value, or just for those named values.
#
# Arguments:
#	args	A list of form element names.  If this is empty,
#		then all form value are imported.

proc ::ncgi::importAll {args} {
    variable varlist
    if {[llength $args] == 0} {
	set args $varlist
    }
    foreach cginame $args {
	upvar 1 $cginame var
	set var [value $cginame]
    }
}

# ::ncgi::redirect
#
#	Generate a redirect by returning a header that has a Location: field.
#	If the URL is not absolute, this automatically qualifies it to
#	the current server
#
# Arguments:
#	url		The url to which to redirect
#
# Side Effects:
#	Outputs a redirect header

proc ::ncgi::redirect {url} {
    global env

    if {![regexp -- {^[^:]+://} $url]} {

	# The url is relative (no protocol/server spec in it), so
	# here we create a canonical URL.

	# request_uri	The current URL used when dealing with relative URLs.
	# proto		http or https
	# server 	The server, which we are careful to match with the
	#		current one in base Basic Authentication is being used.
	# port		This is set if it is not the default port.

	if {[info exists env(REQUEST_URI)]} {
	    # Not all servers have the leading protocol spec
	    #regsub -- {^https?://[^/]*/} $env(REQUEST_URI) / request_uri
	    array set u [uri::split $env(REQUEST_URI)]
	    set request_uri /$u(path)
	    unset u
	} elseif {[info exists env(SCRIPT_NAME)]} {
	    set request_uri $env(SCRIPT_NAME)
	} else {
	    set request_uri /
	}

	set port ""
	if {[info exists env(HTTPS)] && $env(HTTPS) == "on"} {
	    set proto https
	    if {$env(SERVER_PORT) != 443} {
		set port :$env(SERVER_PORT)
	    }
	} else {
	    set proto http
	    if {$env(SERVER_PORT) != 80} {
		set port :$env(SERVER_PORT)
	    }
	}
	# Pick the server from REQUEST_URI so it matches the current
	# URL.  Otherwise use SERVER_NAME.  These could be different, e.g.,
	# "pop.scriptics.com" vs. "pop"

	if {[info exists env(REQUEST_URI)]} {
	    # Not all servers have the leading protocol spec
	    if {![regexp -- {^https?://([^/:]*)} $env(REQUEST_URI) x server]} {
		set server $env(SERVER_NAME)
	    }
	} else {
	    set server $env(SERVER_NAME)
	}
	if {[string match /* $url]} {
	    set url $proto://$server$port$url
	} else {
	    regexp -- {^(.*/)[^/]*$} $request_uri match dirname
	    set url $proto://$server$port$dirname$url
	}
    }
    ncgi::header text/html Location $url
    puts "Please go to <a href=\"$url\">$url</a>"
}

# ncgi:header
#
#	Output the Content-Type header.
#
# Arguments:
#	type	The MIME content type
#	args	Additional name, value pairs to specifiy output headers
#
# Side Effects:
#	Outputs a normal header

proc ::ncgi::header {{type text/html} args} {
    variable cookieOutput
    puts "Content-Type: $type"
    foreach {n v} $args {
	puts "$n: $v"
    }
    if {[info exists cookieOutput]} {
	foreach line $cookieOutput {
	    puts "Set-Cookie: $line"
	}
    }
    puts ""
    flush stdout
}

# ::ncgi::parseMimeValue
#
#	Parse a MIME header value, which has the form
#	value; param=value; param2="value2"; param3='value3'
#
# Arguments:
#	value	The mime header value.  This does not include the mime
#		header field name, but everything after it.
#
# Results:
#	A two-element list, the first is the primary value,
#	the second is in turn a name-value list corresponding to the
#	parameters.  Given the above example, the return value is
#	{
#		value
#		{param value param2 value param3 value3}
#	}

proc ::ncgi::parseMimeValue {value} {
    set parts [split $value \;]
    set results [list [string trim [lindex $parts 0]]]
    set paramList [list]
    foreach sub [lrange $parts 1 end] {
	if {[regexp -- {([^=]+)=(.+)} $sub match key val]} {
            set key [string trim [string tolower $key]]
            set val [string trim $val]
            # Allow single as well as double quotes
            if {[regexp -- {^["']} $val quote]} { ;# need a " for balance
                if {[regexp -- ^${quote}(\[^$quote\]*)$quote $val x val2]} {
                    # Trim quotes and any extra crap after close quote
                    set val $val2
                }
            }
            lappend paramList $key $val
	}
    }
    if {[llength $paramList]} {
	lappend results $paramList
    }
    return $results
}

# ::ncgi::multipart
#
#	This parses multipart form data.
#	Based on work by Steve Ball for TclHttpd, but re-written to use
#	string first with an offset to iterate through the data instead
#	of using a regsub/subst combo.
#
# Arguments:
#	type	The Content-Type, because we need boundary options
#	query	The raw multipart query data
#
# Results:
#	An alternating list of names and values
#	In this case, the value is a two element list:
#		headers, which in turn is a list names and values
#		content, which is the main value of the element
#	The header name/value pairs come primarily from the MIME headers
#	like Content-Type that appear in each part.  However, the
#	Content-Disposition header is handled specially.  It has several
#	parameters like "name" and "filename" that are important, so they
#	are promoted to to the same level as Content-Type.  Otherwise,
#	if a header like Content-Type has parameters, they appear as a list
#	after the primary value of the header.  For example, if the
#	part has these two headers:
#
#	Content-Disposition: form-data; name="Foo"; filename="/a/b/C.txt"
#	Content-Type: text/html; charset="iso-8859-1"; mumble='extra'
#
#	Then the header list will have this structure:
#	{
#		content-disposition form-data
#		name Foo
#		filename /a/b/C.txt
#		content-type {text/html {charset iso-8859-1 mumble extra}}
#	}
#	Note that the header names are mapped to all lowercase.  You can
#	use "array set" on the header list to easily find things like the
#	filename or content-type.  You should always use [lindex $value 0]
#	to account for values that have parameters, like the content-type
#	example above.  Finally, not that if the value has a second element,
#	which are the parameters, you can "array set" that as well.
#
proc ::ncgi::multipart {type query} {

    set parsedType [parseMimeValue $type]
    if {![string match multipart/* [lindex $parsedType 0]]} {
	return -code error "Not a multipart Content-Type: [lindex $parsedType 0]"
    }
    array set options [lindex $parsedType 1]
    if {![info exists options(boundary)]} {
	return -code error "No boundary given for multipart document"
    }
    set boundary $options(boundary)

    # The query data is typically read in binary mode, which preserves
    # the \r\n sequence from a Windows-based browser.
    # Also, binary data may contain \r\n sequences.

    if {[string match "*$boundary\r\n*" $query]} {
        set lineDelim "\r\n"
	#	puts "DELIM"
    } else {
        set lineDelim "\n"
	#	puts "NO"
    }

    # Iterate over the boundary string and chop into parts

    set len [string length $query]
    # [string length $lineDelim]+2 is for "$lineDelim--"
    set blen [expr {[string length $lineDelim] + 2 + \
            [string length $boundary]}]
    set first 1
    set results [list]
    set offset 0

    # Ensuring the query data starts
    # with a newline makes the string first test simpler
    if {[string first $lineDelim $query 0]!=0} {
        set query $lineDelim$query
    }
    while {[set offset [string first $lineDelim--$boundary $query $offset]] \
            >= 0} {
	if {!$first} {
	    lappend results $formName [list $headers \
		[string range $query $off2 [expr {$offset -1}]]]
	} else {
	    set first 0
	}
	incr offset $blen

	# Check for the ending boundary, which is signaled by --$boundary--

	if {[string equal "--" \
		[string range $query $offset [expr {$offset + 1}]]]} {
	    break
	}

	# Split headers out from content
	# The headers become a nested list structure:
	#	{header-name {
	#		value {
	#			paramname paramvalue ... }
	#		}
	#	}

        set off2 [string first "$lineDelim$lineDelim" $query $offset]
	set headers [list]
	set formName ""
        foreach line [split [string range $query $offset $off2] $lineDelim] {
	    if {[regexp -- {([^:	 ]+):(.*)$} $line x hdrname value]} {
		set hdrname [string tolower $hdrname]
		set valueList [parseMimeValue $value]
		if {[string equal $hdrname "content-disposition"]} {

		    # Promote Conent-Disposition parameters up to headers,
		    # and look for the "name" that identifies the form element

		    lappend headers $hdrname [lindex $valueList 0]
		    foreach {n v} [lindex $valueList 1] {
			lappend headers $n $v
			if {[string equal $n "name"]} {
			    set formName $v
			}
		    }
		} else {
		    lappend headers $hdrname $valueList
		}
	    }
	}

	if {$off2 > 0} {
            # +[string length "$lineDelim$lineDelim"] for the
            # $lineDelim$lineDelim
            incr off2 [string length "$lineDelim$lineDelim"]
	    set offset $off2
	} else {
	    break
	}
    }
    return $results
}

# ::ncgi::importFile --
#
#   get information about a file upload field
#
# Arguments:
#   cmd         one of '-server' '-client' '-type' '-data'
#   var         cgi variable name for the file field
#   filename    filename to write to for -server
# Results:
#   -server returns the name of the file on the server: side effect
#      is that the file gets stored on the server and the
#      script is responsible for deleting/moving the file
#   -client returns the name of the file sent from the client
#   -type   returns the mime type of the file
#   -data   returns the contents of the file

proc ::ncgi::importFile {cmd var {filename {}}} {

    set vlist [valueList $var]

    array set fileinfo [lindex [lindex $vlist 0] 0]
    set contents [lindex [lindex $vlist 0] 1]

    switch -exact -- $cmd {
	-server {
	    ## take care not to write it out more than once
	    variable _tmpfiles
	    if {![info exists _tmpfiles($var)]} {
		if {$filename != {}} {
		    ## use supplied filename
		    set _tmpfiles($var) $filename
		} else {
		    ## create a tmp file
		    set _tmpfiles($var) [::fileutil::tempfile ncgi]
		}

		# write out the data only if it's not been done already
		if {[catch {open $_tmpfiles($var) w} h]} {
		    error "Can't open temporary file in ncgi::importFile ($h)"
		}

		fconfigure $h -translation binary -encoding binary
		puts -nonewline $h $contents
		close $h
	    }
	    return $_tmpfiles($var)
	}
	-client {
	    if {![info exists fileinfo(filename)]} {return {}}
	    return $fileinfo(filename)
	}
	-type {
	    if {![info exists fileinfo(content-type)]} {return {}}
	    return $fileinfo(content-type)
	}
	-data {
	    return $contents
	}
	default {
	    error "Unknown subcommand to ncgi::import_file: $cmd"
	}
    }
}


# ::ncgi::cookie
#
#	Return a *list* of cookie values, if present, else ""
#	It is possible for multiple cookies with the same key
#	to be present, so we return a list.
#
# Arguments:
#	cookie	The name of the cookie (the key)
#
# Results:
#	A list of values for the cookie

proc ::ncgi::cookie {cookie} {
    global env
    set result ""
    if {[info exists env(HTTP_COOKIE)]} {
	foreach pair [split $env(HTTP_COOKIE) \;] {
	    foreach {key value} [split [string trim $pair] =] { break ;# lassign }
	    if {[string compare $cookie $key] == 0} {
		lappend result $value
	    }
	}
    }
    return $result
}

# ::ncgi::setCookie
#
#	Set a return cookie.  You must call this before you call
#	ncgi::header or ncgi::redirect
#
# Arguments:
#	args	Name value pairs, where the names are:
#		-name	Cookie name
#		-value	Cookie value
#		-path	Path restriction
#		-domain	domain restriction
#		-expires	Time restriction
#
# Side Effects:
#	Formats and stores the Set-Cookie header for the reply.

proc ::ncgi::setCookie {args} {
    variable cookieOutput
    array set opt $args
    set line "$opt(-name)=$opt(-value) ;"
    foreach extra {path domain} {
	if {[info exists opt(-$extra)]} {
	    append line " $extra=$opt(-$extra) ;"
	}
    }
    if {[info exists opt(-expires)]} {
	switch -glob -- $opt(-expires) {
	    *GMT {
		set expires $opt(-expires)
	    }
	    default {
		set expires [clock format [clock scan $opt(-expires)] \
			-format "%A, %d-%b-%Y %H:%M:%S GMT" -gmt 1]
	    }
	}
	append line " expires=$expires ;"
    }
    if {[info exists opt(-secure)]} {
	append line " secure "
    }
    lappend cookieOutput $line
}