Tcl Library Source Code

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

    package forget $pname
    catch {namespace delete $nsname}

    set unique [info cmdcount]
    set cresvar [namespace current]::${unique}_cres
    set coptsvar [namespace current]::${unique}_copts
    if {[uplevel 1 [list ::catch [list useLocalFile $fname] $cresvar $coptsvar]]} {

	puts "    Aborting the tests found in \"[file tail [info script]]\""



    } else {
	puts "$::tcllib::testutils::tag [list $pname] [package present $pname]"
    }
    return -options [set $coptsvar][unset $coptsvar] [set $cresvar][unset $cresvar] 
}

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 *
    set unique [info cmdcount]
    set cresvar [namespace current]::${unique}_cres
    set coptsvar [namespace current]::${unique}_copts
    uplevel 1 [list ::catch $script $cresvar $coptsvar]



    return -options [set $coptsvar][unset $coptsvar] [set $cresvar][


	unset $cresvar]
}

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

[def [const zone]]

-720 .. 720 (minutes east of GMT)

[list_end]


[call [arg message] [cmd .destroy] [opt "[option -subordinates] [const all] | [const dynamic] | [const none]"]]

Destroys the message corresponding to [arg token] and
returns the empty string.


[para]

[option -subordinates] specifies which messages comprising the body should also
be destroyed.  The default value of [const dynamic] indicates all component
messages that were created while parsing a message.  [const all] indicates
all component messages. [const none] indicates that no component messages should be
destroyed.


[call [cmd ::mime::header] [cmd serialize] [arg value] [arg parameters]]

Returns the the serialization of a header.

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

package require {mime qp}
package require namespacex
package require tcl::chan::cat
package require tcl::chan::memchan
package require tcl::chan::string
package require {chan base}
package require {chan getslimit}
package require sha256

#
#     file: input file
#     fd: cached file-descriptor, typically for root
#     root: token for top-level part, for (distant) subordinates
#     count: length in octets of (encoded) content
#
#     parts: list of bodies (tokens)




namespace eval ::mime {

    variable mime
    array set mime {uid 0}


    # RFC 822 lexemes
    variable addrtokenL
    lappend addrtokenL \; , < > : . ( ) @ \" \[ ] \\
    variable addrlexemeL {
        LX_SEMICOLON LX_COMMA

        ksc5601 KSC5601
        ksc5601 korean
        shiftjis MS_Kanji
        utf-8 UTF8
    }

    namespace export {*}{
	.destroy .new body cookie datetime field_decode header mapencoding qp
	parseaddress property reversemapencoding serialize setheader uniqueID
	word_decode word_encode
    }
}


proc ::mime::addchan {token chan} {
    variable channels
    upvar 0 $token state

    upvar 1 inputs inputs
    if {[incr inputs] > 1} {
	error [list {more than one input source provided}]
    }
}


proc ::mime::body_decoded _ {
    set token [$_ token]
    upvar 0 $token state
    upvar 0 state(bodychandecoded) bodychandecoded
    $_ parsepart
    if {[info exists state(parts)]} {
	error [list {not a leaf part} $token]
    }
    if {$state(canonicalP)} { 
	$state(fd) seek 0 
	return $state(fd)
    } else {
	if {![info exists bodychandecoded]} {
	    set bodychandecoded [::tcllib::chan::base .new [
		info cmdcount]_bodydecoded [file tempfile]]
	    $bodychandecoded configure -translation binary
	    $state(bodychan) seek 0
	    $state(bodychan) copy [$bodychandecoded $ chan]
	    $bodychandecoded seek 0
	    $state(bodychan) seek 0
	    setencoding $token $bodychandecoded
	    setcharset $_ $bodychandecoded
	}
	$bodychandecoded seek 0
	return $bodychandecoded
    }
}

proc ::mime::body_raw _ {
    set token [$_ token]
    upvar 0 $token state
    $_ parsepart
    if {[info exists state(parts)]} {
	error [list {not a leaf part} $token]
    }
    if {$state(canonicalP)} { 
	$state(fd) seek 0
	return $state(fd)
    } else {
	$state(bodychan) seek 0 
	return $state(bodychan)
    }
}


namespace eval ::mime::body {
    namespace ensemble create -parameters token
    namespace export *
    namespacex import [namespace parent] body_decoded decoded body_raw raw
}


proc ::mime::contenttype _ {
    set token [$_ token]
    upvar 0 $token state
    try {
	$_ header get content-type
    } on error {cres copts} {
	# rfc 2045 5.2
	try {
	    if {header::exists $token MIME-Version} {
		    return text/plain
	    } else {
		switch $state(spec) {
		    cgi - http {
			return {text/html {charset UTF-8}}
		    }
		    mime {
			# do not specify US-ASCII here as it is the default
			return text/plain
		    }
		    
		}
	    }
	} on error {} {
	    return application/octet-stream
	}
    }
}


# ::mime::cookie_set
#
#	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 ::mime::cookie_set {_ args} {
    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 "
    }
    $_ header set Set-Cookie $line {} 
}


# ::mime::datetime --
#
#    Fortunately the clock command in the Tcl 8.x core does all the heavy
#    lifting for us (except for timezone calculations).
#
#    mime::datetime takes a string containing an 822-style date-time

#       token
#            The MIME token to parse.
#
# Results:
#       Returns the encoding of the message (the null string, base64,
#       or quoted-printable).

proc ::mime::encoding _ {
    set token [$_ token]
    # FRINK: nocheck
    upvar 0 $token state
    upvar 0 state(fd) chan state(params) params

    if {[info exists state(encoding)]} {
	return $state(encoding)
    }
    lassign [$_ contenttype] content

    switch -glob $content {
        audio/*
            -
        image/*
            -
        video/* {

	    return 0
	}
    }
    return 1
}


proc ::mime::contentid _ {
    set token [$_ token]
    upvar 0 $token state
    upvar 0 state(parts) parts
    $_ parsepart
    if {[info exists parts]} {
	foreach part $parts {
	    upvar 0 $part childpart
	    set created 0
	    if {![header::exists $part message-id]} {
		set created 1
		header::setinternal $part Message-ID [messageid $part]
	    }

	    # use message-id here, not content-id, to account for header info
	    # in the parts
	    append ids [$part header get message-id] 

	    if {$created} {
		if {!$childpart(addmessageid)} {
		    header::unset $part message-id
		}
	    }
	}
	set id [::sha2::sha256 -hex $ids]
    } else {
	set chan [$_ body decoded]
	set config [$chan configure]
	if {[dict exists $config -chan]} {
	    dict unset config -chan
	}
	try {
	    $chan seek 0
	    set id [::sha2::sha256 -hex -channel [$chan configure -chan]]

	    }
	}
	unset state(fd)
    }
}


# ::mime::.destroy --
#
#   mime::.destroy 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::.destroy {token args} {
    # FRINK: nocheck
    upvar 0 $token state
    array set options [list -subordinates dynamic]
    array set options $args

    set ensemble $state(ensemble)

    switch $options(-subordinates) {
        all {
            #TODO: this code path is untested
            if {[info exists state(parts)]} {
                foreach part $state(parts) {
		    $part .destroy
                }
            }
        }

        dynamic {
	    foreach part $state(dynamic) {
		$part .destroy
	    }
        }

        none {
        }

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

    if {[info exists state(bodychandecoded)]} {
	rename $state(bodychandecoded) {}
    }

    foreach name [array names state] {
        unset state($name)
    }

    if {[namespace which $ensemble] ne {}} {
	rename $ensemble {}
	# FRINK: nocheck
    }
    unset $token
}


proc ::mime::messageid _ {
    set token [$_ token]
    upvar 0 $token state
    #set unique [uniqueID]
    if {![header::exists $token content-id] && $state(addcontentid)} {
	header::setinternal $token Content-ID [contentid $_]
    }
    set sha [::sha2::SHA256Init]
    foreach {key val} [lsort -stride 2 [$_ header get]] {
	lassign $val value params
	::sha2::SHA256Update $sha $key$value
	foreach {pkey pval} $params {
	    ::sha2::SHA256Update $sha $pkey$pval
	}
    }
    set hash [::sha2::SHA256Final $sha]

#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the size in bytes of the MIME token.

proc ::mime::getsize _ {
    set token [$_ token]
    # FRINK: nocheck
    upvar 0 $token state
    upvar 0 state(bodychan) bodychan state(fd) inputchan 

    $_ parsepart

    if {[info exists state(parts)]} {
	set size 0
	foreach part $state(parts) {
	    incr size [getsize $part]
	}
    } else {

    #if {$state(encoding) eq {base64}} {
    #    set size [expr {($size * 3 + 2) / 4}]
    #}
    return $size
}


proc ::mime::getTransferEncoding _ {
    set token [$_ token]
    upvar 0 $token state
    # not the global [encoding]
    set encoding [encoding $_]
    # See also issues [#477088] and [#539952]
    switch $encoding {
	base64 - quoted-printable  - 7bit - 8bit - binary - {} {
	}
	default {
	    error [list {Can't handle content encoding} $encoding]
	}
    }
    return $encoding
}


namespace eval ::mime::header {









    variable tchar
    # hypen is first for inclusion in brackets
    variable tchar_re {-!#$%&'*+.^`|~0-9A-Za-z}
    variable token_re "^(\[$tchar_re]*)\\s*(?:;|$)?"
    variable notattchar_re "\[^[string map {* {} ' {} % {}} $tchar_re]]"

    # RFC 2045 lexemes

#    If $key is provided, returns only the value and paramemters of the last
#    maching header, without regard for case. 
#
#    If -names is specified, a list of all header names is returned.
#

proc ::mime::header::get {_ {key {}}} {
    set token [$_ token]
    # FRINK: nocheck
    upvar 0 $token state
    parse $token

    set contentid $state(contentid)
    set contentidlower $state(contentidlower)
    set header $state(header)
    set headerlower $state(headerlower)
    set headerinternal $state(headerinternal)
    set headerinternallower $state(headerinternallower)
    set messageid $state(messageid) 
    set messageidlower $state(messageidlower)
    switch $key {
	{} {
	    set result [list {*}$messageid {*}$contentid {*}$headerinternal \
		{*}$header]
	    if {![dict exists $headerlower content-transfer-encoding]
		&& !$state(canonicalP)} {
		set tencoding [getTransferEncoding $_]
		if {$tencoding ne {}} {
		    lappend result Content-Transfer-Encoding [list $tencoding {}]
		}
	    }
	    return $result
	}

		    }
		    return [dict get $contentidlower content-id]
		}
		content-transfer-encoding {
		    if {[dict exists $headerinternallower $lower]} {
			return [dict get $headerinternallower $lower]
		    } elseif {!$state(canonicalP)} {
			return [list [getTransferEncoding $_] {}]
		    } else {
			error [list {no such header} $key]
		    }
		}
		message-id {
		    if {![dict size $messageidlower]} {
			setinternal $token Message-ID [[namespace parent]::messageid $_]

		    }
		    return [dict get $messageidlower message-id]
		}
		mime-version {
		    return [list $state(version) {}]
		}
		default {

#    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.
#       ?params?   A dictionary of parameters for the header.
#       ?args?       An optional argument of the form:
#                  ?-mode "write" | "append" | "delete"?
#
# Results:
#       Returns previous value associated with the specified key.

proc ::mime::header::set_ {token key value args} {
    variable internal

    try {
	set_ {*}$args
    } finally {
	set internal 0
    }
}








# ::mime::.new --
#
#    the public interface for initializeaux

proc ::mime::.new args {
    variable mime
    if {[llength $args] % 2} {
	set args [lassign $args[set args {}] name]
    } elseif {[llength $args]} {
	error [list {wrong # args}]
    } else {
	set name {}
    }
    set mimeid [incr mime(uid)]
    set token [namespace current]::$mimeid
    if {$name eq {}} {
	set name $token
    } elseif {![string match ::* $name]} {
	set name [uplevel 1 {namespace current}]::$name
    }

    set cookiecmd [namespace current]::${mimeid}_cookie
    namespace ensemble create -command $cookiecmd -map [list \
	delete [list cookie_delete $name] \
	set [list cookie_set $name]
    ]

    set headercmd [namespace current]::${mimeid}_header
    namespace ensemble create -command $headercmd -map [list \
	get [list header::get $name] \
	exists [list header::exists $token] \
	parse [list header::parse $token] \
	set [list header::set_ $token] \
	serialize header::serialize \
	setinternal [list header::setinternal $token]
    ]

    namespace ensemble create -command $name -map [list \
	.destroy [list .destroy $token] \
	body [list body $name] \
	contenttype [list contenttype $name] \
	cookie [list $cookiecmd] \
	datetime [list datetime $token] \
	field_decode [list field_decode $token] \
	header [list $headercmd] \
	mapencoding [list mapencoding $token] \
	qp [list qp $token] \
	parseaddress [list parseaddress $token] \
	parsepart [list parsepart $name] \
	property [list property $name] \
	reversemapencoding [list reversemapencoding $token] \
	serialize [list serialize $name] \
	setheader [list setheader $token] \
	token [list ::lindex $token]  \
	uniqueID [list uniqueID $token] \
	word_decode [list word_decode $token] \
	word_encode [list word_encode $token]
    ]

    trace add command $name delete [list apply [list {
	token cookiecmd headercmd old new op} {
	::mime::.destroy $token
	rename $cookiecmd {}
	rename $headercmd {}
    }] $token $cookiecmd $headercmd]

    # FRINK: nocheck
    upvar 0 $token state
    set state(ensemble) $name

    if {[catch {uplevel 1 [
	list mime::initializeaux $name {*}$args]} result eopts]} {
        catch {mime::.destroy $token -subordinates dynamic}
        return -options $eopts $result
    }
    return $name
}

# ::mime::initializeaux --
#
#    Creates a MIME part and returns the MIME token for that part.
#
# Arguments:
#    args   Args can be any one of the following:
#                  ?-canonical type/subtype
#                  ?-params    {?key value? ...}
#                  ?-encoding value?
#                  ?-headers   {?key value? ...}
#                  ?-spec   ?mime | cgi | http? 
#                  (-chan 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,
#       -chan, or -parts option.
#
#       -header

#       contained in -chan option is parsed,
#       dynamically generating subordinates as appropriate.
#
# Results:
#    An initialized mime token.


proc ::mime::initializeaux {_ args} {
    set token [$_ token]
    variable channels
    # FRINK: nocheck
    upvar 0 $token state
    upvar 0 state(canonicalP) canonicalP state(params) params \
	state(relax) relax

    set ipnuts 0

    set params {}

    set state(addcontentid) 1
    set state(addmessageid) 1
    set state(addmimeversion) 1

    # contains the decoded message body 
    set state(bodychan) {}
    set state(bodydecoded) 0
    set state(bodyparsed) 0
    set state(dynamic) {}
    set canonicalP 0

    set state(closechan) 1
    set state(contentid) {}
    set state(contentidlower) {}
    set state(encoding) {}
    set state(encodingdone) 0
    set state(eof) 0
    set state(header) {}

            -root {
                # the following are internal options
                set state(root) $value
            }

	    -spec {
		switch $value {
		    cgi - http {
			set state(addcontentid) 0
			set state(addmimeversion) 0
			set state(addmessageid) 0
			set state(spec) http
		    }
		    mime {
			set state(addcontentid) 1

    }

    if {$canonicalP} {
	if {![info exists type]} {
	    set type multipart/mixed
	}

	header::setinternal $token Content-Type $type $params

	if {[info exists headers]} {
	    foreach {name hvalue} $headers {
		set lname [string tolower $name]
		if {$lname eq {content-type}} {
		    error [list {use -canonical instead of -headers} $hkey $name]
		}
		if {$lname eq {content-transfer-encoding}} {
		    error [list {use -encoding instead of -headers} $hkey $name]
		}
		if {$lname in {content-md5 mime-version}} {
		    error [list {don't go there...}]
		}
		header::setinternal $token $name $hvalue
	    }
	}

	lassign [$_ header get content-type] content dummy

	if {[info exists state(parts)]} {
	    switch -glob $content {
		text/*
		    -
		image/*
		    -

# 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 _ {
    set token [$_ token]
    upvar 0 $token state
    if {$state(canonicalP) || $state(bodyparsed)} {
	return
    }
    set state(bodyparsed) 1
    parsepartaux $_
}


proc ::mime::parsepartaux _ {
    set token [$_ token]
    # FRINK: nocheck
    upvar 0 $token state
    upvar 0 state(bodychan) bodychan state(eof) eof \
	state(fd) fd state(size) size state(usemem) usemem state(relax) relax

    header::parse $token

    # although rfc 2045 5.2 defines a default treatment for content without a
    # type, don't automatically add an explicit content-type field

    #if {![header::exists $token content-type]} {
    #    # rfc 2045 5.2
    #    header::setinternal $token Content-Type text/plain [
    #        dict create charset us-ascii]
    #}

    lassign [$_ contenttype] content params

    if {$usemem} {
	set bodychan [tcllib::chan::base .new [info cmdcount]_bodychan [
	    ::tcl::chan::memchan]]
    } else {
	set bodychan [tcllib::chan::base .new [info cmdcount]_bodychan]
	tcllib::chan::getslimit $bodychan

		    # Covered by by test case mime-3.7, using  "badmail1.txt".

		    set state(sawclosing) 1

		    $bodychan puts $line
		    $bodychan seek 0




		    set child [.new {} -chan $bodychan \
			-root $state(root) -boundary $boundary -usemem $usemem]
		    $child parsepart
		    
		    lappend state(parts) $child
		    lappend state(dynamic) $child
		    $child header setinternal Content-Type application/octet-stream
		    break
	    } elseif {[llength $state(parts)] || [string first --$boundary $line] == 0} {
		    # either just saw the first boundary or saw a boundary between parts

		    # do not brace this expression 
		    if $iseof {
			# either saw the closing boundary or reached the end of the file
			break
		    } elseif {[string first --$boundary-- $line] >= 0} {
			set state(sawclosing) 1
			break
		    } else {
			#mimegets returned 0 because it found a border



			set child [.new {} -chan $fd \


			    -root $state(root) -boundary $boundary -usemem $usemem]
			$child parsepart
			lappend state(parts) $child
			lappend state(dynamic) $child
			upvar 0 $child childstate
			set state(sawclosing) $childstate(sawclosing)
			if {$childstate(eof)} break
		    }
	    } else {
		# Accumulate data in case the terminating boundary occurs starting
		# boundary was found, so that a part can be generated from data

	    set size [$bodychan tell]
	}
	$bodychan seek 0

        if {[string match message/* $content]} {
            # FRINK: nocheck
	    setencoding $token $bodychan
	    setcharset $_ $bodychan


	    set child [.new {} -chan $bodychan -usemem $usemem]

            lappend state(parts) $child
	    lappend state(dynamic) $child
	    $child parsepart
        } else {
	    # this is undtrusted data, so keep the getslimit enabled on the
	    # assumption that no one else wants to get hit by a long-line
	    # attack either.
	    #$bodychan configure -getslimit -1
	}
    }

#       property   One of 'content', 'encoding', 'params', 'parts', and
#                  'size'. Defaults to returning a dictionary of
#                  properties.
#
# Results:
#       Returns the properties of a MIME part

proc ::mime::property {_ {property {}}} {
    set token [$_ token]
    # FRINK: nocheck
    upvar 0 $token state
    $_ parsepart

    lassign [$_ contenttype] content params

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

            return [array get properties]
        }

                error [list not a multipart message]
            }

            return $state(parts)
        }

        size {
            return [getsize $_]
        }

        default {
            error [list {unknown property} $property]
        }
    }
}

#       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::serialize {_ args} {
    set level 0
    set chan {} 
    dict for {arg val} $args {
	switch $arg {
	    -chan {
		if {$val eq {}} {
		    error [list {chan must not be the empty string}]
		}
		set chan [uplevel 1 [list ::namespace which $val]]
	    }
	    -level {
		set level [expr {$val + 0}]
	    }
	    default {
		error [list {unknown option} $arg]
	    }
	}
    }

    if {$chan eq {}} {
	set token [$_ token]
	upvar 0 $token state
	set code [catch {serialize_value $_ $level} result copts]
	return -options $copts $result
    } else {
	return [serialize_chan $_ $chan $level]
    }
}


proc ::mime::serialize_chan {_ channel level} {
    set token [$_ token]
    # FRINK: nocheck
    upvar 0 $token state
    upvar 0 state(bodychan) bodychan
    $_ parsepart

    set result {}
    if {!$level && $state(addmimeversion)} {
	$channel puts [header::serialize MIME-Version $state(version) {}]
    }
    contentid $_
    if {![header::exists $token content-id] && $state(addcontentid)} {
	header::setinternal $token Content-ID [contentid $_]
    }
    if {![header::exists $token message-id] && $state(addmessageid)} {
	header::setinternal $token Message-ID [messageid $_]
    }

    foreach {name value} [$_ header get] {
	$channel puts [header::serialize $name {*}$value]
    }

    set converter {}
    set encoding {}
    if {![info exists state(parts)]} {
        if {$state(canonicalP)} {
	    set encoding [getTransferEncoding $_]
            if {$encoding ne {}} {
                $channel puts "Content-Transfer-Encoding: $encoding"
            }
        }
    }

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

    if {[info exists state(parts)]} {
	lassign [$_ contenttype] content params
	set boundary [dict get $params boundary]

	switch -glob $content {
	    message/* {
		$channel puts {}
		foreach part $state(parts) {
		    serialize_chan $part $channel 1
		    break
		}
	    }

	    default {
		# Note RFC 2046: See serialize_value for details.
		#

		#   1213527, and patch 1254934 for the problems when
		#   both file/string branches added CRLF after the
		#   body parts.


		foreach part $state(parts) {
		    $channel puts \n--$boundary
		    serialize_chan $part $channel 1
		}
		$channel puts \n--$boundary--
	    }
	}
    } else {
	$channel puts {}
	if {$state(canonicalP)} {

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


proc ::mime::serialize_value {_ level} {
    set chan [::tcllib::chan::base .new [info cmdcount]_serialize_value [
	tcl::chan::memchan]]
    $chan configure -translation crlf
    serialize_chan $_ $chan $level
    $chan seek 0
    $chan configure -translation binary
    set res [$chan read]
    $chan close
    return $res
}

		error [list {Can't handle content encoding} $state(encoding)]
	    }
	}
    }
    return $transforms
}

proc ::mime::setcharset {_ chan} {
    set token [$_ token]
    upvar 0 $token state
    lassign [$_ contenttype] content params
    if {[dict exists $params charset]} {
	set mcharset [dict get $params charset]
    } else {
	switch $state(spec) {
	    cgi - http {
		set mcharset UTF-8
	    }
	    mime - default {
		# mime
		set mcharset US-ASCII
	    }
	}

    useLocal mime.tcl mime
}

package require {chan base}

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

namespace import mime::datetime mime::field_decode mime::mapencoding \
    mime::.new mime::parseaddress mime::qp mime::reversemapencoding \
    mime::word_decode mime::word_encode

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


proc channamescmp names {
    expr {[llength $names] == [llength [chan names]]}
}


proc cleanly script {
    set ns [info cmdcount]
    namespace eval $ns {
	namespace path [namespace parent]
    }
    catch {namespace eval $ns $script} cres copts
    foreach name [info vars ${ns}::*] {
	set val [set $name]
	if {[namespace which $val] ne {} && [string match ::mime* $val]} {
	    rename $val {}
	}
    }
    namespace delete $ns
    return -options $copts $cres
}


proc setup1 {} {
    uplevel 1 {
	set channames [chan names]
    }
}


proc with.chan {name args} {
    set body [lindex $args end]
    set args [lrange $args 0 end-1]
    set chan chan_[info cmdcount]
    ::tcllib::chan::base .new $chan [open $name]
    uplevel 1 [list set tok [.new {} {*}$args -chan $chan]]
    try {
	uplevel 1 $body
    } finally {
	rename $chan {}
    }
}


proc with.file {name args} {
    set body [lindex $args end]
    set args [lrange $args 0 end-1]
    uplevel 1 [list set tok [.new {} {*}$args -file $name]]
    uplevel 1 $body
}


proc main {} {
variable encoded
variable name
variable n

set message1 {MIME-Version: 1.0
Content-Type: Text/plain

I'm the message.}

test mime-1.1 {.new with no args} {cleanly {
    catch .new res
    subst $res
}} {{specify exactly one of} {-chan -file -parts -string}}


test mime-2.1 {Generate a MIME message} {cleanly {

    set tok [.new {} -canonical Text/plain -string {jack and jill}]
    set msg [$tok serialize]
}} "MIME-Version: 1.0\r
Message-ID: <ac7319c5a872e80af7fe7fb7efa5fd7ac7356ec74eb4410d23287b6cf7fa0129@|>\r
Content-ID: <8e84af0326e6170dfb2720eeb49b23337250b571c563247605c9ec6910772d2c@|>\r
Content-Type: text/plain\r
\r
jack and jill"

test mime-2.1.1 {Generate a MIME message} {cleanly {
    setup1
    with.chan [makeFile {jack and jill} input.txt] -canonical Text/plain {
	set msg [[$tok body raw] read]
	$tok .destroy

	# The generated message is predictable except for the Content-ID
	lappend res $msg
	lappend res [channamescmp $channames]
	return $res
    }
}} [list "jack and jill\n" 1]


test mime-2.2 {Generate a multi-part MIME message} {cleanly {
    set tok1 [.new {} -canonical Text/plain -string {jack and jill}]
    set tok2 [.new {} -canonical Text/plain -string james]
    set bigTok [.new {} -canonical Multipart/MyType \
	    -params [list MyParam foo boundary bndry] \
	    -headers [list Content-Description {Test Multipart}] \
	    -parts [list $tok1 $tok2]]
    $bigTok serialize
}} "MIME-Version: 1.0\r
Message-ID: <0b1ce38bc23a7af000d136b6227d7e47af437c850c83145d8ae807bb4ab4d748@|>\r
Content-ID: <b534a48db81537371fd048c0fc6da3047924c773b8f1b1691df58d032ed717c1@|>\r
Content-Type: multipart/mytype\r
	; myparam=foo\r
	; boundary=bndry\r
Content-Description: Test Multipart\r

\r
james\r
--bndry--\r
"


test mime-2.3 {Generate a multi-part MIME message} {cleanly {
    set tok1 [.new {} -canonical Text/plain -string {jack and jill}]
    set tok2 [.new {} -canonical Text/plain -string james]
    set bigTok [.new {} \
	    -params [list MyParam foo boundary bndry] \
	    -headers [list Content-Description {Test Multipart}] \
	    -parts [list $tok1 $tok2]]
    $bigTok serialize
}} "MIME-Version: 1.0\r
Message-ID: <6fd7e9b06fe3961dbc67d3bcc058451c3674403801ed18714d11aa200aed02a2@|>\r
Content-ID: <b534a48db81537371fd048c0fc6da3047924c773b8f1b1691df58d032ed717c1@|>\r
Content-Type: multipart/mixed\r
	; myparam=foo\r
	; boundary=bndry\r
Content-Description: Test Multipart\r

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

I'm the message.}
    set tok [.new {} -string $msg]
    [$tok body raw] read
}} {I'm the message.}


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

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

part3
--bar--
}

    set tok [.new {} -string $msg]
    set partToks [$tok property parts]

    set res {} 
    foreach childTok $partToks {
	lappend res [[$childTok body raw] read]
    }
    set res
}} [list part1 part2 part3]


test mime-3.3 {Try to parse a totally invalid message} {cleanly {
	set token [.new {} -string blah]
    catch {$token header get} err0
    set err0
}} {{improper line in header} blah}


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

msg1}

    set tok [.new {} -string $msg1]
    catch {[$tok body raw] read} err1
    catch {$tok serialize} err1a
    list $err1 $err1a
}} "msg1 {MIME-Version: 2.0\r
Message-ID: <d956986793d51d614044c01a7e7650665330a4a170d071aff1de6dceda8c8b0d@|>\r
Content-ID: <289e5175e02c788c2d442cfe81d6be0533d8c13e253ef763fda45d37accfe4d4@|>\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} {cleanly {
    set msg2 {MIME-Version: 1.0
Content-Type: foobar
data without newline}

    .new mime1 -string $msg2
    catch {mime1 header get} err2
    set err2
}} {expecting type/subtype found foobar}


test mime-3.6 {Try to parse a MIME message with no MIME version and generate a new message from it} {cleanly {
    # No MIME version
    set msg3 {Content-Type: text/plain

foo}
    .new mime1 -string $msg3
    catch {[mime1 body raw] read} err3
    catch {mime1 serialize} err3a copts
    list $err3 $err3a
}} "foo {MIME-Version: 1.0\r
Message-ID: <fb8bfc091f5ff55264834b7ea21278fbcb7bf875b20ddeae2f5e4eb662de2129@|>\r
Content-ID: <2c26b46b68ffc68ff99b453c1d30413413422d706483bfa0f98a5e886266e7ae@|>\r
Content-Type: text/plain\r
\r
foo}"


foreach name {file chan} {
    test mime-3.7.$name {Test mime with a bad email [SF Bug 631314 ]} {cleanly {
	with.$name $tcltest::testsDirectory/badmail1.txt {
	    set res {}
	    lappend res [llength [$tok property parts]]
	    set ctok [lindex [$tok property parts] 0]
	    lappend res [dictsort [$tok property]]
	    lappend res [dictsort [$ctok property]]
	    $tok .destroy
	    string map [list $ctok CHILD] $res
	}
    }} {1 {content multipart/mixed encoding {} params {boundary ----------CSFNU9QKPGZL79} parts CHILD size 0} {content application/octet-stream encoding {} params {} size 0}}
}

foreach name {file chan} {

    test mime-3.8.1.$name {Test mime with another bad email [SF Bug 631314 ]} -body {cleanly {
	with.$name $tcltest::testsDirectory/badmail2.txt {
	    set ctok [lindex [$tok property parts] 0]
	}
    }} -returnCodes 1 -result {end-of-string encountered while parsing multipart/form-data}
}

foreach name {file chan} {

    test mime-3.8.2.$name {Test mime with another bad email [SF Bug 631314 ]} {cleanly {
	with.$name $tcltest::testsDirectory/badmail2.txt -relax finalboundary {
	    set res {}
	    set ctok [lindex [$tok property parts] 0]
	    lappend res [dictsort [$tok property]]
	    lappend res [dictsort [$ctok property]]
	    $tok .destroy
	    string map [list $ctok CHILD] $res
	}
    }} {{content multipart/related encoding {} params {boundary ----=_NextPart_000_0000_2CBA2CBA.150C56D2} parts CHILD size 879} {content text/html encoding base64 params {} size 879}}
}


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

Fran\xE7ois
}
    set tok [.new {} -string $msg]
    [$tok body decoded] read
}} {Fran\xE7ois
}


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

=A4=CF}
    set tok [.new {} -string $msg]
    [$tok body decoded] read
}} \u306F


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

A plain text message.}
    set tok [.new {} -string $msg]
    [$tok body decoded] read
}} {A plain text message.}


test mime-3.12 {Parse a MIME message with a charset encoded body in an unrecognised charset and use [body decoded] to attempt to get it back} {cleanly {
    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 [.new {} -string $msg]
    lappend res [$tok header get content-type]
    lappend res [[$tok body decoded] configure -encoding]
    catch {[$tok body decoded] read} errmsg
    lappend res $errmsg
}} {{text/plain {charset SCRIBBLE}} binary {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.} {cleanly {
    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\""
    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} {cleanly {
    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 [qp encode $str1]
    set dec [qp decode $enc]
    string equal $dec $str1
}} 1


test mime-4.3 {decode data that might come from an MUA} {cleanly {
    set enc "I'm the =22 message =\nwith some new lines=  \n but with some extra space, too.   "
    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.} {cleanly {
    set str1 "Test de caractères accentués : â î é ç et quelques contrôles \"\[|\]()\""
    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} {cleanly {
    set str1 [string repeat abc 40]
    qp encode $str1
}} "abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabca=
bcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc"


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


test mime-4.7 {Test qp::encode/decode in encoded_word mode} {cleanly {
    set enc [qp encode {jack and jill went up the hill} 1]
    qp decode $enc 1
}} {jack and jill went up the hill}


test mime-4.8 {Test qp::encode in encoded_word mode with equal signs} {cleanly {
    qp encode 1and1=2 1
}} 1and1=3D2

test mime-4.9 {Test qp::encode in encoded_word mode with tabs and spaces} {cleanly {
    qp encode "1 and 1 =\t2" 1
}} 1_and_1_=3D=092


test mime-4.10 {Test qp::encode in encoded_word mode with underscores} {cleanly {
    qp encode 2003_06_30 1
}} 2003=5F06=5F30


test mime-4.11 {Test qp::encode in encoded_word mode with underscores and spaces} {cleanly {
    qp encode {2003_06_30 is 30 June 2003} 1
}} 2003=5F06=5F30_is_30_June_2003


test mime-4.12 {Test qp::encode in encoded_word mode with question marks} {cleanly {
    qp encode {How long is a piece of string ?} 1
}} How_long_is_a_piece_of_string_=3F


test mime-4.13 {Test qp::encode in no_softbreak mode} {cleanly {
    qp encode {This is a very long string into which we do not want inserted softbreaks as we want one very long line returned even though that's probably not how we whould be doing it (see RFC2047) but we don't want to break backward compatibility} 0 1
}} {This is a very long string into which we do not want inserted softbreaks as we want one very long line returned even though that's probably not how we whould be doing it (see RFC2047) but we don't want to break backward compatibility}
 


test mime-5.1 {Test word_encode with quoted-printable method} {cleanly {
    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} {cleanly {
    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} {cleanly {
    set enc [word_encode iso8859-1 quoted-printable {Test de contrôle effectué}]
    word_decode $enc
}} {iso8859-1 quoted-printable {Test de contrôle effectué}}


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


test mime-5.5 {Test decode with lowercase quoted-printable method} {cleanly {
	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} {cleanly {
	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} {cleanly {
    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} {cleanly {
    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} {cleanly {
    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} {cleanly {
	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)} {cleanly {
    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} {cleanly {
	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} {cleanly {
	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} {cleanly {
	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} {cleanly {
	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} {cleanly {
    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} {cleanly {
    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} {cleanly {
    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} {cleanly {
    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} {cleanly {
    word_encode iso8859-1 base64 a
}} =?ISO-8859-1?B?YQ==?=


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


test mime-5.38 {Test word_encode with unknown charset} {cleanly {
    catch {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} {cleanly {
    catch {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} {cleanly {
    catch {word_encode iso8859-1 tea-leaf {tea-leaf is not a valid method}} errmsg
    set errmsg
}} {{unknown method} tea-leaf {must be one of} {base64 quoted-printable}}


test mime-5.41 {Test word_encode with maxlength to short for method quoted-printable} {cleanly {
    catch {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} {cleanly {
   catch {word_encode iso8859-1 quoted-printable _ -maxlength 20} errmsg
   set errmsg
}} =?ISO-8859-1?Q?=5F?=


test mime-5.43 {Test word_encode with maxlength to short for method quoted_printable and a character to be quoted} {cleanly {
   catch {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} {cleanly {
    catch {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} {cleanly {
    catch {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)} {cleanly {
    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)} {cleanly {
    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)} {cleanly {
    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)}

    {(ax b)}
    12 {a         b         c}
    {a         b         c}
    13 {} 
    {}
} {
    test mime-6.$n {Test field_decode (from RFC 2047, part 8)} {cleanly {
	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)" {cleanly {
	field_decode $encoded
    }} $expected ; # {}
}


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


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


foreach name {file chan} {
    test mime-9.0.$name {Test chunk handling of serialize and helpers} {cleanly {
	set in [makeFile [set data [string repeat [string repeat {123456789 } 10]\n 350]] input.txt]
	set mi [makeFile {} mime.txt]

	with.$name $in -canonical text/plain {
	    ::tcllib::chan::base .new chan1 [open $mi w]
	    chan1 configure -translation binary
	    $tok serialize -chan chan1 
	    chan1 close

	    with.$name $mi {
		set newdata [[$tok body raw] read]
		set res [string compare $data $newdata]

		removeFile input.txt
		removeFile mime.txt
		unset data newdata tok in mi
		set res
	    }

    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 {[datetime $date clock] - $epoch}]
	# Parse and re-format should get us the original.
	set parsed_test [datetime $date proper]
	list $stamp_test $parsed_test
    } [list $stamp $date]
}


test mime-11.0 {Bug 1825092} {cleanly {
    set in [makeFile {From [email protected]  Sat Oct 20 17:58:49 2007

Content-Type: application/octet-stream;
 name="a0036.dss"

BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAZ
--------------090305080603000703000106--
} mail_part]
    set token [.new {} -file $in]
    set allparts [$token property parts]
    set attachment [lindex $allparts 1]

    set out [makeFile {} mail_att]
    ::tcllib::chan::base .new chan1 [open $out w]
    chan1 configure -translation binary
    $attachment serialize -chan chan1 -level 1
    chan1 close

    set data [viewFile $out]
    file delete $in $out
    set data
}} {Message-ID: <f60c78370648168a30158b8cda876db2f875d1531e86e5594c5a108dcf5209db@|>
Content-ID: <93755e1312eacd488b6170673caa5e7a9a9445ce82ff11c934055bd1f907b229@|>
Content-Type: application/octet-stream
	; name=a0036.dss
Content-Disposition: attachment
	; filename=a0036.dss
Content-Transfer-Encoding: base64

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

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


test mime-12.0 {Bug 3483716} {cleanly {
    set token [.new {} -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 [$token property parts]
    set result [[lindex $parts end] header get Remote-MTA]
    return $result
}} {53.24.282.150 {}}

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


test mime-13.0 {cleanly {
    issue a16b1095974e071d
}} {
    set msg "MIME-Version: 1.0
Content-Type: text/plain\r
\r
so plain
"

    set tok [.new {} -string $msg]
    [$tok body raw] read 
} "so plain\n"

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

test mime-14.0 {cleanly {
	hostname argument to parseaddress
}} {
	set parsed [parseaddress hostname fakedomain.fake {Here <h>}] 
    list [llength $parsed] [lindex $parsed 0]
} [list 1 [list address [email protected] comment {} domain {} error {} \
	friendly Here group {} local h memberP 0 phrase Here \
	proper {Here <[email protected]>} route {}]]



test mime-14.1 {cleanly {
	special characters in local part
}} {
	set parsed [parseaddress hostname fakedomain.fake foo<>[email protected]]
    list [llength $parsed] [lindex $parsed 0]
} [list 1 [list address {} comment {} domain {} \
	error {expecting mailbox in local-part (found >)} friendly foo group {} \
	local {} memberP 0 phrase foo proper {foo <>} route {}]]

test mime-14.2 {cleanly {
	special characters in local part
}} {
	set parsed [parseaddress hostname fakedomain.fake {"foobar"@grill.com}]
    list [llength $parsed] [lindex $parsed 0]
} [list 1 [
    list address {"foobar"@grill.com} comment {} domain grill.com error {} \
    friendly foobar group {} local {"foobar"} memberP 0 phrase {} \
    proper {"foobar"@grill.com} route {}]]


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


test mime-15.0 {cleanly {
	a multipart/mixed message with an invalid body
}} {
    set msg "MIME-Version: 1.0
Content-Type: multipart/mixed; boundary=\"something\"\r
\r
so plain
"

    set tok [.new {} -string $msg]
    $tok header get
} [list Content-Type {multipart/mixed {boundary something}}]


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


test mime-16.0 {cleanly {
}} {
    set msg "MIME-Version: 1.0
Content-Type: text/plain\r
Content-Disposition: attachment
    ; param1=\"a parameter value\";  param2*1=\"another param\";
	param2*2=\"eter value\" \r
\r
so plain
"

    set tok [.new {} -string $msg]
    $tok header get
} [list Content-Type {text/plain {}} Content-Disposition [
    list attachment [list param1 {a parameter value} \
	param2 {another parameter value}]]]


set char [encoding convertfrom utf-8 \xE3\x81\xAF]
test mime-16.1 {cleanly {
}} {
    set res {}
    set mime [.new {} -canonical text/plain -string {dawg one}]
    $mime header set Content-Disposition attachment [list param1 $char]
    set msg [$mime serialize]
    lappend res $msg
    set mime2 [.new {} -string $msg]
    lappend res [$mime2 header get]
    return $res

} [list "MIME-Version: 1.0\r
Message-ID: <c7aa6d4b48aa9fcfe18d9c24adf71de96efbaaf2e261eb1de738ef45f453d1a4@|>\r
Content-ID: <086570e97284c5bc5145f32689a5342363b10b64963446293b83930fa8a9fa45@|>\r
Content-Type: text/plain\r
Content-Disposition: attachment\r
	; param1*0*=utf-8''%E3%81%AF\r
\r
dawg one" \
[list Content-ID {<086570e97284c5bc5145f32689a5342363b10b64963446293b83930fa8a9fa45@|> {}} Content-Type {text/plain {}} \
    Message-ID {<c7aa6d4b48aa9fcfe18d9c24adf71de96efbaaf2e261eb1de738ef45f453d1a4@|> {}} \
    Content-Disposition [list attachment [list param1 $char]]]

]


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

test mime-17.1 {header parsing} {cleanly {
    set mime [.new {} -string {Content-Type: text/html}]
    $mime header get Content-Type
}} {text/html {}}


test mime-17.2 {header parsing} {cleanly {
    set mime [.new {} -string {Content-Type: text/html; charset=iso-8859-1}]
    $mime header get Content-Type
}} {text/html {charset iso-8859-1}}


test mime-17.3 {header parsing} {
    set mime [.new {} -string {Content-Type: text/html; charset='iso-8859-1'}]
    $mime header get Content-Type
} {text/html {charset 'iso-8859-1'}}


test mime-17.4 {header parsing} {
    set mime [.new {} -string {Content-Type: text/html; charset="iso-8859-1"}]
    $mime header get Content-Type
} {text/html {charset iso-8859-1}}


test mime-17.5 {header parsing} -body {
    set mime [.new {} -string {Content-Type: text/html; charset="iso-8859-1"; ignored}]
    $mime header get Content-Type
} -returnCodes 1 -result {expecting = found end-of-input}


test mime-17.6 {header parsing} -body {
    set mime [.new {} -string {Content-Type: text/html; charset="iso-8859-1"morecrap}]
    $mime header get Content-Type
} -returnCodes 1 -result {expecting = found end-of-input}


test mime-17.7 {header parsing} {
    set mime [.new {} -string {Content-Type: test/test; foo="bar\"baz\""}]
    $mime header get Content-Type
} [list test/test [list foo bar"baz"]]


test mime-17.8 {header parsing} {
    set mime [.new {} -string {Content-Type: test/test; foo=""}]
    $mime header get Content-Type
} {test/test {foo {}}}


test mime-17.9 {
    header supplied by a component message, retrieved by lowercase name
} {
    set mime [.new {} -string {Content-Disposition: form-data; name="field2"}]
    $mime header get content-disposition 
} {form-data {name field2}}


test mime-17.10 {
    Content-Type is not automatically added to a subordinate
} {
    set mime [.new {} -string {Content-Disposition: form-data; name="field2"}]
    $mime header get content-disposition 
} {form-data {name field2}}


test mime-18.1 {
    non-seekable channel
} {
    set script [list puts -nonewline $message1]
    set chan [open |[list [info nameofexecutable] <<$script]]
    tcllib::chan::base .new chan1 $chan
    set mime [.new {} -spec http -chan chan1]
    $mime serialize
} "Content-Type: text/plain\r
\r
I'm the message."

test mime-19.1 {
    -http
} {
    set mime [.new {} -spec http -string {}]
    $mime serialize
} "\r
"




testsuiteCleanup

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


namespace eval ::mime::qp {
    namespace ensemble create
    namespace export decode encode
}

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

# smtp.tcl - SMTP client
#
# Copyright (c) 1999-2000 Marshall T. Rose
# Copyright (c) 2003-2006 Pat Thoyts
# Copyright (c) 2003-2018 Poor Yorick 
#
# 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 mime 1.7-

#             -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} {


    # 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

        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 {$part header get $dateL}])} {
        lappend lowerL $dateL
        lappend mixedL $dateM
        lappend header($dateL) [::mime::datetime -now proper]
    }

    if {([lsearch -exact $lowerL ${message-idL}] < 0) \
            && ([catch {$part header get ${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 [$part header get]

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

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

		                -maxsecs $maxsecs -usetls $tlsP \
                                -multiple $bccP -queue $queueP \
                                -servers $servers -ports $ports \
                                -tlspolicy $tlspolicy -tlsimport $tlsimport \
                                -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 code1 [catch {
	sendmessageaux $token $part $sender $vrecipients $aloP
    } cres1 copts1]
    lappend results $code1 $cres1 $copts1

    if {!$code1 && $bccP} {
	# Send the message to bcc recipients as a MIME attachment.


        set inner [::mime::.new {} -canonical message/rfc822 \
                                    -headers [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::.new {} \
	    -canonical multipart/digest \
	    -headers [list \
		From [list $originator {}] \
		Bcc 
		Date [::mime::datetime -now proper] \
		Subject $subject \
		Message-ID [::mime::uniqueID] \
		Content-Description {Blind Carbon Copy} \
	     -parts [list $inner]]]


        set code2 [catch {
	    sendmessageaux $token $outer $sender $brecipients $aloP
	} cres2 copts2]






	lappend results $code2 $cres2 $copts2


        catch {$inner .destroy -subordinates none}
        catch {$outer .destroy -subordinates none}
    }

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

    foreach {code cres copts} $results {
	# handle just the first one
	switch -- $code {
	    0 {
		set status orderly
	    }

	    7 {
		dict set copts -code 1


		set status abort
		break
	    }

	    default {
		set status abort
		break
	    }
	}
    }

    set code3 [catch {finalize $token -close $status} cres3 copts3]

    if {$code3 && !$code} {
	lassign [list $cres3 $copts3] cres copts
    }

    # Destroy SMTP token 'cause we're done with it.
   
    # Restore provided MIME object to original state (without the SMTP headers).
   
    foreach {key val} [$part header get] {
        $part header set $key "" -mode delete
    }
    foreach {key value} $savedH {
	$part header set $key {*}$value -mode append
    }

    return -options $copts $cres
}

# ::smtp::sendmessageaux --
#

#
# 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} {

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

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

    try {
	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)"
	    }
	}

    } finally {
	if {$state(sd) in [chan names]} {
	    close $state(sd)
	}

	if {$state(afterID) ne {}} {
	    after cancel $state(afterID)
	}

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

}

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

    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 [$part serialize]]
            append from " SIZE=$size"
        }
    }

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

    if {$response(code) == 250} {

    # 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 {$part serialize} 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

    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 ""
    }

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]]
        }

package require nettool
package require smtpd

variable port [nettool::allocate_port 1025]
smtpd::start localhost $port

proc accept msg {
    variable result
    set headers [$msg header get]
    lappend result [lsort [dict keys $headers]]
    lappend result [$msg header get From]

    return
}


proc main {} {
    variable done
    variable result
    test smtp-1.1 {} -body {
	variable port
	smtpd::configure -deliverMIME [namespace which accept]
	set msg [mime::.new {} -canonical text/plain \
	    -string {a door is ajar}]
	set res [smtp::sendmessage $msg -ports $port -originator Slawkenbergius -recipients {[email protected]}]
	lappend result $res
	return $result
    } -cleanup {
	unset result
    } -result [list \
	{Bcc Content-ID Content-Type Date From Message-ID Received Return-Path} {Slawkenbergius {}} {}
    ]

    testsuiteCleanup
    set done 1
    return
}

	    }
	    default {
		error [list {wrong # args}]
	    }
	}
    }
}













































proc ::ncgi::delete token {
    namespace delete [namespace ensemble configure $token -namespace]
}


# ::ncgi::decode

		return 1
	    }
	}
    }
    return 0
}

proc ::ncgi::headerfilter headers {
    join [lmap {key val} $headers[set headers {}] {
	if {[string tolower $key] in {content-type}} continue
	list $key $val
    }]
}


proc ::ncgi::header_send {token type args} {
    namespace upvar $token respons response 
    set mimeout [mime::.new {} -canonical $type -params $args \
	-addcontentid 0 -addmimeversion 0 -addmessageid 0 -string {}
    ]
    foreach {n v} [headerfilter [$token response header get]] {
	$mimeout header set $n {*}$v
    }
    $token response .destroy
    $mimeout serialize -chan ${token}::stdout
    ${token}::stdout flush
    $mimeout .destroy
}


# ::ncgi::get
#
#	Returns 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::all

	    return $default
	}
    } else {
	error [list {wrong # args}]
    }
}






























# ::ncgi::importFile --
#
#   get information about a file upload field
#
# Arguments:
#   cmd         one of '-server' '-client' '-type' '-data'

    namespace upvar $token mimeparts mimeparts
    if {[form $token exists]} {
	set form [form $token get]
    }

    lassign [dict get $mimeparts $var] mime 

    lassign [$mime header get content-disposition] cdisp dispparams

    switch -exact -- $cmd {
	-server {
	    return [$mime body decode]
	}
	-client {
	    if {[dict exists $dispparams filename]} {
		return [dict get $dispparams filename]
	    }
	    return {}
	}
	-type {
	    lassign [$mime header get content-type] ctype params
	    return $ctype
	}
	-data {
	    return [$mime body decoded]
	}
	default {
	    error "Unknown subcommand to ncgi::import_file: $cmd"
	}
    }
}

#	each value is a list containing the header value and a dictionary of
#	parameters for that header.

proc ::ncgi::multipart token {
    namespace upvar $token form form mime mime mimeparts mimeparts
    set type [type $token]
    set data [body $token]
    set mime [mime::.new {}  -string "Content-Type: $type\n\n$data"]
    set parts [$mime property parts]
    trace add variable mime unset [list apply [list {mime args} {
	if {[namespace which $mime] ne {}} {
	    $mime .destroy
	}
    } $mime]]

    set results [list]
    foreach part $parts {
	set value [[$part body decoded] read]
	lassign [$part header get content-disposition] hvalue params
	if {$hvalue eq {form-data} && [dict exists $params name]} {
	    set name [dict get $params name]
	    dict unset params name
	} else {
	    set name {}
	}
	lappend mimeparts $name $part 
	lappend form $name [list $value $params]
    }
    return $form
}


# ::ncgi::.new
#	Create a new cgi session and return a token for that session
# 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::.new {token name args} {
    if {$name eq {}} {
	set name [namespace current]::[info cmdcount]
    } elseif {![string match ::* $name]} {
	set name [uplevel 1 {namespace current}]::$name
    }
    set ns [namespace eval $name {
	namespace ensemble create
	namespace current
    }]
    # normalize $name
    set name [namespace which $name]

    ::tcllib::chan::base .new ${ns}::stdout stdout -close 0

    namespace ensemble create -command ${ns}::header -map [list \
	send [list header_send $name]
    ]


    mime::.new ${ns}::response -canonical text/html -spec cgi -string {}

    set map [dict merge [list decode decode encode encode {*}[join [lmap cmdname {
	.namespace .new all importFile input body cookies delete form get
	merge method query redirect type urlStub
    } {
	list $cmdname [list $cmdname $name]
    }]]] [list \
	header [list ${ns}::header] \
	response [list ${ns}::response] \
	stdout [list ${ns}::stdout]
    ]]
    namespace ensemble configure $name -map $map
    
    trace add command $name delete [list apply [list {
	token headercmd old new op} {
	$old .destroy
    }]]

    # $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

    # $contenttype is the content-type, which affects how the query is parsed

    # $urlStub holds the URL corresponding to the current request
    # This does not include the server name.



    namespace upvar $ns \
	_tmpfiles _tmpfiles \
	body body \
	content_length content_length \
	contenttype contenttype \

	env env \
	form form \
	listRestrict listRestrict \
	method method \
	query query \
	querystring querystring \
	urlStub urlStub \


    # Map of transient files
    array set _tmpfiles {}

    # $listRestrict 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.
    set listRestrict 0




    dict for {opt val} $args {
	switch $opt {
	    body {
		set $opt $val
		set content_length [string length $body]
	    }
	    contenttype - env - form - querystring {
		set $opt $val
	    }
	    default {
		error [list {unknown reset option} $opt]
	    }
	}
    }

    if {![info exists env]} {
	array set env [array get ::env]
    }


    if {[info exists env(CONTENT_LENGTH)] && [
	string length $env(CONTENT_LENGTH)] != 0} {
	set content_length [expr {$env(CONTENT_LENGTH)}]
    }

    if {[info exists env(REQUEST_METHOD)]} {
	set method [string tolower $env(REQUEST_METHOD)]
    }


    return $name
}


# ::ncgi::parseMimeValue
#
#	Parse a MIME header value, which has the form
#	value; param=value; param2="value2"; param3='value3'

	if {[string match /* $url]} {
	    set url $proto://$server$port$url
	} else {
	    regexp -- {^(.*/)[^/]*$} $request_uri match dirname
	    set url $proto://$server$port$dirname$url
	}
    }

    set mimeout [mime::.new {} -canonical text/html -addcontentid 0 \
	-addmimeversion 0 -addmessageid 0 \
	-string "Please go to <a href=\"$url\">$url</a>\n"
    ]

    foreach {n v} [headerfilter [$token response header get]] {
	$mimeout header set $n {*}$v
    }
    $token response .destroy

    $mimeout header set Location $url
    $mimeout serialize -chan ${token}::stdout
    ${token}::stdout flush
    $mimeout .destroy
    return
}


# ::ncgi::type
#
#	This returns the content type of the query data.
#
# Arguments:
#	none
#
# Results:
#	The content type of the query data.
proc ::ncgi::type token {
    namespace upvar $token contenttype contenttype env env

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


# ::ncgi::urlquery

	-parameters token -map {

	parse query_parse
	set query_set
	string query_string
    }

    .new dummy [namespace current]
}

		}
	}


	proc withncgi args {
		set script [lindex $args end]
		set args [lreplace $args end end]
		ncgi .new ncgi1 {*}$args
		catch [list uplevel 1 $script] cres copts
		ncgi1 delete
		resetenv
		return -options $copts $cres
	}


	test ncgi-1.1 {[ncgi .new]} {
		withncgi {
			list [info exist [ncgi1 .namespace]::query] [
				info exist [ncgi1 .namespace]::contenttype]
		}
	} {0 0}

	test ncgi-2.4 {[ncgi query] POST} {
		set env(REQUEST_METHOD) POST
		set env(CONTENT_LENGTH) 10
		withncgi {
			makeFile [format {
				set auto_path {%s}
				source {%s}
				source {%s}
				source {%s}
				ncgi .new ncgi1
				ncgi1 body
				puts [set [ncgi1 .namespace]::body]
				ncgi1 delete
			} $sub_ap $cmdlFile $futlFile $ncgiFile] test1 ; # {}
			set f [open |[list $::tcltest::tcltest test1] r+]
			puts  $f name=value
			flush $f
			gets  $f line
			close $f
			removeFile test1
			set line
		}
	} name=value

		set env(SERVER_PORT) 80
		makeFile [makescript [format {
			set auto_path {%s}
			if {[catch {
				source %s
				source %s
				source %s
				ncgi .new ncgi1
				ncgi1 redirect %s
				ncgi1 delete
			} err eopts]} {
				puts stderr [dict get $eopts -errorinfo]
				puts $err
			}
		} $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1
		set f [open |[list $::tcltest::tcltest test1] r+]
		set res [read $f]
		close $f
		removeFile test1
		set res
	} "Content-Type: text/html\nLocation: $URL\n\nPlease go to <a href=\"$URL\">$URL</a>\n"

		set env(SERVER_PORT) 80
		makeFile [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			set token [ncgi .new {}]
			$token response cookie set -name CookieName -value 12345
			$token redirect %s
			$token delete
		} err copts]} {
			puts [dict get $copts -errorinfo]
		}
		exit
		} $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1
		set f [open |[list $::tcltest::tcltest test1] r+]
		set res [read $f]
		close $f
		removeFile test1
		set res
	} "Content-Type: text/html\nSet-Cookie: CookieName=12345 ;\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"


	set URL foo.html
	set URL2 http://www.scriptics.com/cgi-bin/foo.html
	test ncgi-11.3 {ncgi::redirect} {
		set env(REQUEST_URI) http://www.scriptics.com/cgi-bin/test.cgi
		set env(REQUEST_METHOD) GET
		set env(QUERY_STRING) {}
		set env(SERVER_NAME) www.scriptics.com
		set env(SERVER_PORT) 80
		makeFile [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi .new ncgi1
			ncgi1 redirect %s
			ncgi1 delete
		} err]} {
			puts $err
		}
		exit
		} $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1
		set f [open |[list $::tcltest::tcltest test1] r+]
		set res [read $f]
		close $f
		removeFile test1
		set res
	} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"

		set env(SERVER_PORT) 80
		makeFile [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi .new ncgi1
			ncgi1 redirect %s
			ncgi delete
		} err]} {
			puts $err
		}
		exit
		} $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1
		set f [open |[list $::tcltest::tcltest test1] r+]
		set res [read $f]
		close $f
		removeFile test1
		set res
	} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"

		set env(SERVER_PORT) 8000
		makeFile [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi .new ncgi1
			ncgi1 redirect %s
			ncgi1 delete
		} err]} {
			puts $err
		}
		exit
		} $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1
		set f [open |[list $::tcltest::tcltest test1] r+]
		set res [read $f]
		close $f
		removeFile test1
		set res
	} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"

		set env(HTTPS) on
		makeFile [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi .new ncgi1
			ncgi1 redirect %s
			ncgi1 delete
		} err]} {
			puts $err
		}
		exit
		} $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1

		set env(HTTPS) on
		makeFile [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi .new ncgi1
			ncgi1 redirect %s
			ncgi1 delete
		} cres copts]} {
			puts stderr [dict get $copts -errorinfo] 
			exit 1
		}
		exit
		} $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1
		set f [open |[list $::tcltest::tcltest test1] r+]
		set res [read $f]
		close $f
		removeFile test1
		set res
	} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"


	test ncgi-12.1 {ncgi::header} {
		makeFile [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi .new ncgi1
			ncgi1 header send text/html
			ncgi1 delete
		} err copts]} {
			puts stderr [dict get $copts -errorinfo] 
			exit 1
		}
		exit
		} $sub_ap $cmdlFile $futlFile $ncgiFile]] test1
		set f [open |[list $::tcltest::tcltest test1] r+]
		set res [read $f]
		close $f
		removeFile test1
		set res
	} "Content-Type: text/html\n\n"


	test ncgi-12.2 {ncgi::header} {
		makeFile [makescript [format {
		    set auto_path {%s}
		    if {[catch {
			source %s
			source %s
			source %s
			ncgi .new ncgi1
			ncgi1 header send text/plain
			ncgi1 delete
		    } err copts]} {
			puts stderr [dict get $copts -errorinfo] 
			exit 1
		    }
		    exit
		} $sub_ap $cmdlFile $futlFile $ncgiFile]] test1
		set f [open |[list $::tcltest::tcltest test1] r+]
		set res [read $f]
		close $f
		removeFile test1
		set res
	} "Content-Type: text/plain\n\n"


	test ncgi-12.3 {ncgi::header} {
		makeFile [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi .new ncgi1
			ncgi1 response header set X-Comment {This is a test}
			ncgi1 header send text/html
			ncgi1 delete
		} cres copts]} {
			puts stderr [dict get $copts -errorinfo] 
			exit 1
		}
		exit
		} $sub_ap $cmdlFile $futlFile $ncgiFile]] test1
		set f [open |[list $::tcltest::tcltest test1] r+]
		set res [read $f]
		close $f
		removeFile test1
		set res
	} "Content-Type: text/html\nX-Comment: This is a test\n\n"


	test ncgi-12.4 {ncgi::header} {
		makeFile [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi .new ncgi1
			ncgi1 response cookie set -name Name -value {The+Value}
			ncgi1 header send text/html
		} err]} {
			puts $err
		}
		exit
		} $sub_ap $cmdlFile $futlFile $ncgiFile]] test1
		set f [open |[list $::tcltest::tcltest test1] r+]
		set res [read $f]
		close $f
		removeFile test1
		set res
	} "Content-Type: text/html\nSet-Cookie: Name=The+Value ;\n\n"

package require mime
package require smtp

set sndr "tcl-test-script@localhost"
set rcpt "tcllib-test@localhost"
set msg "This is a sample message send from Tcl.\nAs\
always, let us check the transparency function:\n. <-- there\
should be a dot there.\nBye"

set tok [mime::.new {} -canonical text/plain -encoding 7bit -string $msg]
$tok header set Subject "Testing from Tcl"
smtp::sendmessage $tok -servers localhost \
    -header [list To $rcpt] \
    -header [list From $sndr]
$tok .destroy

    set deliverMIME [cget deliverMIME]
    if { $deliverMIME != {} \
            && [state $channel from] != {} \
            && [state $channel to] != {} \
            && [state $channel data] != {} } {
        
        # create a MIME token from the mail message.        
        set tok [mime::.new {} -string \
                [join [state $channel data] \n]]
#        mime::setheader $tok "From" [state $channel from]
#        foreach recipient [state $channel to] {
#            mime::setheader $tok "To" $recipient -mode append
#        }
        
        # catch and rethrow any errors.
        set err [catch {eval $deliverMIME [list $tok]} msg]
        $tok .destroy -subordinates all
        if {$err} {
            Log debug "error in deliver: $msg"
            return -code error -errorcode $::errorCode \
                    -errorinfo $::errorInfo $msg
        }        
        
    } else {