Tcl Library Source Code

#! /usr/bin/env tclsh

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


proc .init {_ channame args} {
    $_ .vars chan close
    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/env tclsh

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


variable buf bufcount eof getslimit

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]
}
.my .method .init


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
}
.my .method configure


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


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
    }
}
.my .method gets



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
}
.my .method read


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 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 {
	getslimit .new chan1 [::tcl::chan::memchan]
	chan1 configure -getslimit 33
	chan1 configure -getslimit
    } -cleanup {
	rename chan1 {}
    } -result 33


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


    test getslimit-exceeded {
    } -body {
	getslimit .new chan1 [::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 {
	getslimit .new chan1 [::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 {chan base}
    ::tcllib::chan::base .new ::tcllib::chan::getslimit
    ::tcllib::chan::getslimit .specialize
    ::tcllib::chan::getslimit .eval [list ::source $dir/getslimit.tcl]
    namespace eval ::tcllib::chan {
	namespace export getslimit
    }
    package provide {chan getslimit} 0.1
}} $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]

#! /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 $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]

[para]

Provides commands to create and manipulate Internet messages.

[list_begin definitions]


[call [cmd ::mime::initialize] [opt [arg options]]]









Parses a message and returns a token for the message.  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 [cmd ::mime::body] [arg token] [opt [option -decode]] [opt "[option -blocksize] [arg octets]"]"]

Sets to [const 0] the cursor for the channel hodling the body of the message
corresponding to [arg token] 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 [cmd ::mime::serialize] [arg token] [opt [option -level]] [
    opt "[option -chan] [arg channel]"]]

Returns the serialization of the message corresponding to [arg token].  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::parseaddress] [arg addresses]]

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

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


#     cid: last child-id assigned



namespace eval ::mime {

    variable mime
    array set mime {uid 0 cid 0}

    namespace export {*}{
	datetime finalize getbody header initialize mapencoding parseaddress
	property reversemapencoding serialize setheader uniqueID
    }
}


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

        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 token {
    upvar 0 $token state

    upvar 0 state(bodychandecoded) bodychandecoded
    parsepart $token
    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 $token $bodychandecoded
	}
	$bodychandecoded seek 0




	return $bodychandecoded
    }
}

proc ::mime::body_raw token {

    upvar 0 $token state
    parsepart $token





































































    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



    namespace export *





    namespacex import [namespace parent] body_decoded decoded body_raw raw




















}


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

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

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

    if {[info exists state(encoding)]} {
	return $state(encoding)
    }
    lassign [contenttype $token] 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 token {
    upvar 0 $token state
    upvar 0 state(parts) parts
    parsepart $token
    if {[info exists parts]} {
	foreach part $parts {
	    # use message-id here, not content-id, to account for header info
	    # in the parts
	    append ids [header get $part message-id] 
	}
	set id [::sha2::sha256 -hex $ids]
    } else {
	set chan [body decoded $token]
	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)
    }
}

    upvar 0 $token state
    array set options [list -subordinates dynamic]
    array set options $args

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

        dynamic {

        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)
    }
    # FRINK: nocheck
    unset $token
}


proc ::mime::messageid token {
    upvar 0 $token state
    #set unique [uniqueID]
    if {![header exists $token content-id] && $state(addcontentid)} {
	header::setinternal $token Content-ID [contentid $token]
    }
    set sha [::sha2::SHA256Init]
    foreach {key val} [lsort -stride 2 [header::get $token]] {
	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 token {
    # FRINK: nocheck
    upvar 0 $token state
    upvar 0 state(bodychan) bodychan state(fd) inputchan 




    parsepart $token



    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 token {
    upvar 0 $token state


    set encoding [encoding $token]


    # 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 {
    namespace ensemble create -map {
	get get
	exists exists

# ::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 {token {key {}}} {
    # 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 $token]
		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 $token] {}]
		    } else {
			error [list {no such header} $key]
		    }
		}
		message-id {
		    if {![dict size $messageidlower]} {
			setinternal $token Message-ID [
			    [namespace parent]::messageid $token]
		    }
		    return [dict get $messageidlower message-id]
		}
		mime-version {
		    return [list $state(version) {}]
		}
		default {
		    set res {}
		    if {[dict exists $headerinternallower $lower]} {

    }
}


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

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

            }

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

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

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

    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 {token 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"

    dict for {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"
	}
    }
    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:

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

	    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]

		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 {

proc ::mime::initialize args {
    variable mime

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

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

# ::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 | 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 {token args} {
    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 canonicalP 0
    set state(cid) 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 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 {
		    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]} {

		}
		header::setinternal $token $name $hvalue
	    }
	}

	lassign [header get $token 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.
#

    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.

    parsepartaux $token
}


proc ::mime::parsepartaux 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 $token] content params

    if {$usemem} {
	set bodychan [tcllib::chan::base .new [info cmdcount]_bodychan [
	    ::tcl::chan::memchan]]
    } else {
	set bodychan [tcllib::chan::getslimit .new [info cmdcount]_bodychan [
	    file tempfile]]
    }
    if {[dict exists $params charset]} {
	set charset [reversemapencoding [dict get $params charset]]
	if {$charset eq {}} {
	    puts stderr [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

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

		    mime::initializeaux $child -chan $bodychan \
			-root $state(root) -boundary $boundary -usemem $usemem
		    parsepart $child
		    
		    lappend state(parts) $child
		    header setinternal $child 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

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


			mime::initializeaux $child -chan $fd \
			    -root $state(root) -boundary $boundary -usemem $usemem
			parsepart $child
			lappend state(parts) $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 $token $bodychan
            variable [set child $token-[incr state(cid)]]




	    mime::initializeaux $child -chan $bodychan -usemem $usemem




































































































































































            set state(parts) $child











	    parsepart $child




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

# Results:
#       Returns the properties of a MIME part

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


    lassign [contenttype $token] content params

    switch $property {
        {} {
            array set properties [list content  $content \
                                       encoding $state(encoding) \

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

        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.

    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 {}} {
	# FRINK: nocheck
	upvar 0 $token state



	set code [catch {mime::serialize_value $token $level} result copts]







	return -options $copts $result
    } else {
	return [serialize_chan $token $chan $level]
    }

}


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

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

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

    set converter {}
    set encoding {}
    if {![info exists state(parts)]} {
        if {$state(canonicalP)} {

	    set encoding [getTransferEncoding $token]

            if {$encoding ne {}} {
                $channel puts "Content-Transfer-Encoding: $encoding"














            }
        }
    }

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



    if {[info exists state(parts)]} {



























	lassign [contenttype $token] content params
	set boundary [dict get $params boundary]

	switch -glob $content {
	    message/* {
		$channel puts {}
		foreach part $state(parts) {
		    mime::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
		    mime::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 {token level} {
    set chan [::tcllib::chan::base .new [info cmdcount]_serialize_value [
	tcl::chan::memchan]]
    $chan configure -translation crlf
    serialize_chan $token $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 {token chan} {
    upvar 0 $token state
    lassign [contenttype $token] content params
    if {[dict exists $params charset]} {
	set mcharset [dict get $params charset]
    } else {
	switch $state(spec) {
	    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.
#

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

    use md5/md5x.tcl md5

    use namespacex/namespacex.tcl namespacex
}
testing {
    useLocal mime.tcl mime
}

package require {chan base}

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

namespace import mime::*

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



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}::*] {
	catch [list mime finalize $name]
    }
    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 [::mime::initialize {*}$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 [::mime::initialize {*}$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 {initialize with no args} {cleanly {
    catch {initialize} res
    subst $res
}} {{specify exactly one of} {-chan -file -parts -string}}


test mime-2.1 {Generate a MIME message} {cleanly {
   
    set tok [initialize -canonical Text/plain -string {jack and jill}]
    set msg [mime::serialize $tok]


}} "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 [[mime::body raw $tok] read]
	mime::finalize $tok

	# 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 [initialize -canonical Text/plain -string {jack and jill}]
    set tok2 [initialize -canonical Text/plain -string james]
    set bigTok [mime::initialize -canonical Multipart/MyType \
	    -params [list MyParam foo boundary bndry] \
	    -headers [list Content-Description {Test Multipart}] \
	    -parts [list $tok1 $tok2]]
    mime::serialize $bigTok


}} "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 [initialize -canonical Text/plain -string {jack and jill}]
    set tok2 [initialize -canonical Text/plain -string james]
    set bigTok [mime::initialize \
	    -params [list MyParam foo boundary bndry] \
	    -headers [list Content-Description {Test Multipart}] \
	    -parts [list $tok1 $tok2]]
    mime::serialize $bigTok

}} "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 [mime::initialize -string $msg]
    [mime::body raw $tok] 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"

}

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

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


test mime-3.3 {Try to parse a totally invalid message} {
	set token [mime::initialize -string blah]
    catch {mime::header get $token} 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 [mime::initialize -string $msg1]
    catch {[mime::body raw $tok] read} err1
    catch {mime::serialize $tok} 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}

    set token [mime::initialize -string $msg2]
    catch {mime::header get $token} 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}

    set tok [mime::initialize -string $msg3]
    catch {[mime::body raw $tok] read} err3
    catch {mime::serialize $tok} err3a
    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 [mime::property $tok parts]]
	    set ctok [lindex [mime::property $tok parts] 0]
	    lappend res [dictsort [mime::property $tok]]
	    lappend res [dictsort [mime::property $ctok]]
	    mime::finalize $tok
	    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 [mime::property $tok 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 [mime::property $tok parts] 0]
	    lappend res [dictsort [mime::property $tok]]
	    lappend res [dictsort [mime::property $ctok]]
	    mime::finalize $tok
	    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 [mime::initialize -string $msg]
    [mime::body decoded $tok] 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 [mime::initialize -string $msg]
    [mime::body decoded $tok] 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 [mime::initialize -string $msg]
    [mime::body decoded $tok] 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 [mime::initialize -string $msg]
    lappend res [mime::header get $tok content-type]


    lappend res [[mime::body decoded $tok] configure -encoding]
    catch {[mime::body decoded $tok] 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\""
    mime::qp::encode $str1
}} "foo=21=22\t barbaz =24 =60 =7B =23 jack and jill went up a hill to fetch a=\n pail of water. Jack fell down and said =21=22=23=24=40=5B=5C=5D=5E=60=7B=\n=7C=7D=7E =20\nJill said, =22Oh my=22"


test mime-4.2 {Check that encode/decode yields original string} {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 [mime::qp::encode $str1]
    set dec [mime::qp::decode $enc]
    string equal $dec $str1
}} 1


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


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


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


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


test mime-4.7 {Test qp::encode/decode in encoded_word mode} {cleanly {
    set enc [mime::qp::encode {jack and jill went up the hill} 1]
    mime::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 {
    mime::qp::encode 1and1=2 1
}} 1and1=3D2

test mime-4.9 {Test qp::encode in encoded_word mode with tabs and spaces} {cleanly {
    mime::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 {
    mime::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 {
    mime::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 {
    mime::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 {
    mime::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 {
    mime::word_encode iso8859-1 quoted-printable {Test de contrôle effectué}
}} =?ISO-8859-1?Q?Test_de_contr=F4le_effectu=E9?=

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

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

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

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

set ::env(TZ) UTC0

--------------090305080603000703000106--
} mail_part]
    set token [mime::initialize -file $in]
    set allparts [mime::property $token parts]
    set attachment [lindex $allparts 1]

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

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

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

    set msg "MIME-Version: 1.0
Content-Type: text/plain\r
\r
so plain
"

    set tok [mime::initialize -string $msg]
    [mime::body raw $tok] read 
} "so plain\n"

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

test mime-14.0 {cleanly {
	hostname argument to parseaddress
}} {

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

    lappend res $msg
    set mime2 [mime::initialize -string $msg]
    lappend res [mime::header get $mime2]
    return $res

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

]


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

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


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

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




testsuiteCleanup
set [namespace current]::done 1
return
}

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

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

#! /usr/bin/env tclsh

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


namespace eval ::mime::qp {}

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

    if {$encoded_word} {
        # Special processing for encoded words (RFC 2047)
        set regexp {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF\x09\x5F\x3F]}
	lappend mapChars { } _
    } else {
        set regexp {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]}
    }
    regsub -all -- $regexp $string {[format =%02X [scan "\\&" %c]]} string

    # Replace the format commands with their result

    set string [subst -novariables $string]

    # soft/hard newlines and other
    # Funky cases for SMTP compatibility
    lappend mapChars " \n" =20\n \t\n =09\n \n\.\n =2E\n "\nFrom " "\n=46rom "

    set string [string map $mapChars $string]

    # Break long lines - ugh

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

                    # Don't break in the middle of a code

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

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

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

    set lastChar [string index $result end]
    if {$lastChar eq { }} {
        set result [string replace $result end end =20]
    } elseif {$lastChar eq "\t"} {
        set result [string replace $result end end =09]
    }

    return $result
}


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

proc ::mime::qp::decode {string {encoded_word 0}} {
    # 8.1+ improved string manipulation routines used.
    # Special processing for encoded words (RFC 2047)

    if {$encoded_word} {
        # _ == \x20, even if SPACE occupies a different code position
        set string [string map [list _ \u0020] $string]
    }

    # smash the white-space at the ends of lines since that must've been
    # generated by an MUA.

    regsub -all -- {[ \t]+\n} $string \n string
    set string [string trimright $string " \t"]

    # Protect the backslash for later subst and
    # smash soft newlines, has to occur after white-space smash
    # and any encoded word modification.

    #TODO: codepath not tested
    set string [string map [list \\ {\\} =\n {}] $string]

    # Decode specials

    regsub -all -nocase {=([a-f0-9][a-f0-9])} $string {\\u00\1} string

    # process \u unicode mapped chars

    return [subst -novariables -nocommands $string]
}


package provide {mime qp} 1.7

                lappend header($senderL) $aprops(address)
            }
        }
    }

    # We're done parsing the arguments.

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

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

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

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

    }

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


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

    # server.
    set token [initialize -debug $debugP -client $client \
		                -maxsecs $maxsecs -usetls $tlsP \
                                -multiple $bccP -queue $queueP \
                                -servers $servers -ports $ports \
                                -tlspolicy $tlspolicy -tlsimport $tlsimport \
                                -username $username -password $password]


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

    set code [catch {
	sendmessageaux $token $part $sender $vrecipients $aloP } result]

    set ecode $errorCode
    set einfo $errorInfo

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

    if {($code == 0) && ($bccP)} {
        set inner [::mime::initialize -canonical message/rfc822 \

        }

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


        set code [catch { sendmessageaux $token $outer \

    }

    # Destroy SMTP token 'cause we're done with it.
    
    catch { finalize $token -close $status } copts cres

    # Restore provided MIME object to original state (without the SMTP headers).
   
    foreach {key val} [::mime::header get $part] {
        mime::header set $part $key "" -mode delete
    }
    foreach {key value} $savedH {
	::mime::header set $part $key {*}$value -mode append
    }

    return -options $copts $cres
}

# ::smtp::sendmessageaux --
#
#	Sends a mime object (containing a message) to some recipients using an
#       existing SMTP token.
#

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

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

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

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

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

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

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

#! /usr/bin/env tclsh

# copyright 2018 Poor Yorick

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

testsNeedTcl     8.5
testsNeedTcltest 1.0-

testing {
    useLocal smtp.tcl smtp
}

package require nettool
package require smtpd

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

proc accept token {
    variable result
    set headers [::mime::header get $token]
    lappend result [lsort [dict keys $headers]]
    lappend result [::mime::header get $token From]
    ::mime::finalize $token
    return
}


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

    testsuiteCleanup
    set done 1
    return
}

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

# # ## ### ##### ######## ############# ######################
## Requisites

package require Tcl 8.5  ; # namespace ensembles, {*}

namespace eval ::namespacex {
    namespace export add hook import info normalize strip state
    namespace ensemble create

    namespace eval hook {
	namespace export add proc on next
	namespace ensemble create

	# add - hook a command prefix into the chain of unknown handlers for a

        return -code $rc $result
    }
}

# # ## ### ##### ######## ############# ######################
## Implementation :: Info - Visible API


proc ::namespacex::import {from args} {
    set upns [uplevel 1 {namespace current}]
    if {![string match ::* $from]} {
	set from $upns::$from[set from {}]
    }
    set orig [namespace eval $from {namespace export}]
    try {
	namespace eval $from {namespace export *}
	set tmp [namespace current]::[::info cmdcount]
	namespace eval $tmp [list ::namespace import ${from}::*]
	if {[llength $args] == 1} {
	    lappend args [lindex $args 0]
	}
	dict size $args
	foreach {old new} $args {
	    rename ${tmp}::$old ${upns}::$new
	}
	namespace delete $tmp
    } finally {
	namespace eval $from [list ::namespace export -clear {*}$orig]
    }
    return
}


proc ::namespacex::info::allvars ns {
    set ns [uplevel 1 [list [namespace parent] normalize $ns]]
    ::set result [::info vars ${ns}::*]
    foreach cns [allchildren $ns] {
	lappend result {*}[::info vars ${cns}::*]
    }

Returns the mime type of the uploaded file.

[def "[option -data] [arg name]"]

Returns the contents of the file.

[def "[option -server] [arg name]"]


Returns the name of a channel routine for the contents of the field named [arg

name].

[list_end]


[call [cmd ::ncgi::query] [arg session] [cmd parse]]

Returns the parsed query data as a multidict.

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

# We use newer string routines
package require Tcl 8.6
package require {chan base}
package require fileutil ; # Required by importFile.
package require mime
package require uri

package provide ncgi 1.5.0

namespace eval ::ncgi {

#
# Side Effects:
#	Outputs a normal header

proc ::ncgi::header {token {type text/html} args} {
    namespace upvar $token cookieOutput cookieOutput
    set mimeout [mime::initialize -canonical $type -addcontentid 0 \
	-addmimeversion 0 -addmessageid 0  -string {}]
    foreach {n v} $args {
	mime::header set $mimeout $n $v {}
    }
    if {[info exists cookieOutput]} {
	foreach line $cookieOutput {
	    mime::header set $mimeout Set-Cookie $line {}
	}
    }
    mime::serialize $mimeout -chan ${token}::stdout
    ${token}::stdout flush
}


# ::ncgi::importFile --
#
#   get information about a file upload field
#
# Arguments:
#   cmd         one of '-server' '-client' '-type' '-data'
#   var         cgi variable name for the file field

# Results:
#   -server returns the name of the file on the server: side effect
#      is that the file gets stored on the server and the 
#      script is responsible for deleting/moving the file
#   -client returns the name of the file sent from the client 
#   -type   returns the mime type of the file
#   -data   returns a channel command for the contents of the file 

proc ::ncgi::importFile {token cmd var {filename {}}} {
    namespace upvar $token mimeparts mimeparts
    if {[form $token exists]} {
	set form [form $token get]
    }

    lassign [dict get $mimeparts $var] mime 

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

    switch -exact -- $cmd {
	-server {

















	    return [mime::body decode $mime]



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

    set parts [mime::property $mime parts]
    trace add variable mime unset [list apply [list token {
	mime::finalize $token
    } $token]]

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

    } elseif {![string match ::* $name]} {
	set name [uplevel 1 {namespace current}]::$name
    }
    set new [namespace eval $name {
	namespace ensemble create
	namespace current
    }]

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

    # normalize $new
    set new [namespace which $new]

    set map [list decode decode encode encode {*}[join [lmap cmdname {
	.namespace all importFile input body cookies delete form get
	header merge method new query redirect setCookie type urlStub

testsNeedTcl     8.4
testsNeedTcltest 2

testing {
    useLocal ncgi.tcl ncgi
}

proc main {} {try {
	global env
	global auto_path

	set     sub_ap $auto_path
	lappend sub_ap $::tcltest::testsDirectory
	set ncgiFile   [localPath ncgi.tcl]
	set futlFile   [tcllibPath fileutil/fileutil.tcl]

			} finally {
				set done 1
			}]
			vwait done
			exit
		}
	}


	proc resetenv {} {
		global env
		foreach varname {
			CONTENT_LENGTH CONTENT_TYPE HTTP_COOKIE HTTPS QUERY_STRING
			REQUEST_METHOD REQUEST_URI SERVER_NAME SERVER_PORT
	} {

			if {[catch {
				source %s
				source %s
				source %s
				ncgi new ncgi1
				ncgi1 redirect %s
				ncgi1 delete
			} err eopts]} {
				puts stderr [dict get $eopts -errorinfo]
				puts $err
			}
		} $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1
		set f [open "|[list $::tcltest::tcltest test1]" r+]
		set res [read $f]
		close $f
		removeFile test1

		set b [genformdatapart field2 "" {another value}]
		set c [genformdatapart the_file_name "; filename=\"C:\\Program Files\\Netscape\\Communicator\\Program\\nareadme.htm\"\nContent-Type: text/html" $bcontent]

		return "$a$b$c--$form_boundary--\n" 
	}



	test ncgi-14.5 {ncgi::multipart--check binary file} {
		set X [genformdata $binary_content]
		withncgi body $X contenttype [genformcontent_type] {
			set content [ncgi1 get the_file_name]
			list [ncgi1 get field1] [ncgi1 get field2] $content
		}
	} [list value {another value} [string map [list \r {}] $binary_content]]

	} text/html


	test ncgi-16.3 {ncgi::importFile -- file contents} {
		global binary_content
		set X [genformdata $binary_content]
		withncgi contenttype [genformcontent_type] body $X  {
			set chan [ncgi1 importFile -data the_file_name]
			set res [$chan read]
			$chan close
			return $res
		}
	} $binary_content


	test ncgi-16.4 {ncgi::importFile -- save file} {
		global binary_content
		set X [genformdata $binary_content]
		withncgi contenttype [genformcontent_type] body $X  {
			set chan [ncgi1 importFile -server the_file_name]

			# get the contents of the local file to verify

			$chan configure -translation binary
			set content [$chan read]
			$chan close

			return $content
		}

	} $binary_content


	test ncgi-16.5 {ncgi::importFile -- save file, given name} {
		global binary_content
		set X [genformdata $binary_content]
		withncgi contenttype [genformcontent_type] body $X {
			set chan [ncgi1 importFile -server the_file_name]

			# get the contents of the local file to verify

			$chan configure -translation binary
			set content [$chan read]
			$chan close

			return $content
		}
	} $binary_content


	test ncgi-16.6 {ncgi::importFile -- bad input} {

		set X "bad multipart data"

			ncgi1 cookies all two
		}
	} {2 3}

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

	testsuiteCleanup

	return
} finally {
	set [namespace current]::done 1
}}

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

package ifneeded tcl::chan::null 1         [list source [file join $dir null.tcl]]
package ifneeded tcl::chan::nullzero 1     [list source [file join $dir nullzero.tcl]]
package ifneeded tcl::chan::random 1       [list source [file join $dir random.tcl]]
package ifneeded tcl::chan::std 1.0.1      [list source [file join $dir std.tcl]]
package ifneeded tcl::chan::string 1.0.3   [list source [file join $dir string.tcl]]
package ifneeded tcl::chan::textwindow 1   [list source [file join $dir textwindow.tcl]]
package ifneeded tcl::chan::variable 1.0.4 [list source [file join $dir variable.tcl]]
package ifneeded tcl::chan::wrapper 1      [list source [file join $dir wrapper.tcl]]
package ifneeded tcl::chan::zero 1         [list source [file join $dir zero.tcl]]
package ifneeded tcl::randomseed 1         [list source [file join $dir randseed.tcl]]

#! /usr/bin/env tclsh

# # ## ### ##### ######## #############
# (C) 2018 Poor Yorick
# # ## ### ##### ######## #############

package require Tcl 8.6

package require coroutine

package require tcl::chan::events

oo::class create ::tcl::chan::wrapper {
    superclass ::tcl::chan::events ; # -> initialize, finalize, watch


    constructor args {
	namespace path [list ::coroutine::util {*}[namespace path]]
	dict size $args
	foreach {key val} $args {
	    switch $key {
		chan {
		    set chan $chan
		}
	    }
	}
	next {*}$args
    }

    method blocking {c m} {
	chan blocking $c $m
    }


    method cget {c o} {
	chan configure $chan $o
    }


    method cgetall c {
	chan configure $chan
    }


    method configure {c o v} {
	chan configure $chan $o $v
    }


    method finalize {} {
	close $chan
	next
    }

    method read {c n} {
	read $c $n
    }

    method seek {c o b} {
	seek $c $o $b
    }

    method write {c d} {
	puts -nonwline $chan $d
    }

    variable chan
}

package provide tcl::chan::wrapper 1

		lappend supported $m
	    }
	}
	return $supported
    }

    method finalize {c} {
	set channel {} ; # Prevent destructor from calling close.
	my destroy
	return
    }

    # # ## ### ##### ######## #############

    variable channel

    return
}

oo::class create ::tcl::transform::base64::implementation {
    superclass tcl::transform::core ;# -> initialize, finalize, destructor

    method write {c data} {
	set res [my Code encodebuf encode $data 3]
	incr encdount [string length $data]
	return $res
    }

    method read {c data} {
	set length [string length $data]
	# remove whitespace to make framing calculations in [Code] accurate
	# to do:  Add a -strict configuration to disallow whitespace?
	regsub -all {[[:space:]]} $data[set data {}] {} data
	set res [my Code decodebuf decode $data 4]
	incr deccount $length 
	return $res
    }

    method flush {c} {
	set data [binary encode base64 $encodebuf]
	set encodebuf {}
	return $data
    }

    method drain {c} {
	set length [string length $decodebuf]
	set data [binary decode base64 $decodebuf]
	if {$data eq {} && $length} {
	    error [list {invalid input after } $deccount]
	}
	set decodebuf {}
	return $data
    }

    method clear {c} {
	set decodebuf {}
	return
    }

    # # ## ### ##### ######## #############

    constructor {} {
	set encodebuf {}
	set deccount 0
	set enccount 0
	set decodebuf {}
	return
    }

    # # ## ### ##### ######## #############

    variable enccount encodebuf deccount decodebuf

    # # ## ### ##### ######## #############

    method Code {bufvar op data n} {
	upvar 1 $bufvar buffer

	append buffer $data

	set n [my Complete $buffer $n]
	if {$n < 0} {
	    return {}
	}

	set chunk [string range $buffer 0 $n]
	set result [binary $op base64 $chunk]

	if {$result eq {} && $chunk ne {}} {
	    error [list {invalid input after} [
		expr {$op eq {encode} ? $enccount : $deccount}]]
	}
	incr n

	set buffer [string range $buffer $n end]
	
	return $result
    }

    method Complete {buffer n} {
	set len [string length $buffer]
	return [expr {(($len / $n) * $n)-1}]
    }

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

package ifneeded tcl::transform::adler32 1     [list source [file join $dir adler32.tcl]]
package ifneeded tcl::transform::base64 1      [list source [file join $dir base64.tcl]]
package ifneeded tcl::transform::counter 1     [list source [file join $dir counter.tcl]]
package ifneeded tcl::transform::crc32 1       [list source [file join $dir crc32.tcl]]
package ifneeded tcl::transform::hex 1         [list source [file join $dir hex.tcl]]
package ifneeded tcl::transform::identity 1    [list source [file join $dir identity.tcl]]
package ifneeded tcl::transform::limitsize 1   [list source [file join $dir limitsize.tcl]]
package ifneeded tcl::transform::observe 1     [list source [file join $dir observe.tcl]]
package ifneeded tcl::transform::otp 1         [list source [file join $dir otp.tcl]]
package ifneeded {tcl transform qp} 0.1        [list source [file join $dir qp.tcl]]
package ifneeded tcl::transform::rot 1         [list source [file join $dir rot.tcl]]
package ifneeded tcl::transform::spacer 1      [list source [file join $dir spacer.tcl]]
package ifneeded tcl::transform::zlib 1.0.1    [list source [file join $dir zlib.tcl]]

#! /usr/bin/env tclsh

# # ## ### ##### ######## #############
# (C) 2018 Poor Yorick

# # ## ### ##### ######## #############

package require {mime qp}
package require tcl::transform::core

namespace eval ::tcl::transform {}

proc ::tcl::transform::qp chan {
    ::chan push $chan [qp::implementation new]
    return

}

oo::class create ::tcl::transform::qp::implementation {
    superclass tcl::transform::core ;# -> initialize, finalize, destructor

    method write {c data} {
	::mime::qp::encode $data
    }

    method read {c data} {
	::mime::qp::decode $data
    }
}

package provide {tcl transform qp} 0.1