Tcl Library Source Code

[call [cmd ::mime::initialize] [
    opt "[option -canonical] [arg type/subtype]"] [
    opt "[option -params] [arg dictionary]"] [
    opt "[option -encoding] [arg value]"] [
    opt "[option -headers] [arg dictionary]"] [
    opt "[option -addcontentid] [arg boolean]"] [
    opt "[option -addmimeversion] [arg boolean]"] [
    opt "([option -chan] [arg name] | [option -file] [arg name] | [
	option -string] [arg value] | [option -parts] [arg parts])"]]

Parses a message and returns a token for the message.  One of [

    option -chan

    const Content-Type
    
] header.  [

    option -headers
    
] is a multidict of headers.  If [
    arg addcontentid
] is provided, it is a boolean value indicating whether a [
    const Content-Id
] header field should be added to the message.  By default, this
header is added to non-canonical messages.  If [
    arg addmimeversion
] is provided, it is a boolean value indicating whether a [
    const MIME-Version
] header should be added to non-canonical messages.  By default, this header is
added to non-canonical messages.


[para]

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

# mime.tcl - MIME body parts
#
# (c) 1999-2000 Marshall T. Rose
# (c) 2000      Brent Welch
# (c) 2000      Sandeep Tamhankar
# (c) 2000      Dan Kuchler
# (c) 2000-2001 Eric Melski
# (c) 2001      Jeff Hobbs
# (c) 2001-2008 Andreas Kupries
# (c) 2002-2003 David Welton
# (c) 2003-2008 Pat Thoyts
# (c) 2005      Benjamin Riefenstahl
# (c) 2013-2018 Poor Yorick
#
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's
# unpublished package of 1999.

        return -options $eopts $result
    }
    return $token
}

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

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

    set params {}

    set state(addcontentid) 1
    set state(addmimeversion) 1
    set state(encoding) {}
    set state(version) 1.0

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

        set option [lindex $args $argx]
        if {[incr argx] >= $argc} {
            error "missing argument to $option"
        }
        set value [lindex $args $argx]

        switch $option {
	    -addcontentid {
		set state(addcontentid) [expr {!!$value}]
	    }
	    -addmimeversion {
		set state(addmimeversion) [expr {!!$value}]
	    }
            -canonical {
		set canonicalP 1
		set type [string tolower $value]
            }

	    -chan {
		set state(file) {}

	    upvar 0 $state(root) root
	    addchan $token $root(fd)
	}
    }


    if {$canonicalP} {
        if {![header exists $token content-id] && $state(addcontentid)} {
	    header::setinternal $token Content-ID [contentid]
        }

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

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

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

    set converter {}

# mime.test - Test suite for TclMIME                     -*- tcl -*-
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# genere totes output for errors.  No output means no errors were found.
#
# Copyright (c) 2000 by Ajuba Solutions
# Copyright (c) 2018 by Poor Yorick
# All rights reserved.
#
# RCS: @(#) $Id: mime.test,v 1.31 2012/02/23 17:35:17 andreas_kupries Exp $

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

source [file join \

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

proc ::ncgi::header {token {type text/html} args} {
    namespace upvar $token cookieOutput cookieOutput
    set mimeout [mime::initialize -canonical $type -addcontentid 0 \
	-addmimeversion 0 -string {}]
    foreach {n v} $args {

	mime::header set $mimeout $n $v {}
    }
    if {[info exists cookieOutput]} {
	foreach line $cookieOutput {
	    mime::header set $mimeout Set-Cookie $line {}
	}
    }
    mime::serialize $mimeout -chan stdout
    flush stdout
}


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

# -*- 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 Poor Yorick 
#
# RCS: @(#) $Id: ncgi.test,v 1.28 2012/05/03 17:56:07 andreas_kupries Exp $

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

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \

	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]


	proc makescript script {
		string map [list @script@ [list $script]] {
			after 0 [list coroutine main try @script@ \
				on error {tres topts} {
				exit 1 
			} finally {
				set done 1
			}]
			vwait done
			exit
		}
	}

	proc resetenv {} {
		global env
		foreach varname {
			CONTENT_LENGTH CONTENT_TYPE HTTP_COOKIE HTTPS QUERY_STRING
			REQUEST_METHOD REQUEST_URI SERVER_NAME SERVER_PORT
	} {
			if {[info exists env($varname)]} {

	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 [makescript [format {
			set auto_path {%s}
			if {[catch {
				source %s
				source %s
				source %s
				ncgi new ncgi1
				ncgi1 redirect %s
				ncgi1 delete
			} err]} {
				puts $err
			}

		} $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 [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			set token [ncgi new {}]
			$token setCookie -name CookieName -value 12345
			$token redirect %s
			$token delete
		} err copts]} {
			puts [dict get $copts -errorinfo]
		}
		exit
		} $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1
		set f [open "|[list $::tcltest::tcltest test1]" r+]
		set res [read $f]
		close $f
		removeFile test1
		set res
	} "Content-Type: text/html\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 [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi new ncgi1
			ncgi1 redirect %s
			ncgi1 delete
		} err]} {
			puts $err
		}
		exit
		} $sub_ap $cmdlFile $futlFile $ncgiFile $URL]] test1
		set f [open "|[list $::tcltest::tcltest test1]" r+]
		set res [read $f]
		close $f
		removeFile test1
		set res
	} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"


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


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


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


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


	test ncgi-12.1 {ncgi::header} {
		makeFile [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi new ncgi1
			ncgi1 header
			ncgi1 delete
		} 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 [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi new ncgi1
			ncgi1 header text/plain
			ncgi1 delete
		} 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 [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi new ncgi1
			ncgi1 header text/html X-Comment "This is a test"
			ncgi1 delete
		} 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 [makescript [format {
		set auto_path {%s}
		if {[catch {
			source %s
			source %s
			source %s
			ncgi new ncgi1
			ncgi1 setCookie -name Name -value {The+Value}
			ncgi1 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"