Tcl Library Source Code

# (c) 1999-2000 Marshall T. Rose
# (c) 2000      Brent Welch
# (c) 2000      Sandeep Tamhankar
# (c) 2000      Dan Kuchler
# (c) 2000-2001 Eric Melski
# (c) 2001      Jeff Hobbs
# (c) 2001-2008 Andreas Kupries
# (c) 2002-2003 David Welton
# (c) 2003-2008 Pat Thoyts
# (c) 2005      Benjamin Riefenstahl


#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# Copyright (c) 2018-2024 Poor Yorick
#
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# mime.tcl - MIME body parts
#
# Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's
# unpublished package of 1999.


# new string features and inline scan are used, requiring 8.3.
package require Tcl 8.5 9

# Fix for 00d04c4f12l, base64 transchan over a refchan: segmentation fault,
# requires 8.6.9
package require Tcl 8.6.9-

package require {mime qp}
package require namespacex
package require tcl::chan::cat
package provide mime 3.0.0 
package require tcl::chan::memchan
package require tcl::chan::string

    # Warning!
    ##
    # These are a fragile emulations of the more general calling
    # sequence that appears to work with this code here.
    ##
    # The `__ignored__` arguments are expected to be `--` options on
    # the caller's side. (See the uses in `copymessageaux`,
    # `serialize`, `parsepart`, and `getbody`).

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

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

    if {[info exists fd]} {
	error [list {a channel is already present}]
    }

    if {[$chan configure -encoding] ne {binary}} {
	$chan configure -translation auto
    }
    if {[set current [$chan tell]] < 0} {
	set chan [makeseekable $chan]
    }
    incr channels($chan)
    dropchan $token
    set fd $chan
    if {!$state(closechan)} {
	error [
	    list {need permission to close the channel in to make it seekable}]
    }
    return
}


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

    upvar 0 $token state
    upvar 0 state(bodychandecoded) bodychandecoded
    $_ parsepart
    if {[info exists state(parts)]} {
	error [list {not a leaf part} $token]
    }
    if {$state(canonicalP)} { 
	#{to do} {shouldn't this also get decoded?}
	$state(fd) seek 0 
	return $state(fd)
    } else {
	if {![info exists bodychandecoded]} {
	    set bodychandecoded [[::tcllib::chan::base new [
		info cmdcount]_bodydecoded] .init [file tempfile]]
	    $bodychandecoded configure -translation binary

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

    if {[set current [$chan tell]] < 0} {
	set chan [makeseekable $chan]
	set current [$chan tell]
    }
    set chanconfig [$chan configure]
    try {
	set buf {}
	set dataend 0
	while {[set data [$chan read 8192]] ne {} || $buf ne {}} {

		if {!$childpart(addmessageid)} {
		    header::unset $part message-id
		}
	    }
	}
	set id [::sha2::sha256 -hex $ids]
    } else {
	if {[info exists bodychan]} {
	    #use the transfer-encoded form of the body to generate the id so that
	    #each different encoding gets its own id
	    set chan $state(bodychan)
	} else {
	    set chan $state(fd)
	}
	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]]

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

    #set unique [uniqueID]
    if {![header::exists $token content-id] && $state(addcontentid)} {
	header::setinternal $token Content-ID [contentid $_]
    }
    set sha [::sha2::SHA256Init]
    foreach {key val} [lsort -stride 2 [$_ header get]] {
	lassign $val value params
	::sha2::SHA256Update $sha [::encoding convertto utf-8 $key$value]
	foreach {pkey pval} $params {
	    ::sha2::SHA256Update $sha [::encoding convertto utf-8 $pkey$pval]
	}
    }
    set hash [::sha2::SHA256Final $sha]
    binary scan $hash H* hex
    return $hex@|
}

	foreach part $state(parts) {
	    incr size [getsize $part]
	}
    } else {
	set size 0
	if {$state(canonicalP)} {
	    if {[set current [$inputchan tell]] < 0} {
		set inputchan [makeseekable $inputchan]
	    }
	    set current [$inputchan tell]
	    $inputchan seek 0 end
	    set size [$inputchan tell]
	    $inputchan seek $current
	} else {
	    set size $state(size)

#
#    the public interface for initializeaux

proc ::mime::.new args {
    variable mime
    if {[llength $args] % 2} {
	set args [lassign $args[set args {}] name]


    } else {
	set name {}
    }
    set mimeid [incr mime(uid)]
    set token [namespace current]::$mimeid
    if {$name eq {}} {
	set name $token

        return -options $eopts $result
    }
    return $name
}

# ::mime::initializeaux --
#
#    Creates a MIME part and returns the MIME token for that part.
#
# Arguments:
#    args   Args can be any one of the following:
#                  ?-canonical type/subtype
#                  ?-params    {?key value? ...}
#                  ?-encoding value?
#                  ?-headers   {?key value? ...}

    if {[info exists headers]} {
        error "-header requires -canonical"
    }

}


proc mime::makeseekable chan {
    if {[set current [$chan tell]] >= 0} {
        return $chan
    }
    set chan2 [::tcllib::chan::base new [info cmdcount]_chan]
    $chan2 .init [file tempfile] 
    $chan2 configure -translation binary
    $chan copy [$chan2 configure -chan]
    incr size [$chan2 tell]
    $chan2 seek 0
    $chan close

    return $chan2
}


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

    if {[dict exists $params charset]} {
	set charset [reversemapencoding [dict get $params charset]]
	if {$charset eq {}} {
		upvar 0 state(warnings) warnings
		lappend warnings [list {unknown charset} [
		dict get $params charset] {using binary translation instead}]
	    # but still do line automatic translation
	    $fd configure -encoding iso8859-1 -translation auto
	} else {
	    $fd configure -encoding [reversemapencoding [dict get $params charset]]
	}
    }
    $bodychan configure -translation binary

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

		    $child header setinternal Content-Type application/octet-stream
		    break
	    } elseif {[llength $state(parts)] || [string first --$boundary $line] == 0} {
		    # either just saw the first boundary or saw a boundary between parts

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

			set child [.new {} -chan $fd \
			    -root $state(root) -boundary $boundary -usemem $usemem]
			$child parsepart
			lappend state(parts) $child
			lappend state(dynamic) $child
			upvar 0 $child childstate
			set state(sawclosing) $childstate(sawclosing)
			if {$childstate(eof)} break
		    }
	    } else {
		# Accumulate data in case the terminating boundary occurs
		# before 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}]

    } else {
	$channel puts {}
	if {$state(canonicalP)} {
	    set transforms [setencoding $token $channel]
	    $state(fd) seek 0
	    $state(fd) copy [$channel configure -chan]
	    while {[incr transforms -1] >= 0} {
		$channel pop
	    }
	} else {
	    $state(bodychan) seek 0
	    $state(bodychan) copy [$channel configure -chan]
	}
    }

# mime.test - Test suite for TclMIME                     -*- tcl -*-
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2000 by Ajuba Solutions, 2023 AK

# All rights reserved.

# Copyright (c) 2018-2024 Poor Yorick
#
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

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

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

testsNeedTcl     9.0-
testsNeedTcltest 2.0

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

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


proc cleanly args {
    if {![llength $args]} {
	error [list {wrong # args}]
    }
    set script [lindex $args end]
    set args [lrange $args[set args {}] 0 end-1]
    if {[llength $args] % 2} {
	error [list {wrong # args}]
    }
    set ns [info cmdcount]
    set names {}
    set values {}
    while {[llength $args]} {
	set args [lassign $args[set args {}] name value]
	lappend names $name
	lappend values $value
    }
    namespace eval $ns {
	namespace path [namespace parent]
    }







    catch {apply [list $names $script $ns] {*}$values} cres copts
    namespace delete $ns
    return -options $copts $cres
}


proc setup1 {} {
    uplevel 1 {

msg1}

    set tok [.new {} -string $msg1]
    catch {[$tok body raw] read} err1
    catch {$tok serialize} err1a
    list $err1 $err1a
}} "msg1 {MIME-Version: 2.0\r
Message-ID: <7938b12d5fca6dac4d93058a53bd042eb6489fe781dc7c1d9e4d3fb2a0298568@|>\r
Content-ID: <6d940d16b5e44281d818537093e2d718cf63b738bd80db235246918456966ad1@|>\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

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


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



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



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



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

Fran\xE7ois

This is a message in the scribble charset that tcl does not recognise.}
    set tok [.new {} -string $msg]
    lappend res [$tok header get content-type]
    lappend res [[$tok body decoded] configure -encoding]
    catch {[$tok body decoded] read} errmsg
    lappend res $errmsg
}} {{text/plain {charset SCRIBBLE}} iso8859-1 {This is a message in the scribble charset that tcl does not recognise.}}



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

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

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


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

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

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

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

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


test mime-5.33 {Test word_encode with quoted-printable method and -maxlength set to same length as will the result} {cleanly {
    word_encode iso8859-1 quoted-printable 123 -maxlength 20

    11 {(=?ISO-8859-1?Q?a?=x=?ISO-8859-2?Q?_b?=)}
    {(ax b)}
    12 {a         b         c}
    {a         b         c}
    13 {} 
    {}
} {
    test mime-6.$n {Test field_decode (from RFC 2047, part 8)} [
	list cleanly n $n encoded $encoded expected $expected {

	field_decode $encoded
    }] $expected
}

foreach {bug n encoded expected} {
    764702 1 {(=?utf-8?Q?H=C3=BCrz?=)} {(Hürz)}
} {
    test mime-7.$n "Test field_decode (from SF Tcllib bug $bug)" [
	list cleanly encoded $encoded {
	    field_decode $encoded
	}] $expected
}


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


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


cleanly {
    foreach name {file chan} {
	test mime-9.0.$name {Test chunk handling of serialize and helpers} [
	    list cleanly name $name {

	    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] .init [open $mi w]
		chan1 configure -translation binary
		$tok serialize -chan chan1 
		chan1 close

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

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

set ::env(TZ) UTC0
set epoch [clock scan 2000-01-01]
foreach {n stamp date} {
    1     86340 {Sat, 01 Jan 2000 23:59:00 +0000}
    2   5176620 {Tue, 29 Feb 2000 21:57:00 +0000}

    chan1 configure -translation binary
    $attachment serialize -chan chan1 -level 1
    chan1 close

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

BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2

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

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

test mime-14.0 {ticket 5f455d6343} -setup {

    set part  [.new -canonical application/x-simile \
	-headers [list "Content-Description" "Run Status"] \
	-encoding base64 -string "This is a test"]
    set whole [.new -canonical multipart/mixed -parts [list $part]]

    set saved checkmime.msg
    set stm [open $saved w]
    mime::serialize $whole -chan $stm
    close $stm

} -body {
    set stm [open $saved r]
    set str [read $stm]
    close $stm
    set restore [.new -string $str]
} -cleanup {
    $restore .destroy
    unset part whole saved stm str
} -match glob -result "::mime::*"

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

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



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

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


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

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


set char [encoding convertfrom utf-8 \xE3\x81\xAF]
test mime-16.1 {} {

    set res {}
    set mime [.new {} -canonical text/plain -string {dawg one}]
    $mime header set Content-Disposition attachment [list param1 $char]
    set msg [$mime serialize]
    lappend res $msg
    set mime2 [.new {} -string $msg]
    lappend res [$mime2 header get]
    return $res

} [list "MIME-Version: 1.0\r
Message-ID: <056eb988475329e0d14defde74ba007f9b56e6f0d3a04ad773528dec1336ff26@|>\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 {<056eb988475329e0d14defde74ba007f9b56e6f0d3a04ad773528dec1336ff26@|> {}} \
    Content-Disposition [list attachment [list param1 $char]]]

]


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

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


test {mime cookie serialization} {
	cookie serialization
} {
	set mime [.new {} -spec http -string {}]
	$mime cookie set one two
	set res [$mime serialize]
	$mime .destroy
	return $res

\t; HttpOnly\r
\r
"



testsuiteCleanup

return
}

after 0 [list ::coroutine [info cmdcount]_main ::apply [list {} {
    variable done
    catch main cres copts
    set done [list $copts $cres]
} [namespace current]]]
vwait [namespace current]::done
return -options {*}$done

if {![package vsatisfies [package provide Tcl] 8.6.9 9]} return
package ifneeded smtp 1.5.2 [list source [file join $dir smtp.tcl]]

package ifneeded mime 3.0.0 [list source [file join $dir mime.tcl]]
package ifneeded {mime qp} 1.7 [list source [file join $dir qp.tcl]]

# ncgi.tcl
#
# Basic support for CGI programs
#
# Copyright (c) 2000 Ajuba Solutions.
# Copyright (c) 2012 Richard Hipp, Andreas Kupries
# Copyright (c) 2013-2014 Andreas Kupries

#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# Copyright (c) 2018-2024 Poor Yorick
#
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# Please note that Don Libes' has a "cgi.tcl" that implements version 1.0
# of the cgi package.  That implementation provides a bunch of cgi_ procedures
# (it doesn't use the ::cgi:: namespace) and has a wealth of procedures for
# generating HTML.  In contrast, the package provided here is primarly
# concerned with processing input to CGI programs.

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

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

package provide ncgi 1.5.0

#	Decodes data in www-url-encoded format.
#
# Arguments:
#	An encoded value.
#
# Results:
#	The decoded value.
proc ::ncgi::DecodeHex hex {
    return [binary decode hex $hex]
}

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

    # prepare to process all %-escapes
    regsub -all -nocase -- {%([E][A-F0-9])%([89AB][A-F0-9])%([89AB][A-F0-9])%([89AB][A-F0-9])} \
	$str {[encoding convertfrom utf-8 [DecodeHex \1\2\3]]} str
    regsub -all -nocase -- {%([E][A-F0-9])%([89AB][A-F0-9])%([89AB][A-F0-9])} \
	$str {[encoding convertfrom utf-8 [DecodeHex \1\2\3]]} str
    regsub -all -nocase -- {%([CD][A-F0-9])%([89AB][A-F0-9])} \
	$str {[encoding convertfrom utf-8 [DecodeHex \1\2]]} str
    regsub -all -nocase -- {%([A-F0-9][A-F0-9])} $str {\\u00\1} str

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

# Results:
#	The raw query data.

proc ::ncgi::query_string token {
    namespace upvar $token env env querystring querystring

    if {[info exists querystring]} {
	# This ensures you can call ncgi::query more than once.

	return $querystring
    }

    set querystring {}
    if {[info exists env(QUERY_STRING)]} {
	set querystring $env(QUERY_STRING)
    }

# -*- tcl -*-
# Tests for the cgi module.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-2000 by Ajuba Solutions

# Copyright (c) 2018-2024 Poor Yorick
#
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

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

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

testsNeedTcl     8.5

	test ncgi-3.9 {ncgi::decode, bug 3601995} {
		ncgi decode {%E2%A0%90}
	} "\u2810" ; # a braille pattern


	test ncgi-3.10 {ncgi::decode, bug 3601995, tkt [1f900bdf6b]} {
	    ncgi::decode {%E2%B1}
	} "\u00e2\u00b1" ;# Changed with branch `ncgi-1f900bdf6b`, tkt [1f900bdf6b]


	test ncgi-4.1 {ncgi::encode} {
		ncgi encode abcdef0123
	} abcdef0123

# -*- tcl -*-
# pop3.test:  tests for the pop3 client.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2002-2006 by Andreas Kupries <[email protected]>
# All rights reserved.

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

source [file join [file dirname [file dirname [

    file join [pwd] [info script]]]] devtools testutilities.tcl]

testsNeedTcl     8.5
testsNeedTcltest 2.0

tcltest::testConstraint hastls [expr {![catch {package require tls}]}]

support {
    #use           snit/snit.tcl snit ;# comm futures, not used, still a dependency
    #use           comm/comm.tcl comm
    use           log/log.tcl   log

	# construction in memory (depending on source of token).

	log::log debug "pop3d $name Transfer $msgid /full"

	# We do "."-stuffing here. This is not in the scope of the
	# MIME library we use, but a transport dependent thing.

	set msg [string trimright [string map [list "\n." "\n.."] [
	    mime::serialize $token]] \n]
	log::log debug "($msg)"
	puts $sock $msg
	puts $sock .

    } else {
	# As long as FR #531541 is not implemented we have to build
	# the entire message in memory and then cut it down to the
	# requested size. If limit was greater than the number of
	# lines in the message we will get the terminating "."
	# too. Using regsub we make sure that it is not present and
	# reattach during the transfer. Otherwise we would have to use
	# a regexp/if combo to decide wether to attach the terminator
	# not.

	set msg [split [mime::serialize $token] \n]
	set i 0
	incr limit -1
	while {[lindex $msg $i] != {}} {
	    incr i
	    incr limit
	}
	# i now refers to the line separating header and body

# Copyright (c) 2002-2014 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pop3d.test,v 1.24 2011/11/14 22:33:48 andreas_kupries Exp $

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

source [file join [file dirname [file dirname [

    file join [pwd] [info script]]]] devtools testutilities.tcl]

testsNeedTcl     8.5 ;# Required by mime.tcl
testsNeedTcltest 2.0

support {
    #use           comm/comm.tcl  comm
    useTcllibFile devtools/coserv.tcl ; # loads comm too
    useTcllibFile devtools/dialog.tcl
    use           md5/md5x.tcl   md5
    use           mime/mime.tcl  mime

    } {
	return -code error "id \"$msgId\" out of range"
    }
    incr msgId -1

    set mailfile [lindex $state($dir) $msgId]

    set token [::mime::.new -file $mailfile]
    return $token
}

###########################
###########################
# Internal helper commands.

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

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

testsNeedTcl     8.5 ;# Required by mime.tcl
testsNeedTcltest 2.0

support {
    use md5/md5x.tcl  md5
    use mime/mime.tcl mime
}
testing {
    useLocal pop3d_dbox.tcl pop3d::dbox