Tcl Library Source Code

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


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

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



[para]

Available properties and their ranges are:

[list_begin definitions]

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


[para]

[option -subordinates] specifies which messages 
comprising the body should also be destroyed.  The default value is
[const dynamic], which destroys all component messages that were created by
[cmd ::mime::initialize].




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

Serialize a header.


[call [cmd ::mime::header] [cmd get] [arg token] [opt "[arg key] | [option -names]"]]

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


[para]

If [arg name] is provided returns a list of values for that name, without
regard to case.


[para]

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


[call [cmd ::mime::header] [cmd set] [arg token] [arg {name value}] [ \
    opt "[arg parameters] [opt "[option -mode] [const write] | [\
	const append] | [const delete]"]"]]



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

If [const write] is provided, deletes any existing headers whose names match
[arg key] and then creates a new header named [arg key] with the value of
[arg value].

If [const delete] is provided, deletes any existing header having a name that matches
[arg key]. 

[arg parameters] is a dictionary of parameters for the header.

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


[para]

[def [const params]]

A list of "Content-Type" parameters

[def [const parts]]

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

[def [const size]]

The approximate size of the unencoded content.

[list_end]


[call [cmd ::mime::serialize] [arg token] [opt [option -level]] [
    opt "[option -chan] [arg channel]"]]

Return the serialization of the message corresponding to [arg token].  If
[option -chan] is provided, write the message to [arg channel] and return the
empty string.  If [option -level] is provided, indicates the level of the part
in the message hierarchy.  The [const MIME-Version] header is only included at
level [const 0].  Yields from the current coroutine as needed to wait for input to
become available.


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

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


[para]

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

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

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

[list_end]

[section {KNOWN BUGS}]

[list_begin definitions]
[def {Tcllib Bug #447037}]

This problem affects only people which are using Tcl and Mime on a
64-bit system. The currently recommended fix for this problem is to
upgrade to Tcl version 8.4. This version has extended 64 bit support
and the bug does not appear anymore.


[para]

The problem could have been generally solved by requiring the use of
Tcl 8.4 for this package. We decided against this solution as it would
force a large number of unaffected users to upgrade their Tcl
interpreter for no reason.


[para]

See [uri {/tktview?name=447037} {Ticket 447037}] for additional information.

[list_end]

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

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


package require tcl::chan::memchan
package require tcl::chan::string
package require coroutine
namespace eval ::mime {
    namespace path ::coroutine::util {*}[namespace path]
}

#
# state variables:
#
#     canonicalP: input is in its canonical form
#     encoding: transfer encoding
#     version: MIME-version
#     header: dicttionary (keys are lower-case)
#     lowerL: list of header keys, lower-case
#     mixedL: list of header keys, mixed-case
#     value: either "file", "parts", or "string"
#
#     file: input file
#     fd: cached file-descriptor, typically for root
#     root: token for top-level part, for (distant) subordinates
#     offset: number of octets from beginning of file/string
#     count: length in octets of (encoded) content

#       or quoted-printable).

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

    lassign [header get $token content-type] content

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

}


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















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

    return $res
}


proc ::mime::header::exists {token name} {
    upvar 0 $token state
    set lname [string tolower $name]
    dict exists $state(header) $lname

}


# ::mime::header get --
#
#    [mime::header get] returns the header of a MIME part.

#
#    A header consists of zero or more key/value pairs. Each value is a

#    list containing one or more strings.
#
#    If [mime::header get] is invoked with the name of a specific key, then
#    a list containing the corresponding value(s) is returned; instead,
#    if -names is specified, a list of all keys is returned; otherwise, a
#    dictionary is returned. Note that when a
#    key is specified (e.g., "Subject"), the list returned usually
#    contains exactly one string; however, some keys (e.g., "Received")
#    often occur more than once in the header, accordingly the list
#    returned usually contains more than one string.
#
# Arguments:
#       token      The MIME token to parse.
#       key        Either a key or '-names'.  If it is '-names' a list
#                  of all keys is returned.
#
# Results:
#       Returns the header of a MIME part.

proc ::mime::header::get {token {key {}}} {
    # FRINK: nocheck
    upvar 0 $token state
    upvar 0 state(hparams) hparams
    parse $token


    array set header $state(header)


    switch $key {
	{} {
	    set result {}
	    foreach lower $state(lowerL) mixed $state(mixedL) {
		foreach value $header($lower) hparam [
		    dict get $hparams $lower] {
		    lappend result $mixed [list $value $hparam]
		}
	    }
	    set tencoding [getTransferEncoding $token]
	    if {$tencoding ne {}} {
		lappend result Content-Transfer-Encoding [list $tencoding {}]
	    }
	    return $result
	}

	-names {
	    return $state(mixedL)
	}

	default {
	    set lower [string tolower $key]

	    switch $lower {
		content-transfer-encoding {
		    return [list [getTransferEncoding $token] {}]
		}
		mime-version {
		    return [list $state(version) {}]
		}
		default {



		    if {![info exists header($lower)]} {
			error "key $key not in header"


		    }
		    return [list $header($lower) [lindex [
			dict get $hparams $lower] end]]
		}
	    }
	}
    }
}

# 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(hparams) hparams
    parse $token

    set params {}
    switch [llength $args] {
	1 - 3 {
	    set args [lassign $args[set args {}] params]
	}
	0 - 2 {
	    # carry on
	}
	default {
	    error [list {wrong # args}]
	}
    }
    array set options [list -mode write]
    array set options $args











    set lower [string tolower $key]

    array set header $state(header)

    if {[set x [lsearch -exact $state(lowerL) $lower]] < 0} {

        #TODO: this code path is not tested
        if {$options(-mode) eq "delete"} {
            error "key $key not in header"
        }

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

        set result {}
    } else {
        set result $header($lower)
    }
    switch $options(-mode) {
	append - write {
	    switch $lower {
		content-md5
		    -
		content-transfer-encoding

			}
			default {
			    #carry on
			}
		    }
		}
	    }
	    switch $options(-mode) {
		append {
		    lappend header($lower) $value


		    dict lappend hparams $lower $params
		}
		write {

		    set header($lower) [list $value]




		    dict set hparams $lower [list $params]
		}







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

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

    set state(header) [array get header]




    return $result
}


proc ::mime::header::setinternal args {
    variable internal 1
    try {
	set_ {*}$args
    } finally {
	set internal 0
    }
}








# ::mime::initialize --
#
#    the public interface for initializeaux

proc ::mime::initialize args {

    # FRINK: nocheck
    upvar 0 $token state
    upvar 0 state(canonicalP) canonicalP
    upvar 0 state(params) params

    set params {}

    set state(hparams) {}
    set state(encoding) {}
    set state(version) 1.0

    set state(bodyparsed) 0
    set canonicalP 0
    set state(header) {}
    set state(headerparsed) 0

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

    set state(cid) 0
    set state(closechan) 1
    set state(root) $token

    set userparams 0

		if {$lname in {content-md5 mime-version}} {
		    error [list {don't go there...}]
		}
		header::setinternal $token $name $hvalue
	    }
	}

	lassign [header get $token content-type] content

        switch $state(value) {
            file {
                set state(offset) 0
            }

            parts {

                    mime::initializeaux $child -root $state(root) -string $strng
                } else {
                    mime::initializeaux $child -root $state(root) -lineslist [
                        lrange $state(lines) $state(lines.current) end]
                }
            }
        }

        return
    }

    set state(value) parts

    dict update params boundary boundary {}
    if {![info exists boundary]} {

    upvar 0 state(fd) fd
    parsepart $token

    set result {}
    if {!$level} {
	puts $channel [header serialize $token MIME-Version $state(version) {}]
    }
    foreach {mixed value} [header get $token] {
	puts $channel [header serialize $token $mixed {*}$value]
    }

    set converter {}
    set encoding {}
    if {$state(value) ne "parts"} {
        if {$state(canonicalP)} {
            if {[set encoding $state(encoding)] eq {}} {

    fconfigure $ofh -translation binary
    mime::serialize $attachment -chan $ofh -level 1
    close $ofh

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

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

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

Content-Transfer-Encoding: base64

T3JpZ2luYWwtUmVjaXBpZW50OiA8L2ZheD1ibHViYkBndW1taS5ib290PgpBY3Rpb246IGZhaWxl
ZApEaWFnbm9zdGljLUNvZGU6IHNtdHA7IDU1MCAjNS4xLjAgQWRkcmVzcyByZWplY3RlZC4KUmVt
b3RlLU1UQTogNTMuMjQuMjgyLjE1MA==
}]
    set parts [mime::property $token parts]
    lassign [mime::header get [lindex $parts end] Remote-MTA] result
    return $result
}} 53.24.282.150

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


test mime-13.0 {cleanly {
    issue a16b1095974e071d
}} {

dawg one" \
[list Content-ID {<> {}} Content-Type {text/plain {}} \
    Content-Disposition [list attachment [list param1 $char]]]

]




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

[package ncgi] package to query these values, set and get cookies, and
encode and decode www-url-encoded values.

[para]

In the simplest case, a CGI script first calls [cmd ::ncgi::parse] and
then calls [cmd ::ncgi::value] to get different form values.  If a CGI
value is repeated, you should use [cmd ::ncgi::valueList] to get back
the complete list of values.

[para]

An alternative to [cmd ::ncgi::parse] is [cmd ::ncgi::input], which
has semantics similar to Don Libes' [cmd cgi_input] procedure.

[call [cmd ::ncgi::header] [opt [arg type]] [arg args]]

Output the CGI header to standard output.  This emits a Content-Type:
header and additional headers based on [arg args], which is a list of
header names and header values. The [arg type] defaults to
"text/html".

[call [cmd ::ncgi::import] [arg cginame] [opt [arg tclname]]]

This creates a variable in the current scope with the value of the CGI
variable [arg cginame].  The name of the variable is [arg tclname], or
[arg cginame] if [arg tclname] is empty (default).

[call [cmd ::ncgi::importAll] [arg args]]

This imports several CGI variables as Tcl variables.  If [arg args] is
empty, then every CGI value is imported.  Otherwise each CGI variable
listed in [arg args] is imported.

[call [cmd ::ncgi::importFile] [arg cmd] [arg cginame] [opt [arg filename]]]

This provides information about an uploaded file from a form input
field of type [const file] with name [arg cginame].  [arg cmd] can be
one of [option -server] [option -client], [option -type] or
[option -data].

writes the file contents to a local temporary file (or [arg filename]
if supplied) and returns the name of the file. The caller is
responsible for deleting this file after use.

[list_end]











[call [cmd ::ncgi::input] [opt [arg fakeinput]] [opt [arg fakecookie]]]


This reads and decodes the CGI values from the environment.  It
restricts repeated form values to have a trailing "List" in their

name.  The CGI values are obtained later with the [cmd ::ncgi::value]

procedure.








[call [cmd ::ncgi::multipart] [arg {type query}]]

This procedure parses a multipart/form-data [arg query].  This is used
by [cmd ::ncgi::nvlist] and not normally called directly.  It returns
an alternating list of names and structured values.  Each structure
value is in turn a list of two elements.  The first element is
meta-data from the multipart/form-data structure.  The second element
is the form value.  If you use [cmd ::ncgi::value] you just get the
form value.  If you use [cmd ::ncgi::valueList] you get the structured
value with meta data and the value.

[para]

The [arg type] is the whole Content-Type, including the parameters
like [arg boundary].  This returns a list of names and values that
describe the multipart data.  The values are a nested list structure
that has some descriptive information first, and the actual form value
second.  The descriptive information is list of header names and
values that describe the content.


[call [cmd ::ncgi::nvlist]]

This returns all the query data as a name, value list.  In the case of
multipart/form-data, the values are structured as described in


[cmd ::ncgi::multipart].

[call [cmd ::ncgi::names]]

This returns all names found in the query data, as a list.

[cmd ::ncgi::multipart].


[call [cmd ::ncgi::parse]]

This reads and decodes the CGI values from the environment.  The CGI
values are obtained later with the [cmd ::ncgi::value] procedure.  IF
a CGI value is repeated, then you should use [cmd ::ncgi::valueList]
to get the complete list of values.


[call [cmd ::ncgi::parseMimeValue] [arg value]]

Decodes the Content-Type and other MIME headers that have the
form of "primary value; param=val; p2=v2" It returns a list, where the
first element is the primary value, and the second element is a list
of parameter names and values.


[call [cmd ::ncgi::post]]

Returns the parsed post data as a multidict.


[call [cmd ::ncgi::poststring]]

Returns the raw post data.

[call [cmd ::ncgi::query]]

Returns the parsed query data as a multidict.


[call [cmd ::ncgi::querystring]]

Returns the raw query data.


[call [cmd ::ncgi::redirect] [arg url]]

Generate a response that causes a 302 redirect by the Web server.  The

[def "[option -name] [arg name]"]
[def "[option -value] [arg value]"]
[def "[option -expires] [arg date]"]
[def "[option -path] [arg {path restriction}]"]
[def "[option -domain] [arg {domain restriction}]"]
[list_end]


[call [cmd ::ncgi::setDefaultValue] [arg {key defvalue}]]

Set a CGI value if it does not already exists.  This affects future
calls to [cmd ::ncgi::value] (but not future calls to

[cmd ::ncgi::nvlist]).  If the CGI value already is present, then this
procedure has no side effects.


[call [cmd ::ncgi::setDefaultValueList] [arg {key defvaluelist}]]

Like [cmd ::ncgi::setDefaultValue] except that the value already has
list structure to represent multiple checkboxes or a multi-selection.


[call [cmd ::ncgi::setValue] [arg {key value}]]

Set a CGI value, overriding whatever was present in the CGI
environment already.  This affects future calls to [cmd ::ncgi::value]
(but not future calls to [cmd ::ncgi::nvlist]).


[call [cmd ::ncgi::setValueList] [arg {key valuelist}]]

Like [cmd ::ncgi::setValue] except that the value already has list
structure to represent multiple checkboxes or a multi-selection.


[call [cmd ::ncgi::type]]

Returns the Content-Type of the current CGI values.


[call [cmd ::ncgi::urlStub] [opt [arg url]]]

Returns the current URL, but without the protocol, server, and port.
If [arg url] is specified, then it defines the URL for the current
session.  That value will be returned by future calls to

[cmd ::ncgi::urlStub]


[call [cmd ::ncgi::value] [arg key] [opt [arg default]]]

Return the CGI value identified by [arg key].  If the CGI value is not
present, then the [arg default] value is returned instead. This value
defaults to the empty string.

[para]

If the form value [arg key] is repeated, then there are two cases: if
[cmd ::ncgi::parse] was called, then [cmd ::ncgi::value] only returns
the first value associated with [arg key].  If [cmd ::ncgi::input] was
called, then [cmd ::ncgi::value] returns a Tcl list value and

[arg key] must end in "List" (e.g., "skuList").  In the case of
multipart/form-data, this procedure just returns the value of the form
element.  If you want the meta-data associated with each form value,
then use [cmd ::ncgi::valueList].


[call [cmd ::ncgi::valueList] [arg key] [opt [arg default]]]

Like [cmd ::ncgi::value], but this always returns a list of values
(even if there is only one value).  In the case of
multipart/form-data, this procedure returns a list of two elements.
The first element is meta-data in the form of a parameter, value list.
The second element is the form value.

[list_end]

[section EXAMPLES]

Uploading a file
[example {
HTML:

# 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.  I have tried to mirror his
# API's where possible.  So, ncgi::input is equivalent to cgi_input, and so
# on.  There are also some different APIs for accessing values (ncgi::list,
# ncgi::parse and ncgi::value come to mind)

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

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

package require uri

package provide ncgi 1.5.0

namespace eval ::ncgi {

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

    variable query

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

    variable contenttype

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





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

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

    variable value

    # This lists the names that appear in the query data

    variable varlist

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

    variable urlStub

    # This flags compatibility with Don Libes cgi.tcl when dealing with
    # form values that appear more than once.  This bit gets flipped when

    variable  _tmpfiles
    array set _tmpfiles {}

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

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






proc ::ncgi::post {} {


    set type [type]


    switch -glob $type {

	{} -
	text/xml* -
	application/x-www-form-urlencoded* -
	application/x-www-urlencoded* {
	    return [urlencoded [poststring]]
	}










	multipart/* {

	    return [multipart $type [poststring]]






	}
	default {
	    return -code error "Unknown Content-Type: $type"



	}
    }




}






proc ::ncgi::poststring {} {
    global env
    variable content_length
    variable method
    variable post
    if {![info exists post]} {
	if {([info exists method] && $method eq {post})
	    && [info exist content_length]
	} {
	    fconfigure stdin -translation binary -encoding binary
	    set post [read stdin $env(CONTENT_LENGTH)]
	} else {
	    set post {}
	}
    }

    return $post
}

# ::ncgi::reset
#
#	This resets the state of the CGI input processor.  This is primarily
#	used for tests, although it is also designed so that TclHttpd can
#	call this with the current query data
#	so the ncgi package can be shared among TclHttpd and CGI scripts.
#
#	DO NOT CALL this in a standard cgi environment if you have not
#	yet processed the query data, which will not be used after a
#	call to ncgi::reset is made.  Instead, just call ncgi::parse



#
# Arguments:
#	newquery	The query data to be used instead of external CGI.
#	newtype		The raw content type.
#
# Side Effects:
#	Resets the cached query data and wipes any environment variables
#	associated with CGI inputs (like QUERY_STRING)

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

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


    set cookieOutput {}



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

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

	if {[info exists query]} {
	    unset query
	}
	if {[info exists contenttype]} {
	    unset contenttype
	}
	if {[info exists post]} {
	    unset post
	}
    } else {
	set contenttype {}
	set post {}
	set query {}
	dict for {opt val} $args {
	    switch $opt {
		contenttype - post - query {
		    set $opt $val
		}
		default {
		    error [list {unknown reset option} $opt]
		}
	    }
	}
    }
}

# ::ncgi::urlStub
#
#	Set or return the URL associated with the current page.
#	This is for use by TclHttpd to override the default value
#	that otherwise comes from the CGI environment

#
# Arguments:

#	url	(option) The url of the page, not counting the server name.
#		If not specified, the current urlStub is returned




#
# Side Effects:
#	May affects future calls to ncgi::urlStub


proc ::ncgi::urlStub {{url {}}} {
    global   env
    variable urlStub
    if {[string length $url]} {
	set urlStub $url

	return ""
    } elseif {[info exists urlStub]} {
	return $urlStub
    } elseif {[info exists env(SCRIPT_NAME)]} {
	set urlStub $env(SCRIPT_NAME)
	return $urlStub
    } else {
	return ""
    }
}









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

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

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

}

# ::ncgi::decode
#
#	This decodes data in www-url-encoded format.
#
# Arguments:

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

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


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

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

# ::ncgi::names
#










#	This parses the query data and returns a list of the names found therein.
#






# 	Note: If you use ncgi::setValue or ncgi::setDefaultValue, this
#	names procedure doesn't see the effect of that.
#









# Arguments:


#	none



#
# Results:

#	A list of names












proc ::ncgi::names {} {
    array set names {}







    foreach {name val} [nvlist] {
        if {![string equal $name "anonymous"]} {


            set names($name) 1

        }






    }

    return [array names names]








}




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





#	none














#









# Results:
#	An alternating list of names and values







proc ::ncgi::nvlist {} {

    set query [query]

    set post [post]

    return [dict merge $query $post]
    switch -glob -- [type] {







	{} -



	text/xml* -




	application/x-www-form-urlencoded* -
	application/x-www-urlencoded*  -









	multipart/* {







	}
	default {
	    return -code error "Unknown Content-Type: $type"
	}
    }
}

# ::ncgi::parse
#


#	The parses the query data and stores it into an array for later retrieval.
#	You should use the ncgi::value or ncgi::valueList procedures to get those
#	values, or you are allowed to access the ncgi::value array directly.








#
#	Note - all values have a level of list structure associated with them
#	to allow for multiple values for a given form element (e.g., a checkbox)
#
# Arguments:
#	none
#
# Results:
#	A list of names of the query values







proc ::ncgi::parse {} {
    variable value
    variable listRestrict 0
    variable varlist {}
    if {[info exists value]} {

	unset value
    }

    foreach {name val} [nvlist] {

	if {![info exists value($name)]} {




	    lappend varlist $name
	}
	lappend value($name) $val
    }
    return $varlist
} 



# ::ncgi::input
#

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

#
# Results:
#	The list of element names in the form

proc ::ncgi::input {{fakeinput {}} {fakecookie {}}} {


    variable value
    variable varlist {}
    variable listRestrict 1
    if {[info exists value]} {
	unset value
    }

    if {[string length $fakeinput]} {
	ncgi::reset query $fakeinput
    }

    foreach {name val} [nvlist] {

	set exists [info exists value($name)]

	if {!$exists} {

	    lappend varlist $name





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

} 



# ::ncgi::query
#
#	Parses the query part of the URI
#
proc ::ncgi::query {} {
    urlencoded [querystring]
}


# ::ncgi::urlencoded
#
#	Parses $data as a url-encoded query and returns a multidict containing
#	the query.
#
proc ::ncgi::urlencoded query {
    set result {}

    # Any whitespace at the beginning or end of urlencoded data is not
    # considered to be part of that data, so we trim it off.  One special
    # case in which post data is preceded by a \n occurs when posting
    # with HTTPS in Netscape.
    foreach x [split [string trim $query] &] {
	# Turns out you might not get an = sign,
	# especially with <isindex> forms.

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

	if { $pos>=0 } {
	    if { $pos == 0 } { # if the = is at the beginning ...
		if { $len>1 } { 
		    # ... and there is something to the right ...
		    set varname anonymous



		    set val [string range $x 1 end]
		} else { 
		    # ... otherwise, all we have is an =
		    set varname anonymous


		    set val ""
		}
	    } elseif { $pos==[expr {$len-1}] } { 
		# if the = is at the end ...
		set varname [string range $x 0 [expr {$pos-1}]]
		set val ""
	    } else {
		set varname [string range $x 0 [expr {$pos-1}]]
		set val [string range $x [expr {$pos+1}] end]
	    }
	} else { # no = was found ...
	    set varname anonymous
	    set val $x
	}		
	lappend result [decode $varname] [decode $val]
    }
    return $result
}


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

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

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

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


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

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

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

	    set val $value($key)
	} else {

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

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

	    # Drop the meta-data information associated with each part

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

	    set url $proto://$server$port$dirname$url
	}
    }
    ncgi::header text/html Location $url
    puts "Please go to <a href=\"$url\">$url</a>"
}


# ncgi:header
#



#	Output the Content-Type header.
#
# Arguments:

#	type	The MIME content type
#	args	Additional name, value pairs to specifiy output headers
#
# Side Effects:
#	Outputs a normal header

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

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

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



            lappend paramList $key $val
	}


    }

    if {[llength $paramList]} {
	lappend results $paramList
    }
    return $results
}

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

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

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

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

    # Iterate over the boundary string and chop into parts

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

    # Ensuring the query data starts
    # with a newline makes the string first test simpler
    if {[string first $lineDelim $query 0]!=0} {

        set query $lineDelim$query
    }
    while {[set offset [string first $lineDelim--$boundary $query $offset]] \
            >= 0} {


	if {!$first} {
	    lappend results $formName [list $headers \
		[string range $query $off2 [expr {$offset -1}]]]

	} else {
	    set first 0
	}
	incr offset $blen


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

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


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



	#		}
	#	}

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

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

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

		} else {
		    lappend headers $hdrname $valueList

		}
	    }
	}

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


# ::ncgi::importFile --
#
#   get information about a file upload field


#


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

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

    set vlist [valueList $var]







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

    switch -exact -- $cmd {
	-server {
	    ## take care not to write it out more than once
	    variable _tmpfiles
	    if {![info exists _tmpfiles($var)]} {

		if {$filename != {}} {

		    ## use supplied filename 
		    set _tmpfiles($var) $filename
		} else {
		    ## create a tmp file 
		    set _tmpfiles($var) [::fileutil::tempfile ncgi]
		}

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

		fconfigure $h -translation binary -encoding binary
		puts -nonewline $h $contents 
		close $h
	    }
	    return $_tmpfiles($var)
	}
	-client {
	    if {![info exists fileinfo(filename)]} {return {}}
	    return $fileinfo(filename)
	}




	-type {
	    if {![info exists fileinfo(content-type)]} {return {}}
	    return $fileinfo(content-type)


	}
	-data {
	    return $contents
	}
	default {
	    error "Unknown subcommand to ncgi::import_file: $cmd"
	}

    }

}


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

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

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


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


proc ::ncgi::setCookie {args} {

    variable cookieOutput

    array set opt $args
    set line "$opt(-name)=$opt(-value) ;"
    foreach extra {path domain} {
	if {[info exists opt(-$extra)]} {
	    append line " $extra=$opt(-$extra) ;"
	}
    }

    if {[info exists opt(-expires)]} {
	switch -glob -- $opt(-expires) {
	    *GMT {
		set expires $opt(-expires)

	    }
	    default {
		set expires [clock format [clock scan $opt(-expires)] \
			-format "%A, %d-%b-%Y %H:%M:%S GMT" -gmt 1]
	    }
	}
	append line " expires=$expires ;"
    }
    if {[info exists opt(-secure)]} {
	append line " secure "
    }
    lappend cookieOutput $line
}

testsNeedTcl     8.4
testsNeedTcltest 2

testing {
    useLocal ncgi.tcl ncgi
}

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



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

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

test ncgi-1.1 {ncgi::reset} {
    ncgi::reset
    list [info exist ncgi::query] [info exist ncgi::contenttype]
} {0 0}


test ncgi-1.2 {ncgi::reset} {
    ncgi::reset query query=reset
    list $ncgi::query $ncgi::contenttype
} {query=reset {}}


test ncgi-1.3 {ncgi::reset} {
    ncgi::reset query query=reset contenttype text/plain
    list $ncgi::query $ncgi::contenttype
} {query=reset text/plain}


test ncgi-2.1 {ncgi::query fake query data} {
    ncgi::reset query fake=query
    ncgi::query
    set ncgi::query
} "fake=query"


test ncgi-2.2 {ncgi::query GET} {
    ncgi::reset
    set env(REQUEST_METHOD) GET
    set env(QUERY_STRING) name=value
    ncgi::query
    set ncgi::query
} "name=value"


test ncgi-2.3 {ncgi::query HEAD} {
    ncgi::reset
    set env(REQUEST_METHOD) HEAD
    catch {unset env(QUERY_STRING)}
    ncgi::querystring
    set ncgi::query
} ""


test ncgi-2.4 {ncgi::query POST} {
    ncgi::reset
    catch {unset env(QUERY_STRING)}
    set env(REQUEST_METHOD) POST
    set env(CONTENT_LENGTH) 10
    makeFile [format {
	set auto_path {%s}
	source {%s}
	source {%s}
	source {%s}
	ncgi::poststring
	puts $ncgi::post
	exit
    } $sub_ap $cmdlFile $futlFile $ncgiFile] test1 ; # {}
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    puts  $f "name=value"
    flush $f
    gets  $f line
    close $f
    removeFile test1
    set line
} name=value


test ncgi-2.5 {ncgi::test} {
    ncgi::reset
    set env(CONTENT_TYPE) text/html
    ncgi::type
} text/html


test ncgi-2.6 {ncgi::test} {
    ncgi::reset query foo=bar contenttype text/plain
    set env(CONTENT_TYPE) text/html
    ncgi::type
} text/plain


test ncgi-3.1 {ncgi::decode} {
    ncgi::decode abcdef0123
} abcdef0123


test ncgi-3.2 {ncgi::decode} {
    ncgi::decode {[abc]def$0123\x}
} {[abc]def$0123\x}


test ncgi-3.3 {ncgi::decode} {
    ncgi::decode {[a%25c]def$01%7E3\x%3D}
} {[a%c]def$01~3\x=}


test ncgi-3.4 {ncgi::decode} {
    ncgi::decode {hello+world}
} {hello world}


test ncgi-3.5 {ncgi::decode} {
    ncgi::decode {aik%C5%ABloa}
} "aik\u016Bloa" ; # u+macron


test ncgi-3.6 {ncgi::decode} {
    ncgi::decode {paran%C3%A1}
} "paran\u00E1" ; # a+acute


test ncgi-3.7 {ncgi::decode, bug 3601995} {
    ncgi::decode {%C4%85}
} "\u0105" ; # a+ogonek


test ncgi-3.8 {ncgi::decode, bug 3601995} {
    ncgi::decode {%E2%80%A0}
} "\u2020" ; # dagger


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} {
    ncgi::decode {%E2%B1}
} "%E2%B1" ; # missing byte trailing %A0, do not accept/decode, pass through.


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


test ncgi-4.2 {ncgi::encode} {
    ncgi::encode "\[abc\]def\$0123\\x"
} {%5Babc%5Ddef%240123%5Cx}


test ncgi-4.3 {ncgi::encode} {
    ncgi::encode {hello world}
} {hello+world}


test ncgi-4.4 {ncgi::encode} {
    ncgi::encode "hello\nworld\r\tbar"
} {hello%0D%0Aworld%0D%09bar}


test ncgi-5.1 {ncgi::nvlist} {
    ncgi::reset query name=hello+world&name2=%7ewelch
    ncgi::nvlist
} {name {hello world} name2 ~welch}

test ncgi-5.2 {ncgi::nvlist} {
    ncgi::reset query name=&name2 contenttype application/x-www-urlencoded
    ncgi::nvlist
} {name {} anonymous name2}

test ncgi-5.3 {ncgi::nvlist} {
    ncgi::reset query name=&name2 contenttype application/x-www-form-urlencoded
    ncgi::nvlist
} {name {} anonymous name2}

test ncgi-5.4 {ncgi::nvlist} {
    ncgi::reset query name=&name2 contenttype application/xyzzy
    set code [catch ncgi::nvlist err]
    list $code $err
} {1 {Unknown Content-Type: application/xyzzy}}

# multipart tests at the end because I'm too lazy to renumber the tests

test ncgi-6.1 {ncgi::parse, anonymous values} {
    ncgi::reset query name=&name2
    ncgi::parse
} {name anonymous}

test ncgi-6.2 {ncgi::parse, no list restrictions} {




    ncgi::reset query name=value&name=value2
    ncgi::parse 
























} {name}


test ncgi-7.1 {ncgi::input} {
    ncgi::reset
    catch {unset env(REQUEST_METHOD)}
    ncgi::input "name=value&name2=value2"
} {name name2}


test ncgi-7.2 {ncgi::input} {
    ncgi::reset query nameList=value1+stuff&nameList=value2+more
    ncgi::input
    set ncgi::value(nameList)
} {{value1 stuff} {value2 more}}


test ncgi-7.3 {ncgi::input} {
    ncgi::reset query name=value&name=value2
    catch {ncgi::input} err
    set err
} {Multiple definitions of name encountered in input. If you're trying to do this intentionally (such as with select), the variable must have a "List" suffix.}

test ncgi-8.1 {ncgi::value} {
    ncgi::reset query nameList=val+ue&nameList=value2
    ncgi::input
    ncgi::value nameList
} {{val ue} value2}

test ncgi-8.2 {ncgi::value} {
    ncgi::reset query name=val+ue&name=value2
    ncgi::parse
    ncgi::value name
} {val ue}

test ncgi-8.3 {ncgi::value} {
    ncgi::reset query name=val+ue&name=value2
    ncgi::parse
    ncgi::value noname
} {}

test ncgi-9.1 {ncgi::valueList} {
    ncgi::reset query name=val+ue&name=value2
    ncgi::parse
    ncgi::valueList name
} {{val ue} value2}

test ncgi-9.2 {ncgi::valueList} {
    ncgi::reset query name=val+ue&name=value2
    ncgi::parse
    ncgi::valueList noname
} {}

test ncgi-10.1 {ncgi::import} {
    ncgi::reset query nameList=val+ue&nameList=value2
    ncgi::input
    ncgi::import nameList
    set nameList
} {{val ue} value2}

test ncgi-10.2 {ncgi::import} {
    ncgi::reset query nameList=val+ue&nameList=value2
    ncgi::input
    ncgi::import nameList myx
    set myx
} {{val ue} value2}

test ncgi-10.3 {ncgi::import} {
    ncgi::reset query nameList=val+ue&nameList=value2
    ncgi::input
    ncgi::import noname
    set noname

} {}

test ncgi-10.4 {ncgi::importAll} {
    ncgi::reset query name1=val+ue&name2=value2
    catch {unset name1}

    catch {unset name2}
    ncgi::parse
    ncgi::importAll

    list $name1 $name2
} {{val ue} value2}

test ncgi-10.5 {ncgi::importAll} {
    ncgi::reset query name1=val+ue&name2=value2
    catch {unset name1}
    catch {unset name2}
    catch {unset name3}
    ncgi::parse
    ncgi::importAll name2 name3
    list [info exist name1] $name2 $name3
} {0 value2 {}}

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


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


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


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


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


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


set URL  login.tcl
set URL2 https://foo.com/cgi-bin/login.tcl
test ncgi-11.7 {ncgi::redirect} {
    set env(REQUEST_URI) https://foo.com/cgi-bin/view.tcl?path=/a/b/c
    set env(REQUEST_METHOD) GET
    set env(QUERY_STRING) {}
    set env(SERVER_NAME) foo.com
    set env(SERVER_PORT) 443
    set env(HTTPS) "on"
    makeFile [format {
	set auto_path {%s}
	if {[catch {
	    source %s
	    source %s
	    source %s
	    ncgi::redirect %s
	} err]} {
	    puts $err
	}
	exit
    } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    set res [read $f]
    close $f
    removeFile test1
    set res
} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"


test ncgi-12.1 {ncgi::header} {
    makeFile [format {
	set auto_path {%s}
	if {[catch {
	    source %s
	    source %s
	    source %s
	    ncgi::header
	} err]} {
	    puts $err
	}
	exit
    } $sub_ap $cmdlFile $futlFile $ncgiFile] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    set res [read $f]
    close $f
    removeFile test1
    set res
} "Content-Type: text/html\n\n"


test ncgi-12.2 {ncgi::header} {
    makeFile [format {
	set auto_path {%s}
	if {[catch {
	    source %s
	    source %s
	    source %s
	    ncgi::header text/plain
	} err]} {
	    puts $err
	}
	exit
    } $sub_ap $cmdlFile $futlFile $ncgiFile] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    set res [read $f]
    close $f
    removeFile test1
    set res
} "Content-Type: text/plain\n\n"


test ncgi-12.3 {ncgi::header} {
    makeFile [format {
	set auto_path {%s}
	if {[catch {
	    source %s
	    source %s
	    source %s
	    ncgi::header text/html X-Comment "This is a test"
	} err]} {
	    puts $err
	}
	exit
    } $sub_ap $cmdlFile $futlFile $ncgiFile] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    set res [read $f]
    close $f
    removeFile test1
    set res
} "Content-Type: text/html\nX-Comment: This is a test\n\n"


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

test ncgi-13.1 {ncgi::parseMimeValue} {
    ncgi::parseMimeValue text/html
} text/html

test ncgi-13.2 {ncgi::parseMimeValue} {
    ncgi::parseMimeValue "text/html; charset=iso-8859-1"
} {text/html {charset iso-8859-1}}

test ncgi-13.3 {ncgi::parseMimeValue} {
    ncgi::parseMimeValue "text/html; charset='iso-8859-1'"
} {text/html {charset iso-8859-1}}

test ncgi-13.4 {ncgi::parseMimeValue} {
    ncgi::parseMimeValue "text/html; charset=\"iso-8859-1\""
} {text/html {charset iso-8859-1}}

test ncgi-13.5 {ncgi::parseMimeValue} {
    ncgi::parseMimeValue "text/html; charset=\"iso-8859-1\"; ignored"
} {text/html {charset iso-8859-1}}

test ncgi-13.6 {ncgi::parseMimeValue} {
    ncgi::parseMimeValue "text/html; charset=\"iso-8859-1\"morecrap"
} {text/html {charset iso-8859-1}}

test ncgi-13.7 {ncgi::parseMimeValue} {
    ncgi::parseMimeValue {test/test; foo="bar\"baz\""}
} {test/test {foo bar\"baz\"}}

test ncgi-13.8 {ncgi::parseMimeValue} {
    ncgi::parseMimeValue {test/test; foo=""}
} {test/test {foo {}}}


test ncgi-14.1 {ncgi::multipart} {
    catch {ncgi::multipart "application/x-www-urlencoded" name=val+ue} err
    set err
} {Not a multipart Content-Type: application/x-www-urlencoded}

test ncgi-14.2 {ncgi::multipart} {
    catch {ncgi::multipart "multipart/form-data" {}} err
    set err

} {No boundary given for multipart document}

test ncgi-14.3 {ncgi::multipart} {
    set in [open [file join [file dirname [info script]] formdata.txt]]
    set X [read $in]
    close $in

    foreach line [split $X \n] {
	if {[string length $line] == 0} {
	    break
	}
	if {[regexp {^Content-Type: (.*)$} $line x type]} {
	    break
	}
    }
    regsub ".*?\n\n" $X {} X

    ncgi::multipart $type $X













} {field1 {{content-disposition form-data name field1} value} field2 {{content-disposition form-data name field2} {another value}} the_file_name {{content-disposition form-data name the_file_name filename {C:\Program Files\Netscape\Communicator\Program\nareadme.htm} content-type text/html} {


























<center><h1>
                  Netscape Address Book Sync for Palm Pilot
                                         User Guide
</h1></center>


}}}



















test ncgi-14.4 {ncgi::multipart} {
    set in [open [file join [file dirname [info script]] formdata.txt]]
    set X [read $in]
    close $in

    foreach line [split $X \n] {
	if {[string length $line] == 0} {
	    break
	}
	if {[regexp {^Content-Type: (.*)$} $line x type]} {
	    break
	}
    }
    regsub ".*?\n\n" $X {} X

    ncgi::reset post $X contenttype $type
    ncgi::parse

    list [ncgi::value field1] [ncgi::value field2] [ncgi::value the_file_name]
} {value {another value} {
<center><h1>
                  Netscape Address Book Sync for Palm Pilot
                                         User Guide
</h1></center>


}}


test ncgi-14.6 {ncgi::multipart setValue} {
    set in [open [file join [file dirname [info script]] formdata.txt]]
    set X [read $in]
    close $in

    foreach line [split $X \n] {
	if {[string length $line] == 0} {
	    break
	}
	if {[regexp {^Content-Type: (.*)$} $line x type]} {
	    break
	}
    }
    regsub ".*?\n\n" $X {} X

    ncgi::reset post $X contenttype $type
    ncgi::parse
    ncgi::setValue userval1 foo
    ncgi::setValue userval2 "a b"
    list [ncgi::value field1] [ncgi::value field2] [ncgi::value userval1] [ncgi::value userval2] [ncgi::value the_file_name]
} {value {another value} foo {a b} {
<center><h1>
                  Netscape Address Book Sync for Palm Pilot
                                         User Guide
</h1></center>


}}


test ncgi-15.1 {ncgi::setValue} {
    ncgi::reset query nameList=val+ue&nameList=value2
    ncgi::input
    ncgi::setValue foo 1
    ncgi::setValue bar "a b"
    list [ncgi::value nameList] [ncgi::value foo] [ncgi::value bar]
} {{{val ue} value2} 1 {a b}}




## ------------ tests for binary content and file upload ----------------

## some utility procedures to generate content 

set form_boundary {17661509020136}

proc genformcontent_type {} {
    global form_boundary
    return "multipart/form-data; boundary=\"$form_boundary\""
}

proc genformdata {bcontent} {



    global form_boundary

    proc genformdatapart {name cd value} {
	global form_boundary
	return "--$form_boundary\nContent-Disposition: form-data; name=\"$name\"$cd\n\n$value\n"
    }

    set a [genformdatapart field1 "" {value}]
    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" 
}

set binary_content "\r
\r
<center><h1>\r
                  Netscape Address Book Sync for Palm Pilot\r
                                         User Guide\r
</h1></center>\r
\r
"

test ncgi-14.5 {ncgi::multipart--check binary file} {

    global binary_content

    set X [genformdata $binary_content]

    ncgi::reset post $X contenttype [genformcontent_type]
    ncgi::parse
    set content [ncgi::value the_file_name]
    list [ncgi::value field1] [ncgi::value field2] $content
} [list value {another value} $binary_content]



test ncgi-16.1 {ncgi::importFile} {

    global binary_content

    set X [genformdata $binary_content]

    ncgi::reset post $X contenttype [genformcontent_type]
    ncgi::parse


    ncgi::importFile -client the_file_name

} "C:\\Program Files\\Netscape\\Communicator\\Program\\nareadme.htm"

test ncgi-16.2 {ncgi::importFile - content type} {

    global binary_content

    set X [genformdata $binary_content]

    ncgi::reset post $X contenttype [genformcontent_type]
    ncgi::parse

    ncgi::importFile -type the_file_name

} text/html


test ncgi-16.3 {ncgi::importFile -- file contents} {

    global binary_content

    set X [genformdata $binary_content]

    ncgi::reset post $X contenttype [genformcontent_type]
    ncgi::parse

    ncgi::importFile -data the_file_name

} $binary_content


test ncgi-16.4 {ncgi::importFile -- save file} {

    global binary_content

    set X [genformdata $binary_content]

    ncgi::reset post $X contenttype [genformcontent_type]
    ncgi::parse

    set localfile [ncgi::importFile -server the_file_name]

    # get the contents of the local file to verify
    set in [open $localfile]
    fconfigure $in -translation binary
    set content [read $in]
    close $in
    file delete $localfile
    set content

} $binary_content


test ncgi-16.5 {ncgi::importFile -- save file, given name} {

    global binary_content

    set X [genformdata $binary_content]

    ncgi::reset post $X contenttype [genformcontent_type]
    ncgi::parse

    set localfile [ncgi::importFile -server the_file_name fofo]

    # get the contents of the local file to verify
    set in [open $localfile]
    fconfigure $in -translation binary
    set content [read $in]
    close $in
    file delete $localfile
    set content

} $binary_content


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

    set X "bad multipart data"

    ncgi::reset post $X contenttype [genformcontent_type]
    ncgi::parse

    ncgi::importFile -client the_file_name

} {}


test ncgi-17.1 {ncgi::names} {
    ncgi::reset query name=hello+world&name2=%7ewelch
    ncgi::names
} {name name2}


test ncgi-17.2 {ncgi::names} {
    ncgi::reset  query name=&name2 contenttype application/x-www-urlencoded
    ncgi::names
} {name}


test ncgi-17.3 {ncgi::names} {
    ncgi::reset query name=&name2 \
	contenttype application/x-www-form-urlencoded
    ncgi::names
} {name}


test ncgi-17.4 {ncgi::names} {
    ncgi::reset query name=&name2 contenttype application/xyzzy
    set code [catch ncgi::names err]
    list $code $err
} {1 {Unknown Content-Type: application/xyzzy}}

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

testsuiteCleanup






return