Tcl Library Source Code

#! /usr/bin/env tclsh

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


proc .init {_ channame args} {
    $_ .vars chan close
    if {$channame ni [::chan names]} {
	error [list {unknown channel} $channame]
    }
    set chan $channame
    $_ .ondelete [list ::apply {{_ channame} {
	$_ .vars close
	if {$close} {
	    ::close $channame
	}
    }} $_ $channame]
    set close 1
    if {[llength $args]} {
	$_ configure {*}$args
    }
    return $_
}
.my .method .init


proc configure {_ args} {
    $_ .vars chan
    if {[llength $args] == 1} {
	lassign $args key
	switch $key {
	    -chan {
		return $chan
	    }
	}
	set res [::chan configure $chan {*}$args]
    } elseif {[llength $args]} {
	dict size $args
	foreach {key val} $args[set args {}] {
	    switch $key {
		-chan {
		    set chan $val
		}
		-close {
		    $_ $ close [expr {!!$val}]
		}
		default {
		    lappend args $key $val
		}
	    }
	}
	if {[llength $args]} {
	    ::chan configure $chan {*}$args
	}
	set res {}
    } else {
	set res [list {*}[::chan configure $chan {*}$args] -chan $chan]
    }
    return $res
}
.my .method configure


proc copy {_ target} {
    ::chan copy [$_ $ chan] $target
}
.my .method copy


proc gets {_ args} {
    uplevel 1 [list ::gets [$_ $ chan] {*}$args]
}
.my .method gets


proc pending {_ args} {
    uplevel 1 [list ::pending {*}$args [$_ $ chan]]
}
.my .method pending


proc puts {_ args} {
    uplevel 1 [list ::puts {*}[lrange $args 0 end-1] [$_ $ chan] {*}[
	lrange $args end end]]
}
.my .method puts


proc read {_ args} {
    uplevel 1 [list ::read {*}[lrange $args 0 end-1] [$_ $ chan] {*}[
	lrange $args end end]]
}
.my .method read


apply [list {} {
    foreach name {
	blocked close eof event flush names pop posteven push seek tell
	truncate
    } {
	proc $name {_ args} [string map [
	    list @name@ [list $name]] {
	    ::chan @name@ [$_ $ chan] {*}$args
	}]
	.my .method $name
    }
} [namespace current]]

#! /usr/bin/env tclsh

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

testsNeedTcl     8.5
testsNeedTcltest 1.0-

package require tcl::chan::string 
package require {chan base}
namespace import ::tcllib::chan::base

proc main {} {
    variable done

    set data1 abcdefghijklmnopqrstuvwxyz

    test chan-object-closeondelete {
    } -body {
	base .new chan1 [::tcl::chan::string $data1]
	set name [chan1 $ chan]
	lappend res [expr {$name in [chan names]}]
	chan1 close
	lappend res [expr {$name in [chan names]}]
    } -result {1 0} 

    testsuiteCleanup
    set done 1 
}

after 0 coroutine [info cmdcount]_main main  
vwait [namespace current]::done

#! /usr/bin/tclsh

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

package require coroutine


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


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


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

#! /usr/bin/tclsh

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

testsNeedTcl     8.5
testsNeedTcltest 1.0-

package require {chan base}
package require {chan coroutine}
package require tcl::chan::string 


proc main {} {try {
    variable done

    test getslimit-configure {} -body {
	::tcllib::chan::base .new chan1
	::tcllib::chan::coroutine chan1
	chan1 .init [::tcl::chan::string \
	    {Curiosity governs the first moment}]
	chan1 read
    } -cleanup {
	rename chan1 {}
    } -result {Curiosity governs the first moment} 

    testsuiteCleanup
} finally {
    set done 1
}}

after 0 coroutine [info cmdcount]_main main  
vwait [namespace current]::done

#! /usr/bin/env tclsh

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

variable buf bufcount eof getslimit

proc [namespace current] chan {
	if {![string match ::* $chan]} {
		set chan [uplevel 1 [list ::namespace which $chan]]
	}
	$chan .specialize
	foreach name {
		.init configure eof gets read
	} {
		$chan .method $name getslimit::$name
	}
	return $chan
}


proc .init {_ args} {
    $_ .vars eof buf bufcount getslimit
    set eof 0
    set buf {}
    set bufcount 0
    set getslimit -1
    uplevel 1 [list $_ .prototype .init {*}$args]
}


proc configure {_ args} {
    $_ .vars getslimit
    if {[llength $args] == 1} {
	switch [lindex $args 0] {
	    -getslimit {
		set res $getslimit
	    } default {
		set res [uplevel 1 [list $_ .prototype configure {*}$args]]
	    }
	}
    } 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 {}
    } else {
	set res [list {*}[uplevel 1 [
	    list $_ .prototype configure {*}$args]] -getslimit $getslimit]
    }
    return $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 {
	    #this is just to generate the error message
	    ::gets [$_ $ chan] {*}$args
	}
    }

    if {$eof} {
	if {[info exists varname]} {
	    set resvar {}
	    return -1
	}
	return {}
    }

    if {[string first \n $buf] < 0 && ![::eof $chan]} {
	if {$getslimit >= 0} {
	    append buf [$_ read $getslimit]
	} else {
	    append buf [$_ read]
	}
    }

    if {[regexp {^(.*?)\n(.*)$} $buf -> res remainder]} {
	set buf $remainder
	set bufcount [expr {$bufcount - [string length $res] - 1}]
    } else {
	# must be at eof
	set res $buf
	set buf {}
	set bufcount 0
	if {[::eof $chan]} {
	    set eof 1
	}
    }

    if {[llength $args]} {
	set args [lassign $args[set args {}] varname]
	set resvar $res

	if {$res eq {} && $eof} {
	    return -1
	} else {
	    return [string length $res]
	}
    } 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 [string range $buf 0 [expr {$size - 1}]]
		set buf [string range $buf $size end]
		incr bufcount -[string length $res]
	    } else {
		set readsize [expr {$size - $bufcount}]
		set res $buf[set buf {}][$_ .prototype read $readsize]
		set bufcount 0
	    }
	} else {
	    set bufcount 0
	    set res $buf[set buf {}][$_ .prototype read {*}$args]
	}
    } else {
	set res [$_ .prototype read {*}$args]
    }
    return $res
}


package provide tcllib::chan::getslimit 1

#! /usr/bin/tclsh

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

testsNeedTcl     8.5
testsNeedTcltest 1.0-

package require {chan base}
package require {chan getslimit}

package require tcl::chan::memchan 
package require tcl::chan::string 
namespace import ::tcllib::chan::getslimit

proc main {} {
    variable done
    set data1 abcdefghijklmnopqrstuvwxyz

    test getslimit-configure {} -body {
	::tcllib::chan::base .new chan1
	getslimit chan1
	chan1 .init [::tcl::chan::memchan] -getslimit 33
	chan1 configure -getslimit
    } -cleanup {
	rename chan1 {}
    } -result 33


    test getslimit-under {
    } -body {
	::tcllib::chan::base .new chan1
	getslimit chan1
	chan1 .init [::tcl::chan::string $data1] -getslimit 1000
	chan1 gets
    } -cleanup {
	rename chan1 {}
    } -result $data1


    test getslimit-exceeded {
    } -body {
	::tcllib::chan::base .new chan1
	getslimit chan1 
	chan1 .init [::tcl::chan::string [
	    string repeat $data1 100]] -getslimit 10
	chan1 gets
    } -cleanup {
	rename chan1 {}
    } -result {abcdefghij}

    test getslimit-read {
	read is unaffacted by the limit
    } -body {
	::tcllib::chan::base .new chan1
	getslimit chan1
	chan1 .init [::tcl::chan::string $data1]
	chan1 configure -getslimit 10
	lappend res [chan1 read 15]
	lappend res [chan1 read 3]
	lappend res [chan1 read 1]
	lappend res [chan1 read]
	lappend res [chan1 eof]
	lappend res [chan1 read]
	lappend res [chan1 eof]
    } -cleanup {
	rename chan1 {}
    } -result {abcdefghijklmno pqr s tuvwxyz 1 {} 1}

    testsuiteCleanup
    set done 1 
}

after 0 coroutine [info cmdcount]_main main  
vwait [namespace current]::done

#! /usr/bin/env tclsh


package ifneeded {chan getslimit} 0.1 [list ::apply {dir {
    package require ego
    namespace eval ::tcllib::chan::getslimit [list ::source $dir/getslimit.tcl]
    package provide {chan getslimit} 0.1
    namespace eval ::tcllib::chan {
	namespace export getslimit
    }
}} $dir]


package ifneeded {chan base} 0.1 [list ::apply {dir {
    package require ego
    tcllib::ego .new ::tcllib::chan::base 
    ::tcllib::chan::base .eval [list ::source  $dir/base.tcl]
    namespace eval ::tcllib::chan {
	namespace export base
    }
    package provide {chan base} 0.1
}} $dir]


package ifneeded {chan coroutine} 0.1 [list ::apply {dir {
    package require ego
    namespace eval ::tcllib::chan::coroutine [list ::source $dir/coroutine.tcl]
    package provide {chan coroutine} 0.1
    namespace eval ::tcllib::chan {
	namespace export coroutine
    }
}} $dir]

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 {

namespace eval ::dicttool {}
namespace eval ::tcllib {}

###
# Because many features in this package may be added as
# commands to future tcl cores, or be provided in binary
# form by packages, I need a declarative way of saying
# [emph {Create this command if there isn't one already}].
# The [emph ninja] argument is a script to execute if the
# command is created by this mechanism.
###
proc ::tcllib::PROC {name arglist body {ninja {}}} {
  if {[info commands $name] ne {}} return
  proc $name $arglist $body

#! /bin/env tclsh

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

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} {
	namespace upvar [$_ .namespace] $name var
	if {[llength $args]} {
		if {[llength $args] > 1} {
			error [list {wrong # args}]
		}
		set var [lindex $args 0]
	}
	return $var
}
.method [namespace current] $


proc .as {_ other name args} {
	set map [namespace ensemble configure $_ -map]
	set cmd [dict get $map $name]
	if {[lindex $name 1] ne $_} {
		error [list {not a method} $name]
	}
	set cmd [lreplace $cmd 1 1 $other]
	::tailcall {*}$cmd
}
.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
		::namespace current
	}]]
	::trace add command $ns delete [list ::apply {{ns oldname newname op} {
		if {[namespace exists $ns]} {
			namespace delete $ns
		}
	}} $ns]

	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 {}
	if {$script ne {}} {
	    set trace [list apply {{script args} {
		try $script
	    }} $script]
	    trace add command $_ delete $trace
	}
	$_ .method .ondelete .ondelete $trace
    } elseif {[llength $args]} {
	error [list {wrong # args}]
    }
    return $trace
}
.method [namespace current] .ondelete .ondelete {}


proc .routine {_ name args} {
	if {![llength $args]} {
		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] = 

#! /usr/bin/env tclsh

package ifneeded ego 0.1 [list ::apply {dir {
    namespace eval ::tcllib::ego [list ::source $dir/ego.tcl]
    package provide ego 0.1
}} $dir]

[keywords {rfc 821}]
[keywords {rfc 822}]
[keywords {rfc 2045}]
[keywords {rfc 2046}]
[keywords {rfc 2049}]
[keywords smtp]
[copyright {1999-2000 Marshall T. Rose}]
[copyright {2018  Poor Yorick}]
[moddesc   {Mime}]
[titledesc {Manipulation of Internet messages}]
[category  {Text processing}]
[require Tcl 8.5]
[require mime [opt 1.6]]
[description]
[para]

Provides commands to create and manipulate Internet messages.

[list_begin definitions]


[call [cmd ::mime::.new] [arg name] [opt [arg options]]]







Parses a message, creates an routine named [arg name] as a handle for the
message, and returns the name of the new routine.  If [arg name] is the empty
string, a name is automatically generated.  One and only one of [

    option -chan

], [

    option -file

], or [

    option -string
    
] must be provided as the source of the input.  Optional arguments are
processed such that later arguments override earlier arguments.  For example,
provide [option -addcontentid] [const 1] after [option "-spec [const http]"]  has disabled
that option.  The optional arguments are

[list_begin definitions]

    [def "[option -addcontentid] [arg boolean]"]
   
	Indicates whether a [const Content-ID] header field should be added to
	the message.  By default, this header is added to non-canonical
	messages.

    [def "[option -addmimeversion] [arg boolean]"]
    
	Indicates whether a [const MIME-Version] header should be added to
	non-canonical messages.  By default, this header is added to
	non-canonical messages.

    [def "[option -canonical] [arg type/subtype]"]

	The input message is the body only and is in the format
	specified by the provided [

	    arg type/subtype
	    
	], and therefore should not be parsed.

    [def "[option -chan] [arg channel]"]

	The name of an ensemble command providing the standard channel commands.

    [def "[option -encoding] [arg encoding]"]
    
	sets the [const Content-Transfer-Encoding].

    [def "[option -file] [arg string]"]

	The file providing the input message.

    [def "[option -headers] [arg headers]"]

	[arg headers] is a multidict of headers.

    [def "[option -spec] [arg spec]"]

	[arg spec] is one of [const mime] (the default) or [const http],
	indicating what specification to conform to.  For [const mime], the
	default [const Content-Type] is [const text/plain] and the character
	set is assumed to be [const US-ASCII].  For [const http], the default
	[const Content-Type] is [const text/html], the [const charset] is
	[const utf-8], and  [const MIME-Version] and [const Content-ID] headers
	are by default not automatically added.
   
    [def "[option -params] [arg params]"]

	[arg params] is a multidict (a dictionary where the keys may not be
	unique) of parameters for the [

	    const Content-Type
    
	] header. 

    [def "[option -parts] [arg parts]"]

	[arg parts] is  list of tokens for messages that comprise a [

	    const multipart/mixed
	    
	] message body.

    [def "[option -string] [arg string]"]
	The string providing the input message.


[list_end]


[call [arg message] [method body] [opt [option -decode]] [opt "[option -blocksize] [arg octets]"]"]

Sets to [const 0] the cursor for the channel holding the body of the message

and returns the name of a channel command for that channel.


[para]

If [option -blocksize] is provided, returns a command that itself returns up to
the next [arg octets] of the message each time it's called, and returns a code
of [const break] when finished, deleting itself as well.  If [arg octets] is
the empty string, a default value is used. 



[para]


[option -decode] converts the message body from the character set it is encoded
in.


[call [arg message] [method {cookie delete}] [arg args]]

Deletes the specifed cookie. [arg args] is the same as for
[method {cookie set}], except that [arg -value] is not needed and
[arg -expires] is ignored.


[call [arg message] [method {cookie set}] [arg name] [arg value] [arg args]]

Sets a cookie header.

[arg args] is a dictionary options:

[list_begin definitions]

[def "[option expires] [arg date]"]
[def "[option path] [arg {path restriction}]"]
[def "[option domain] [arg {domain restriction}]"]
[def "[option httponly] [arg boolean]"]
[list_end]


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

Destroys the message 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 [arg message] [method header] [method serialize] [arg value] [arg parameters]]

Returns the the serialization of a header.


[call [arg message] [method header] [method get] [opt "[arg key] | [option -names]"]]

Returns the header of a message as a multidict where each value is a list
containing the header value and a dictionary of parameters for that header.


[para]

If [arg name] is provided, returns the value and parameters of the last entry
matching that name, without regard to case.


[para]

If [option -names] is provided, returns a list of all header names.


[call [arg message] [method header] [method set] [arg {name value}] [ \
    opt "[arg parameters] [opt "[option -mode] [const write] | [\
	const append] | [const delete]"]"]]

[arg parameters] is a dictionary of parameters for the header.  If parameters
contains an odd number of items, the last item is a list of flag parameters.

If [const append] is provided, creates a new header named [arg name] with the
value of [arg value] and any provided [arg parameters].

If [const write] is provided, first deletes any existing headers matching 
[arg name].

If [const delete] is provided, deletes any existing header matching [arg name].

Returns a list of strings containing the previous value associated with the
key.


[para]

The value for [option -mode] is one of:

[list_begin definitions]

[def [const write]]

The [arg key]/[arg value] is either created or overwritten (the default).

[def [const append]]

Appends a new [arg key]/[arg value].

[def [const delete]]

Removes all values associated with the key.  [arg value] is ignored.

[list_end]


[call [arg message] [method property] [opt "[arg name] | [option -names]"]]

Returns a dictionary of message properties.  If [arg name] is provided, only
the corresponding value is returned.  If [option -names] is provided, a list
of all property names is returned.


[para]
properties:

[list_begin definitions]

[def [const content]]

The type/subtype of the content

[def [const encoding]]

The "Content-Transfer-Encoding"

[def [const params]]

A list of "Content-Type" parameters

[def [const parts]]

A list of tokens for messages that comprise a multipart body.  Only exists if
there are any such messages.

[def [const size]]

The approximate size of the unencoded content.

[list_end]


[call [arg message] [method serialize] [opt [option -level]] [
    opt "[option -chan] [arg channel]"]]

Returns the serialization of the message.  If
[option -chan] is provided, writes the serialization to [arg channel] and returns the
empty string.  [option -level], if provided, indicates the level of the part
in the message hierarchy.  The [const MIME-Version] header is only included at
level [const 0].


[call [cmd ::mime::datetime] ([arg time] | [option -now]) [arg property]]

Returns the [arg property] of [arg time], which is an 822-style date-time
value.


[para]

Available properties and their ranges are:

[list_begin definitions]

[def [const zone]]

-720 .. 720 (minutes east of GMT)

[list_end]




























































































































[call [cmd ::mime::parseaddress] [arg addresses]]

Returns a list describing the comma-separated 822-style [arg addresses].


[para]

Each dictionary contains the following keys, whose values may be the empty
string:

[call [cmd ::mime::reversemapencoding] [arg charset_type]]

Maps MIME charset types onto tcl encoding names.  Those
that are unknown return "".

[list_end]


























[vset CATEGORY mime]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

# 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-2018 Poor Yorick
#
#
# 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.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

package provide mime 1.7

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

    # Fall-back to tcl-based procedures of base64 and quoted-printable encoders

#
# state variables:
#
#     canonicalP: input is in its canonical form
#     encoding: transfer encoding
#     version: MIME-version
#     header: dictionary (keys are lower-case)


#     value: either "chan" or  "parts"
#
#     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 0 state(fd) fd


































































































    if {[info exists fd]} {


	error [list {a channel is already present}]











    }




























































































































































































































































































    if {[$chan configure -encoding] ne {binary}} {



	$chan configure -translation auto


    }





























































































    set fd $chan







    incr channels($fd)
    return
}


# ::mime::addr_next --
#
#       Locate the next address in a mime token.
#

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

    return [string trim $mbox \"]
}


proc ::mime::checkinputs {} {
    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
	}
    }
}

proc ::mime::cookie_delete {_ name args} {
    # this -expires overrides any that might be in $args
    $_ cookie set value {} {*}$args expires [
	format 0 -timezone :UTC -format {%a, %d %b %Y %H:%M:%S %z}]
    return
}


# ::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
#		?httponly?	boolean, default true

#
# Side Effects:
#	Formats and stores the Set-Cookie header for the reply.

proc ::mime::cookie_set {_ name value args} {
    dict size $args
    foreach {key val} $args {
	switch $key {
	    domain - expires - httponly - path {
		set $key $val
	    }
	    default {
		error [list {wrong # args} {should be} \
		    [list name value ?path path? ?domain domain? \
			?expires date? ?httponly boolean?]]
	    }
	}
    }
    set line $name=$value
    set params {}
    set flags {}
    foreach extra {path domain} {
	if {[info exists $extra]} {
	    lappend params $extra [set $extra]
	}
    }
    if {[info exists expires]} {
	switch -glob $expires {
	    *GMT {
		# do nothing
	    }
	    default {
		set expires [clock format [datetimescan $expires] \
		    -format {%A, %d-%b-%Y %H:%M:%S GMT} -gmt 1]
	    }
	}
	lappend params expires $expires
    }
    if {[info exists secure]} {
	lappend flags secure
    }
    if {![info exists httponly] || $httponly} {
	lappend flags HttpOnly
    }
    if {[llength $flags]} {
	lappend params $flags
    }
    $_ header set Set-Cookie $line $params 
    return
}


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

                                    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::datetime {value property} {
    if {$value eq {-now}} {
        set clock [clock seconds]













    } else {
        set clock [datetimescan $value]
    }

    switch $property {
        clock {
            return $clock
        }

        #TODO: this path is not covered by tests
        set value 0
    }
    return $value
}


proc ::mime::datetimescan value {
    variable timeformats
    foreach format $timeformats {
	if {![catch {clock scan $value -format $format} cres copts]} break
    }
    return -options $copts $cres
}


# ::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 _ {
    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 [set state(encoding) base64]
        }

        message/*
            -
        multipart/* {
            return [set state(encoding) {}]
        }
        default {# Skip}
    }

    set asciiP 1
    set lineP 1
    if {[info exists state(parts)]} {
	return [set state(encoding) {}]
    }

    if {[set current [$chan tell]] < 0} {
	makeseekable $token
	set current [$chan tell]
    }
    set chanconfig [$chan configure]
    try {
	set buf {}
	set dataend 0
	while {[set data [$chan read 8192]] ne {} || $buf ne {}} {
	    if {$data eq {}} {
		set dataend 1
	    }
	    set data $buf[set buf {}]$data[set data{}]
	    set lines [split $data \n]
	    if {!$dataend} {
		set buf [lindex $lines end]
		set lines [lrange $lines[set lines {}] 0 end-1]
	    }
	    if {[llength $lines]} {
		if {$asciiP} {
		    set asciiP [encodingasciiP $lines]
		}
		if {$lineP} {
		    set lineP [encodinglineP $lines]
		}
		if {(!$asciiP) && (!$lineP)} {
		    break
		}
	    }
	}
    } finally {
	$chan configure {*}$chanconfig
	$chan seek 0
    }

    switch -glob $content {
        text/* {
            if {!$asciiP} {
                #TODO: this path is not covered by tests
		if {[dict exists $params charset]} {
		    set v [string tolower [dict get $params $charset]]
		    if {($v ne {us-ascii}) \
			    && (![string match {iso-8859-[1-8]} $v])} {
			return [set state(encoding) base64]
		    }
		}
            }

            if {!$lineP} {
                return [set state(encoding) quoted-printable]
            }
        }


        default {
            if {(!$asciiP) || (!$lineP)} {
                return [set state(encoding) base64]
            }
        }
    }
    return [set state(encoding) {}]
}

# ::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 lines {
    foreach line $lines {
	set firstr [string first \r $line]]
	if {
	    $firstr > 0 && $first != [string length $line]
	} {
	    return 0
	}
	foreach c [split $line {}] {
	    switch $c {
		{ } - \t - \r - \n {
		}

		default {
		    binary scan $c c c
		    if {($c < 32) || ($c > 126)} {
			return 0
		    }
		}
	    }
	}
    }
    return 1
}

# ::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 lines {
    foreach line $line {
	if {([string length $line] > 76) \
		|| ($line ne [string trimright $line]) \
		|| ([string first . $line] == 0) \
		|| ([string first {From } $line] == 0)} {
	    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]]
	    $chan seek 0
	} finally {
	    $chan configure {*}$config
	}
    }
    return $id@|
}


proc ::mime::dropchan token {
    variable channels
    upvar 0 $token state
    upvar 0 state(fd) fd

    if {[info exists fd]} {
	if {[incr channels($fd) -1] == 0} {
	    unset channels($fd)
	    if {$state(closechan)} {
		$fd close
	    }
	}
	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)"
        }
    }

    dropchan $token

    if {$state(bodychan) ne {}} {
	if {[$state(bodychan) configure -chan] in [chan names]} {
	    rename $state(bodychan) {}
	}
    }

    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]
    binary scan $hash H* hex
    return $hex@|
}

# ::mime::mimegets --
#
#    like [gets] but does not run over multipart boundaries
#
#    only needed during the parsing stage, since after that the content of each
#    part is in a separate file
#
# Arguments:
#       token      The MIME token to parse.
#
# Results:
#       Returns the size in bytes of the MIME token.
proc ::mime::mimegets {token varname} {
    upvar 0 $token state
    upvar 0 state(boundary) boundary state(eof) eof
    upvar 1 $varname line
    if {$eof} {
	set line {}
	return -1
    }
    set res [$state(fd) gets line]
    if {$res == -1} {
	set eof 1
	set line {}
	return -1
    } else {
	set found [string first --$boundary $line]
	if {$found == 0} {
	    if {[string first --$boundary-- $line] >= 0} {
		set state(sawclosing) 1
		set eof 1
	    }
	    set line {}
	    return -1 
	}
	return $res
    }
}

# ::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 _ {
    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 {
	set size 0
	if {$state(canonicalP)} {
	    if {[set current [$inputchan tell]] < 0} {
		makeseekable $token
	    }
	    set current [$inputchan tell]
	    $inputchan seek 0 end
	    set size [$inputchan tell]
	    $inputchan seek $current
	} else {
	    set size $state(size)
	}
    }
    # no longer needed since size is calculated during parsing
    #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
    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 internal 0
}


proc ::mime::header::boundary {} {
    return [uniqueID]
}


# ::mime::dunset --
#
#   Unset all values for $key, without "normalizing" other redundant keys
proc ::mime::header::dunset {dictname key} {
    upvar 1 $dictname dict
    set dict [join [lmap {key1 val} $dict[set dict {}] {
	if {$key1 eq $key} continue
	list $key1 $val
    }]]
}


proc ::mime::header::exists {token name} {
    upvar 0 $token state
    set lname [string tolower $name]
    expr {[dict exists $state(headerlower) $lname]
		|| [dict exists $state(headerinternallower) $lname]
		|| [dict exists $state(contentidlower) $lname]
		|| [dict exists $state(messageidlower) $lname]
    }
}


# ::mime::header get --
#
#    Returns the header of a message as a multidict where each value is a list
#    containing the header value and a dictionary parameters for that header.

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

	-names {
	    return [dict keys $header]
	}

	default {
	    set lower [string tolower $key]

	    switch $lower {
		content-id {
		    if {![dict size $contentidlower]} {
			contentid $token
		    }
		    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 {
		    set res {}
		    if {[dict exists $headerinternallower $lower]} {
			return [dict get $headerinternallower $lower]
		    } elseif {[dict exists $headerlower $lower]} {
			return [dict get $headerlower $lower]
		    } else {
			error [list {no such header} $key]
		    }
		}
	    }
	}
    }
}


proc ::mime::header::parse token {
    # FRINK: nocheck
    upvar 0 $token state
    upvar 0 state(fd) fd state(boundary) boundary
    if {$state(canonicalP) || $state(headerparsed)} {
	return
    }
    set state(headerparsed) 1

    if {[info exists boundary]} {
	set gets [list [namespace parent]::mimegets $token line]
    } else {
	set gets [list $fd gets line]
    }

    set vline {}
    while 1 {
	set blankP 0
	set x [{*}$gets]
	if {$x <= 0} {
	    set blankP 1
	}

	# to do 2018-11-13: probably remove this now that line translation
	# happens automatically,
	if {!$blankP && [string match *\r $line]} {
	    set line [string range $line 0 $x-2]
	    if {$x == 1} {
		set blankP 1
	    }
	}

	# there is a space and a tab between the brackets in next line
        if {!$blankP && [string match {[ 	]*} $line]} {
            append vline { } [string trimleft $line " \t"]
            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 [list {improper line in header} $vline]
        }
        set value [string trim [string range $vline [expr {$x + 1}] end]]

        switch [set lower [string tolower $mixed]] {
	    content-disposition {
		set_ $token $mixed {*}[parseparts $token $value]
	    }

	    content-id {
		setinternal $token $mixed $value
	    }

            content-type {
                if {[exists $token content-type]} {
                    error [list {multiple Content-Type fields starting with} \
			$vline]
                }

                set x [parsetype $token $value]
		setinternal $token Content-Type {*}$x
            }

            content-md5 {
            }

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

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

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

            default {
		set_ $token $mixed $value -mode append
            }
        }

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


proc ::mime::header::parseparams token {
    # FRINK: nocheck
    upvar 0 $token state
    set params {}

    while 1 {
        switch [parselexeme $token] {
            LX_END {
		return [processparams $params[set params {}]]
            }

	    LX_SEMICOLON {
		if {[dict size $params]} {
		    continue
		} else {
		    error [list {expecting attribute} not $state(buffer)]
		}
	    }

            LX_ATOM {
            }

            default {
                error [list {expecting attribute} not $state(buffer)]
            }
        }

        set attribute [string tolower $state(buffer)]

        if {[parselexeme $token] ne {LX_EQUALS}} {
            error [list expecting = found  $state(buffer)]
        }

        switch [parselexeme $token] {
            LX_ATOM {
            }

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

            default {
                error [list expecting value found $state(buffer)]
            }
        }
        dict set params $attribute $state(buffer)
    }
}


proc ::mime::header::parseparts {token value} {
    variable token_re
    upvar 0 $token state

    if {![regexp $token_re $value match type]} {
	error [list {expected disposition-type}]
    }

    variable typetokenL
    variable typelexemeL

    set value [string range $value[set value {}] [string length $match] end]

    set state(input)   $value
    set state(buffer)  {}
    set state(lastC)   LX_END
    set state(comment) {}
    set state(tokenL)  $typetokenL
    set state(lexemeL) $typelexemeL

    set code [catch {parseparams $token} result copts]

    unset {*}{
	state(input)
	state(buffer)
	state(lastC)
	state(comment)
	state(tokenL)
	state(lexemeL)
    }

    return -options $copts [list $type $result]
}


# ::mime::header::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::header::parsetype {token string} {
    # FRINK: nocheck
    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

    catch {parsetypeaux $token} result copts

    unset {*}{
	state(input)
	state(buffer)
	state(lastC)
	state(comment)
	state(tokenL)
	state(lexemeL)
    }

    return -options $copts $result
}


# ::mime::header::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::header::parsetypeaux token {
    # FRINK: nocheck
    upvar 0 $token state
    set params {}

    if {[parselexeme $token] ne {LX_ATOM}} {
        error [list expecting type found $state(buffer)]
    }
    set type [string tolower $state(buffer)]

    switch [parselexeme $token] {
        LX_SOLIDUS {
        }

        LX_END {
            if {$type ne {message}} {
                error [list expecting type/subtype found $type]
            }

            return [list message/rfc822 {}]
        }

        default {
            error [list expecting / found  $state(buffer)]
        }
    }

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

    switch [parselexeme $token] {
	LX_END {
	}

	LX_SEMICOLON {
	    set params [parseparams $token]
	}

	default {
	    error [list expecting  {;  or end} found $state(buffer)]
	}
    }

    list $type $params
}


proc ::mime::header::processparams params {
    set info {}
    foreach key [lsort -dictionary [dict keys $params]] {
	set pvalue [dict get $params $key]
	# a trailing asterisk is ignored if this is not the first field in an
	# identically-named series

	# this expression can't fail
	regexp {^([^*]+?)(?:([*])([0-9]+))?([*])?$} $key -> name star1 counter star2
	dict update info $name dict1 {
	    if {![info exists dict1]} {
		set dict1 {}
	    }
	    dict update dict1 encoding encoding value value {
		if {$star1 ne {}} {
		    if {$star2 ne {} || $counter eq {}} {
			if {![regexp {^([^']*)'([^']*)'(.*)$} $pvalue \
			    -> charset lang pvalue]} {

			    error [list [list malformed language information in \
				extended parameter name]]
			}
			if {$charset ne {}} {
			    set encoding [reversemapencoding $charset]
			}
		    }
		}
		append value $pvalue
	    }
	}
    }

    set params {}
    dict for {key pinfo} $info[set info {}] {
	dict update pinfo encoding encoding value value {}
	if {[info exists encoding]} {
	    set value [string map {% {\x}} $value[set value {}]]
	    set value [subst -novariables -nocommands $value[set value {}]]
	    set value [::encoding convertfrom $encoding $value]
	}
	dict set params $key $value
    }
    return $params
}


proc ::mime::header::serialize {name value params} {
    variable notattchar_re
    set lname [string tolower $name]

    # to do: check key for conformance
    # to do: properly quote/process $value for interpolation
    if {[regexp {[^\x21-\x39\x3b-\x7e]} $name]} {
	error [
	    list {non-printing character or colon character in header name} $name]
    }
    if {[regexp {[^\t\x20-\x7e]} $value]} {
	error [
	    list {non-printing character in header value}]
    }

    switch $lname {
	content-id - message-id {
	    set value <$value>
	}
    }

    set res "$name: $value"

    if {[llength $params] % 2} {
	set extra [lindex $params end]
	set params [lreplace $params[set params {}] end end]
    } else {
	set extra {}
    }
    foreach {key value} $params {
	if {[regexp $notattchar_re $key]} {
	    error [list {illegal character found in attribute name}]
	}
	set len [expr {[string length $key]} + 1 + [string length $value]]
	# save one byte for the folding white space continuation space
	# and two bytes for "; "
	if {$len > 73 || ![regexp {[^-!#$%&'*+,.\w`~^@{}|]+$} $value]} {
	    # save two bytes for the quotes
	    if {$len <= 71 && ![regexp {[^\x20-\x7e]} $value]} {
		set value "[string map [list \\ \\\\ \" \\\"] $value[set value {}]]"
		append res "\n\t; $key=$value"
	    } else {
		set value [::encoding convertto utf-8 $value]

		regsub -all -- $notattchar_re $value {[format %%%02X [scan "\\&" %c]]} value
		set value [subst -novariables $value]

		set partnum 0
		set start 0
		set param $key*$partnum*=utf-8''
		while {$start < [string length $value]} {
		    # subtract one from the limit to ensure that at least one byte
		    # is included in the part value
		    if {[string length $param] > 72} {
			error [list {parameter name is too long}]
		    }
		    set end [expr {$start + 72 - [string length $param]}]
		    set part [string range $value $start $end]
		    incr start [string length $part]
		    append res "\n\t; $param$part"
		    set param $key*$partnum=
		    incr partnum
		}
	    }
	} else {
	    append res "\n\t; $key=$value"
	}
    }
    foreach item $extra {
	append res "\n\t; $item"
    }
    return $res
}


# ::mime::header::set --
#
#    mime::header::set 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.
#       ?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
    # FRINK: nocheck
    upvar 0 $token state
    upvar 0 \
	state(contentid) contentid \
	state(contentidlower) contentidlower \
	state(header) header \
	state(headerinternal) headerinternal \
	state(headerinternallower) headerinternallower \
	state(headerlower) headerlower \
	state(messageid) messageid \
	state(messageidlower) messageidlower
    parse $token

    set params {}
    switch [llength $args] {
	1 - 3 {
	    set args [lassign $args[set args {}] params]
	}
	0 - 2 {
	    # carry on
	}
	default {
	    error [list {wrong # args}]
	}
    }
    array set options [list -mode write]
    array set options {}
    dict for {opt val} $args {
	switch $opt {
	    -mode {
		set options($opt) $val
	    }
	    default {
		error [list {unknon option} $opt]
	    }
	}
    }

    set lower [string tolower $key]
    set result {}
    switch $options(-mode) {
	append - write {
	    switch $lower {
		content-md5
		    -
		content-transfer-encoding
		    -
		mime-version
		    -
		content-type {
		    if {!$internal} {
			switch $lower {
			    default {
				if {[exists $token $lower]} {
				    lassign [get $token $lower] values params1
				    if {$value ni $values} {
					error "key $key may not be set"
				    }
				}
			    }
			}
		    }
		    switch $lower {
			content-type {
			    if {[string match multipart/* $value]
				&&
				![dict exists $params boundary]
			    } {
				dict set params boundary [boundary]
			    }
			}
			default {
			    #carry on
			}
		    }
		}
	    }
	    if {$options(-mode) eq {write}} {
		if {[dict exists $header $key]} {
		    dunset header $key
		}
		if {[dict exists $headerlower $lower]} {
		    dunset headerlower $lower
		}

		if {[dict exists headerinternal $key]} {
		    dunset headerinternal $key
		}
		if {[dict exists $headerinternallower $lower]} {
		    dunset headerinternallower $lower
		}

	    }
	    set newval [list $value $params]
	    if {$internal} {
		switch $lower {
		    content-id {
			lappend contentid $key $newval 
			lappend contentidlower $lower $newval 
		    }
		    message-id {
			lappend messageid $key $newval 
			lappend messageidlower $lower $newval 
		    }
		    default {
			lappend headerinternal $key $newval 
			lappend headerinternallower $lower $newval 
		    }
		}
	    } else {
		lappend header $key $newval 
		lappend headerlower $lower $newval 
	    }
	}
        delete {
            dunset headerlower $lower
	    dunset headerinternallower $lower
	    dunset header $key
	    dunset headerinternal $key
        }

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

    return $result
}


proc ::mime::header::setinternal args {
    variable internal 1
    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
#           a dictionary of headers
#               with possibliy-redundant keys
#
#       -params
#           a dictionary of parameters
#           with possibly-redundant keys
#
#
#       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 -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) {}
    set state(headerinternal) {}
    set state(headerinternallower) {}
    set state(headerlower) {}
    set state(headerparsed) 0
    set state(isstring) 0 
    set relax [dict create finalboundary 0]
    set state(messageid) {}
    set state(messageidlower) {}
    set state(root) $token
    set state(sawclosing) 0
    set state(spec) mime
    set state(size) 0
    set state(usemem) 0 
    set state(version) 1.0
	set state(warnings) {}

    set userparams 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 {
	    -addcontentid {
		set state(addcontentid) [expr {!!$value}]
	    }
	    -addmessageid {
		set state(addmessageid) [expr {!!$value}]
	    }
	    -addmimeversion {
		set state(addmimeversion) [expr {!!$value}]
	    }
	    -boundary {
		set state(boundary) $value
	    }
            -canonical {
		set canonicalP 1
		set type [string tolower $value]
            }
	    -chan {
		checkinputs
		addchan $token [uplevel 1 [list namespace which $value]]
	    }

	    -close {
		set state(closechan) [expr {!!$value}]
	    }

            -encoding {
		set value [string tolower $value[set value {}]]

                switch $value {
                    7bit - 8bit - binary - quoted-printable - base64 {
                    }

                    default {
                        error "unknown value for -encoding $state(encoding)"
                    }
                }
                set state(encoding) [string tolower $value]
            }

	    -file {
		checkinputs
		addchan $token [tcllib::chan::base .new [
		    info cmdcount]_chan [open $value]]
	    }

            -headers {
		# process headers later in order to assure that content-id and
		# content-type occur first
		if {[info exists headers]} {
		    error [list {-headers option occurred more than once}]
		}
                if {[llength $value] % 2} {
                    error [list -headers expects a dictionary]
                }
		set headers $value
            }

            -params {
		if {$userparams} {
		    error [list {-params can only be provided once}]
		}
		set userparams 1
                if {[llength $value] % 2} {
		    error [list -params expects a dictionary]
                }
		foreach {mixed pvalue} $value {
		    set lower [string tolower $mixed]
		    if {[dict exists params $lower]} {
			error "the $mixed parameter may be specified at most once"
		    }

		    dict set params $lower $pvalue
		}
            }

            -parts {
		checkinputs
		set canonicalP 1
                set state(parts) $value
            }

	    -relax {
		relax $token $value 1 
	    }

            -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
			set state(addmimeversion) 1
			set state(spec) mime
		    }
		    default {
			error [list {unknown protocol}]
		    }
		}
	    }

	    -strict {
		relax $token $value [expr {!$value}]
	    }

	    -string {
		checkinputs
		addchan $token [tcllib::chan::base .new [
		    info cmdcount]_chan [::tcl::chan::string $value]]
	    }

	    -usemem {
		set state(usemem) [expr {!!$value}] 
	    }

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

    if {![info exists inputs]} {
	error [list {specify exactly one of} {-chan -file -parts -string}]
    }

    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/*
		    -
		audio/*
		    -
		video/* {
		    error "-canonical $content and -parts do not mix"
		}

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

        set state(version) 1.0
        return
    }

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

}


proc mime::makeseekable token {
    upvar 0 $token state
    upvar 0 state(bodychan) bodychan state(fd) inputchan 
    set chan2 [::tcllib::chan::base [info cmdcount]_chan [file tempfile]]
    chan configure $chan2 -translation binary
    chan copy $inputchan $chan2
    incr size [tell $chan2]
    seek $chan2 0
    close $inputchan
    set inputchan [::tcllib::chan::base [info cmdcount]_chan $chan2]
    return
}


# ::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::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 _ {
    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
	$bodychan .init [file tempfile]
    }
    if {[dict exists $params charset]} {
	set charset [reversemapencoding [dict get $params charset]]
	if {$charset eq {}} {
		upvar 0 state(warnings) warnings
		lappend warnings [list {unknown charset} [
		dict get $params charset] {using binary translation instead}]
	    # but still do line automatic translation
	    $fd configure -encoding binary -translation auto
	} else {
	    $fd configure -encoding [reversemapencoding [dict get $params charset]]
	}
    }
    $bodychan configure -translation binary

    if {[info exists state(boundary)]} {
	set gets [list mimegets $token line]
	set iseof {$eof}
    } else {
	set gets [list $fd gets line]
	set iseof {[$fd eof] || $eof}
    }

    if {[string match multipart/* $content]} {
	set state(parts) {}

	dict update params boundary boundary {}
	if {![info exists state(boundary)]} {
	    if {![info exists boundary]} {
		error "boundary parameter is missing in $content"
	    }

	    if {[string trim $boundary] eq {}} {
		error "boundary parameter is empty in $content"
	    }
	}

	while 1 {
	    if $iseof {
		break
	    }
	    if {![llength $state(parts)]} {
		set x [{*}$gets]
		if {$x == -1} {
		    break
		}
	    }
	    if {[string first --$boundary-- $line] >= 0} {
		    # No starting boundary was seen prior to the terminating boundary.
		    # Interpret this to mean there are no more parts, and also attempt
		    # to make a part from data already seen.

		    # 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
		# seen so far.
		if $iseof {
		    $bodychan puts -nonewline $line
		} else {
		    $bodychan puts $line
		}
		set size [expr {$size + [
		    string length $line] + 1}]
	    }
	}
	if {!$state(sawclosing) && ![dict get $relax finalboundary]} {
	    error {end-of-string encountered while parsing multipart/form-data}
	}
    } else {
	if {[info exists state(boundary)]} {
	    while 1 {
		set x [{*}$gets]
		if {$x == -1} {
		    break
		} else {
		    if {[incr linesout] > 1} {
			$bodychan puts -nonewline \n$line
		    } else {
			$bodychan puts -nonewline $line
		    }
		    set size [expr {$size + [
			string length $line] + 1}]
		}
	    }
	} else {
	    $fd copy [$bodychan configure -chan]
	    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
	}
    }
    return
}


# ::mime::property --
#
#   mime::property 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 {before decoding} 
#
#   The "parts" property is present only if the MIME part has
#   subordinates.
#
#   If mime::property 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 dictionary of properties is returned.
#
# Arguments:
#       token      The MIME token to parse.
#       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]
        }

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

            return $names
        }

        content
            -
        params {
	    return [set $property]
        }

        encoding {
            return $state($property)
	}
        parts {
            if {![info exists state(parts)]} {
                error [list not a multipart message]
            }

            return $state(parts)
        }

        size {
            return [getsize $_]
        }

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


# ::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 dictionaries, for each
#       address specified in the argument.
#
#    Each dictionary 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 dictionaries, one element for each address
#       specified in the argument.

proc ::mime::parseaddress {string args} {
    variable mime
    set token [namespace current]::[incr mime(uid)]
    # FRINK: nocheck
    upvar 0 $token state

    if {[llength $args]} {
	set string2 [lindex $args end]
	set args [list $string {*}[lrange $args 0 end-1]]
	set string $string2
    }
    dict for {opt val} $args {
	switch $opt {
	    hostname {
		set state(default_host) $val
	    }
	}
    }

    catch {mime::parseaddressaux $token $string} result copts

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

    return -options $copts $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 dictionary 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 dictionaries, one for each address specified in the
#    argument.

proc ::mime::parseaddressaux {token string} {
    # FRINK: nocheck
    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 {
			if {![info exists state(default_host)]} {
				set state(default_host) [info hostname]
			}
            set tail @$state(default_host)
        }
        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::parselexeme --
#
#    Used to implement a lookahead parser.
#

        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

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

    return [set state(lastC) LX_ATOM]
}




















































































































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


proc ::mime::relax {token args} {
    upvar 0 $token state
    upvar 0 state(relax) relax
    foreach {key val} $args {
	switch $key {
	    all {
		dict set relax finalboundary 1
	    }
	    finalboundary {
		dict set relax $key [expr {!!$val}]
	    }
	    default {
		error [list {unknown value for -relax} $key {should be one of} {
		    all finalboundary
		}]
	    }
	}
    }
}


# ::mime::serialize --
#
#    Serializes a message to a value or a 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::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.
		#
		# 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 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)} {
	    set transforms [setencoding $token $channel]


	    $state(fd) seek 0

	    $state(fd) copy [$channel $ chan]
	    while {[incr transforms -1] >= 0} {
		$channel $channel
	    }



	} else {
	    $state(bodychan) seek 0



	    $state(bodychan) copy [$channel $ chan]
	}
    }

    $channel flush

    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
}


proc ::mime::setencoding {token chan} {
    upvar 0 $token state

    set transforms 0

    if {[info exists state(encoding)]} {
	switch $state(encoding) {
	    base64 {
		package require tcl::transform::base64
		::tcl::transform::base64 [$chan configure -chan]
		incr transforms
	    }
	    quoted-printable {
		package require {tcl transform qp}
		::tcl::transform::qp [$chan configure -chan]
		incr transforms
	    }
	    7bit - 8bit - binary - {} {
		# Bugfix for [#477088]
		# Go ahead, leave chunk alone
	    }
	    default {
		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
	    }
	}
    }
    set encoding [reversemapencoding $mcharset]
    if {$encoding eq {}} {
	$chan configure -translation binary
    } else {
	$chan configure -encoding $encoding 
    }
    return
}


# ::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 {} {
    set id [base64 -mode encode -- [
	sha2::sha256 -bin [expr {rand()}][pid][clock clicks][array get state]]]
    return $id
}


# ::mime::unquote
#
#    Removes any enclosing quotes and unquotes quoted pairs in a string.
proc ::mime::unquote string {
    set qstring [string match "\"*" $string]
    regsub -all {\\(.)} $string[set string {}] {\1} string 

    # this isn't exactly right because it doesn't validate that a quote at the
    # end of the string wsan't just replaced as part of a quoted pair.
    if {$qstring} {
	regexp {^["]?(.*?)["]?$} $string[set string {}] -> string
	# a quote for vim syntax coloring: "
    }
    return $string
}


# ::mime::word_encode --
#
#    Word encodes strings as per RFC 2047.
#
# Arguments:
#       charset   The character set to encode the message to.

        error [list {unknown charset} $charset]
    }

    if {$encodings($charset) eq {}} {
        error [list {invalid charset} $charset]
    }

    if {$method ne {base64} && $method ne {quoted-printable}} {
        error [list {unknown method} $method {must be one of} \
	    {base64 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

            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 [list maxlength $options(-maxlength) \
			    {too short for chosen charset and encoding}]
                    }
                    if {
			$length + [string length $qp_enc_char] > $maxlength

    }

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

	namespace eval [namespace parent] {
	    namespace export *
	}
	namespace import [namespace parent]::getTransferEncoding
	namespace import [namespace parent]::parselexeme
	namespace import [namespace parent]::reversemapencoding
	namespace import [namespace parent]::uniqueID
	namespace import [namespace parent]::unquote
	namespace eval [namespace parent] [
	    list namespace export -clear {*}$saved
	]
    } [namespace current]]
}


## One-Shot Initialization

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

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

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

    set formats1 {
	{%a, %d %b %Y %H:%M:%S %z}
	{%a, %d %b %Y %H:%M %z}
	{%a , %d %b %Y %H:%M:%S %z}
	{%a , %d %b %Y %H:%M %z}
	{%d %b %Y %H:%M:%S %z}
	{%d %b %Y %H:%M %z}
    }

    set timeformats [list {*}$formats1 {*}[string map {%Y %y} $formats1]]

    # 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
# genere totes output for errors.  No output means no errors were found.
#
# Copyright (c) 2000 by Ajuba Solutions
# Copyright (c) 2018 by Poor Yorick
# All rights reserved.
#
# RCS: @(#) $Id: mime.test,v 1.31 2012/02/23 17:35:17 andreas_kupries Exp $

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

source [file join \

    use namespacex/namespacex.tcl namespacex
}
testing {
    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
--bndry\r

Message-ID: <ac7319c5a872e80af7fe7fb7efa5fd7ac7356ec74eb4410d23287b6cf7fa0129@|>\r
Content-ID: <8e84af0326e6170dfb2720eeb49b23337250b571c563247605c9ec6910772d2c@|>\r
Content-Type: text/plain\r
\r
jack and jill\r
--bndry\r

Message-ID: <ab7737bc7bbff0d4096ba7e130fd69e77ea5a1e1d7618d17e15f4914bae8600f@|>\r
Content-ID: <119c9ae6f9ca741bd0a76f87fba0b22cab5413187afb2906aa2875c38e213603@|>\r
Content-Type: text/plain\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
\r
--bndry\r

Message-ID: <ac7319c5a872e80af7fe7fb7efa5fd7ac7356ec74eb4410d23287b6cf7fa0129@|>\r
Content-ID: <8e84af0326e6170dfb2720eeb49b23337250b571c563247605c9ec6910772d2c@|>\r
Content-Type: text/plain\r
\r
jack and jill\r
--bndry\r

Message-ID: <ab7737bc7bbff0d4096ba7e130fd69e77ea5a1e1d7618d17e15f4914bae8600f@|>\r
Content-ID: <119c9ae6f9ca741bd0a76f87fba0b22cab5413187afb2906aa2875c38e213603@|>\r
Content-Type: text/plain\r
\r
james\r
--bndry--\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)}