Tcl Library Source Code

Check-in [37008172d9]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:ncgi use the mime module to generate the response headers mime add -addmimeversion and -addcontentid options
Timelines: family | ancestors | descendants | both | pooryorick
Files: files | file ages | folders
SHA3-256: 37008172d91070993932c701533ba5fcac581c23c1241cc10787f07f92f28a5b
User & Date: pooryorick 2018-11-05 08:09:17
Context
2018-11-20
07:32
mime: Internal rewrite plus API redesign. ncgi: Use mime module instead of bespoke routines. New modules: ego chan. check-in: a9488befa9 user: pooryorick tags: pooryorick
05:38
Refactor struct::disjointset to use the Galler-Fischer disjoint sets data structure, and make 'find-exemplar' and 'merge' into inverse-Ackermann-time functions. check-in: d179e2d8c9 user: kbk tags: kbk-refactor-disjointset, pooryorick
2018-11-17
17:06
Pulling new versions of clay, practcl, dicttol, cron, and tool from the hypnotoad branch. Clay and tool are now build as standalone modules with their own dedicated copies of support code. Clay's embedded software fits inside of the clay namespace. Tool still spreads its seeds all over the global namespace to presever backward compadiblity with older version. Reminder: Clay is the successor to tool. If you are starting new development, you should use clay instead of Tool. Tool has some design limitations and a rather impolite implementation. It should be considered deprecated... as much as anything in tcllib is allowed to be deprectated. Tool is being maintained in its present state to support the Integrated Recoverability Model until its developers get a chance to port Taolib to Clay. check-in: e397dc9470 user: hypnotoad tags: pooryorick
2018-11-05
08:09
ncgi use the mime module to generate the response headers mime add -addmimeversion and -addcontentid options check-in: 37008172d9 user: pooryorick tags: pooryorick
2018-10-29
18:54
mime: Fix problem with content type handling. ncgi: Add object interface, update documentation. check-in: efdd4f9d20 user: pooryorick tags: pooryorick
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to modules/mime/mime.man.

30
31
32
33
34
35
36


37
38
39
40
41
42
43
..
75
76
77
78
79
80
81
82










83
84
85
86
87
88
89

[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 -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.












[para]

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








>
>







 







|
>
>
>
>
>
>
>
>
>
>







30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
..
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101

[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].


Changes to modules/mime/mime.tcl.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
....
2549
2550
2551
2552
2553
2554
2555


2556
2557
2558
2559
2560
2561
2562
....
2575
2576
2577
2578
2579
2580
2581






2582
2583
2584
2585
2586
2587
2588
....
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
....
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
# (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 PoorYorick
#
#
# 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 returnes 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(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 {






            -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]} {
	    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} {
	puts $channel [header serialize $token MIME-Version $state(version) {}]
    }
    foreach {name value} [header get $token] {
	puts $channel [header serialize $token $name {*}$value]
    }

    set converter {}






|







 







|







 







>
>







 







>
>
>
>
>
>







 







|







 







|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
....
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
....
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
....
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
....
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
# (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 {}

Changes to modules/mime/mime.test.

1
2
3
4
5
6
7

8
9
10
11
12
13
14
# 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

# All rights reserved.
#
# RCS: @(#) $Id: mime.test,v 1.31 2012/02/23 17:35:17 andreas_kupries Exp $

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

source [file join \






>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
# 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 \

Changes to modules/ncgi/ncgi.tcl.

365
366
367
368
369
370
371
372

373
374

375
376
377
378
379
380
381
382
383
384
385
386
387
388
#	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
    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::importFile --
#
#   get information about a file upload field






|
>

<
>



|


|







365
366
367
368
369
370
371
372
373
374

375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
#	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

Changes to modules/ncgi/ncgi.test.

2
3
4
5
6
7
8

9
10
11
12
13
14
15
..
28
29
30
31
32
33
34














35
36
37
38
39
40
41
...
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
...
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
...
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
...
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
...
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
...
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
...
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
# 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

#
# 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 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 [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: $URL\n\nPlease go to <a href=\"$URL\">$URL</a>\n"

................................................................................
	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
			set token [ncgi new {}]
			$token setCookie -name CookieName -value 12345
			$token redirect %s
			$token 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\nSet-Cookie: CookieName=12345 ;\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"

................................................................................
	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 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 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 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 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 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-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 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-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 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 [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 [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 [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 [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"







>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
|
|
|
|
|
|
|
|
|
|
|
<
|







 







|









|
|


|







 







|












|







 







|












|







 







|












|







 







|












|







 







|












|









|












|









|












|









|












|









|












|







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
...
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380

381
382
383
384
385
386
387
388
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
...
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
...
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
...
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
...
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
...
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
# 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 @[email protected] [list $script]] {
			after 0 [list coroutine main try @[email protected] \
				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 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 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 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 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"

................................................................................
	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"

................................................................................
	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"