1
##################################################
3
# cgi.tcl - routines for writing CGI scripts in Tcl
4
# Author: Don Libes <libes@nist.gov>, January '95
6
# These routines implement the code described in the paper
7
# "Writing CGI scripts in Tcl" which appeared in the Tcl '96 conference.
8
# Please read the paper before using this code. The paper is:
9
# http://expect.nist.gov/doc/cgi.pdf
11
##################################################
13
##################################################
15
##################################################
17
proc cgi_http_head {args} {
18
global _cgi env errorInfo
20
if {[info exists _cgi(http_head_done)]} return
22
set _cgi(http_head_in_progress) 1
24
if {0 == [llength $args]} {
27
if {[catch {uplevel 1 [lindex $args 0]} errMsg]} {
28
set savedInfo $errorInfo
34
unset _cgi(http_head_in_progress)
35
set _cgi(http_head_done) 1
37
if {[info exists savedInfo]} {
38
error $errMsg $savedInfo
42
# avoid generating http head if not in CGI environment
43
# to allow generation of pure HTML files
44
proc _cgi_http_head_implicit {} {
47
if {[info exists env(REQUEST_METHOD)]} cgi_http_head
50
proc cgi_status {num str} {
53
if {[info exists _cgi(http_status_done)]} return
54
set _cgi(http_status_done) 1
55
cgi_puts "Status: $num $str"
58
# If these are called manually, they automatically generate the extra newline
60
proc cgi_content_type {args} {
63
if {0==[llength $args]} {
66
set t [lindex $args 0]
67
if {[regexp ^multipart/ $t]} {
72
if {[info exists _cgi(http_head_in_progress)]} {
73
cgi_puts "Content-type: $t"
75
cgi_http_head [list cgi_content_type $t]
79
proc cgi_redirect {t} {
82
if {[info exists _cgi(http_head_in_progress)]} {
83
cgi_status 302 Redirected
85
cgi_puts "Location: $t"
93
# deprecated, use cgi_redirect
94
proc cgi_location {t} {
97
if {[info exists _cgi(http_head_in_progress)]} {
98
cgi_puts "Location: $t"
100
cgi_http_head "cgi_location $t"
104
proc cgi_target {t} {
107
if {![info exists _cgi(http_head_in_progress)]} {
108
error "cgi_target must be set from within cgi_http_head."
110
cgi_puts "Window-target: $t"
113
# Make client retrieve url in this many seconds ("client pull").
114
# With no 2nd arg, current url is retrieved.
115
proc cgi_refresh {seconds {url ""}} {
118
if {![info exists _cgi(http_head_in_progress)]} {
119
error "cgi_refresh must be set from within cgi_http_head. Try using cgi_http_equiv instead."
121
cgi_put "Refresh: $seconds"
123
if {0!=[string compare $url ""]} {
129
# Example: cgi_pragma no-cache
130
proc cgi_pragma {arg} {
133
if {![info exists _cgi(http_head_in_progress)]} {
134
error "cgi_pragma must be set from within cgi_http_head."
136
cgi_puts "Pragma: $arg"
139
##################################################
140
# support for debugging or other crucial things we need immediately
141
##################################################
143
proc cgi_comment {args} {} ;# need this asap
145
proc cgi_html_comment {args} {
146
regsub -all {>} $args {\>} args
147
cgi_put "<!--[_cgi_list_to_string $args] -->"
151
proc cgi_debug {args} {
155
set arg [lindex $args 0]
158
set args [lrange $args 1 end]
159
} elseif {$arg == "-off"} {
161
set args [lrange $args 1 end]
162
} elseif {[regexp "^-t" $arg]} {
165
set args [lrange $args 1 end]
166
} elseif {[regexp "^-noprint$" $arg]} {
168
set args [lrange $args 1 end]
171
set arg [lindex $args 0]
173
set args [lrange $args 1 end]
176
if {[llength $args]} {
177
if {$_cgi(debug) == "-on"} {
180
# force http head and open html, head, body
182
if {[info exists noprint]} {
183
uplevel 1 [lindex $args 0]
187
cgi_title "debugging before complete HTML head"
189
# force body open and leave open
191
uplevel 1 [lindex $args 0]
192
# bop back out to catch, so we don't close body
200
if {[info exists temp]} {
206
proc cgi_uid_check {user} {
209
# leave in so old scripts don't blow up
210
if {[regexp "^-off$" $user]} return
212
if {[info exists env(USER)]} {
213
set whoami $env(USER)
214
} elseif {0==[catch {exec whoami} whoami]} {
215
# "who am i" on some Linux hosts returns "" so try whoami first
216
} elseif {0==[catch {exec who am i} whoami]} {
218
regexp "(.*!)?(\[^ \t]*)" $whoami dummy dummy whoami
219
} elseif {0==[catch {package require registry}]} {
220
set whoami [registry get HKEY_LOCAL_MACHINE\\Network\\Logon username]
222
set whoami $user ;# give up and let go
224
if {$whoami != "$user"} {
225
error "Warning: This CGI script expects to run with uid \"$user\". However, this script is running as \"$whoami\"."
229
# print out elements of an array
230
# like Tcl's parray, but formatted for browser
231
proc cgi_parray {a {pattern *}} {
233
if {![array exists array]} {
234
error "\"$a\" isn't an array"
238
foreach name [lsort [array names array $pattern]] {
239
if {[string length $name] > $maxl} {
240
set maxl [string length $name]
244
set maxl [expr {$maxl + [string length $a] + 2}]
245
foreach name [lsort [array names array $pattern]] {
246
set nameString [format %s(%s) $a $name]
247
cgi_puts [cgi_quote_html [format "%-*s = %s" $maxl $nameString $array($name)]]
252
proc cgi_eval {cmd} {
255
# put cmd somewhere that uplevel can find it
259
global env _cgi errorInfo
261
if {1==[catch $_cgi(body) errMsg]} {
262
# error occurred, handle it
263
set _cgi(errorInfo) $errorInfo
265
if {![info exists env(REQUEST_METHOD)]} {
266
puts stderr $_cgi(errorInfo)
269
# the following code is all to force browsers into a state
270
# such that diagnostics can be reliably shown
272
# close irrelevant things
274
# force http head and open html, head, body
277
if {[info exists _cgi(client_error)]} {
278
cgi_h3 "Client Error"
279
cgi_p "$errMsg Report this to your system administrator or browser vendor."
281
cgi_put [cgi_anchor_name cgierror]
282
cgi_h3 "An internal error was detected in the service\
283
software. The diagnostics are being emailed to\
284
the service system administrator ($_cgi(admin_email))."
286
if {$_cgi(debug) == "-on"} {
287
cgi_puts "Heck, since you're debugging, I'll show you the\
289
# suppress formatting
291
cgi_puts [cgi_quote_html $_cgi(errorInfo)]
294
cgi_mail_start $_cgi(admin_email)
295
cgi_mail_add "Subject: [cgi_name] CGI problem"
297
cgi_mail_add "CGI environment:"
298
cgi_mail_add "REQUEST_METHOD: $env(REQUEST_METHOD)"
299
cgi_mail_add "SCRIPT_NAME: $env(SCRIPT_NAME)"
300
# this next few things probably don't need
301
# a catch but I'm not positive
302
catch {cgi_mail_add "HTTP_USER_AGENT: $env(HTTP_USER_AGENT)"}
303
catch {cgi_mail_add "HTTP_REFERER: $env(HTTP_REFERER)"}
304
catch {cgi_mail_add "HTTP_HOST: $env(HTTP_HOST)"}
305
catch {cgi_mail_add "REMOTE_HOST: $env(REMOTE_HOST)"}
306
catch {cgi_mail_add "REMOTE_ADDR: $env(REMOTE_ADDR)"}
307
cgi_mail_add "cgi.tcl version: @CGI_VERSION_FULL@"
308
cgi_mail_add "input:"
309
catch {cgi_mail_add $_cgi(input)}
310
cgi_mail_add "cookie:"
311
catch {cgi_mail_add $env(HTTP_COOKIE)}
312
cgi_mail_add "errorInfo:"
313
cgi_mail_add "$_cgi(errorInfo)"
323
# return true if cgi_eval caught an error
324
proc cgi_error_occurred {} {
327
return [info exists _cgi(errorInfo)]
330
##################################################
332
##################################################
334
# declare location of root of CGI files
335
# this allows all CGI references to be relative in the source
336
# making it easy to move everything in the future
337
# If you have multiple roots, just don't call this.
338
proc cgi_root {args} {
341
if {[llength $args]} {
342
set _cgi(root) [lindex $args 0]
348
# make a URL for a CGI script
349
proc cgi_cgi {args} {
353
if {0!=[string compare $root ""]} {
354
if {![regexp "/$" $root]} {
359
set suffix [cgi_suffix]
361
set arg [lindex $args 0]
362
if {0==[string compare $arg "-suffix"]} {
363
set suffix [lindex $args 1]
364
set args [lrange $args 2 end]
367
if {[llength $args]==1} {
368
return $root[lindex $args 0]$suffix
370
return $root[lindex $args 0]$suffix?[join [lrange $args 1 end] &]
374
proc cgi_suffix {args} {
376
if {[llength $args] > 0} {
377
set _cgi(suffix) [lindex $args 0]
379
if {![info exists _cgi(suffix)]} {
386
proc cgi_cgi_set {variable value} {
387
regsub -all {%} $value "%25" value
388
regsub -all {&} $value "%26" value
389
regsub -all {\+} $value "%2b" value
390
regsub -all { } $value "+" value
391
regsub -all {=} $value "%3d" value
392
regsub -all {#} $value "%23" value
393
regsub -all {/} $value "%2f" value ;# Added...
394
return $variable=$value
397
##################################################
398
# URL dictionary support
399
##################################################
401
proc cgi_link {args} {
404
set tag [lindex $args 0]
405
switch -- [llength $args] {
407
set label $_cgi_link($tag,label)
409
set label [lindex $args end]
411
set _cgi_link($tag,label) [set label [lindex $args 1]]
412
set _cgi_link($tag,url) [lrange $args 2 end]
416
return [eval cgi_url [list $label] $_cgi_link($tag,url)]
419
# same as above but for images
420
# note: uses different namespace
421
proc cgi_imglink {args} {
424
set tag [lindex $args 0]
425
if {[llength $args] >= 2} {
426
set _cgi_imglink($tag) [eval cgi_img [lrange $args 1 end]]
428
return $_cgi_imglink($tag)
431
proc cgi_link_label {tag} {
433
return $_cgi_link($tag,label)
436
proc cgi_link_url {tag} {
438
return $_cgi_link($tag,url)
441
##################################################
443
##################################################
445
# construct a hyperlink labeled "display"
446
# last arg is the link destination
447
# any other args are passed through into <a> display
448
proc cgi_url {display args} {
451
set buf "<a href=\"[lindex $args 0]\""
452
foreach a [lrange $args 1 end] {
453
if {[regexp $_cgi(attr,regexp) $a dummy attr str]} {
454
append buf " $attr=\"$str\""
459
return "$buf>$display</a>"
462
# generate an image reference (<img ...>)
463
# first arg is image url
464
# other args are passed through into <img> tag
465
proc cgi_img {args} {
468
set buf "<img src=\"[lindex $args 0]\""
469
foreach a [lrange $args 1 end] {
470
if {[regexp "^(alt|lowsrc|usemap)=(.*)" $a dummy attr str]} {
471
append buf " $attr=[cgi_dquote_html $str]"
472
} elseif {[regexp $_cgi(attr,regexp) $a dummy attr str]} {
473
append buf " $attr=\"$str\""
481
# names an anchor so that it can be linked to
482
proc cgi_anchor_name {name} {
483
return "<a name=\"$name\"/>"
486
proc cgi_base {args} {
491
if {[regexp "^href=(.*)" $a dummy str]} {
492
cgi_put " href=[cgi_dquote_html $str]"
493
} elseif {[regexp $_cgi(attr,regexp) $a dummy attr str]} {
494
cgi_put " $attr=\"$str\""
502
##################################################
504
##################################################
506
if {[info tclversion] >= 8.2} {
507
proc cgi_unquote_input buf {
508
# rewrite "+" back to space
509
# protect \ from quoting another \ and throwing off other things
510
# replace line delimiters with newlines
511
set buf [string map -nocase [list + { } "\\" "\\\\" %0d%0a \n] $buf]
513
# prepare to process all %-escapes
514
regsub -all -nocase {%([a-f0-9][a-f0-9])} $buf {\\u00\1} buf
516
# process \u unicode mapped chars
517
encoding convertfrom $::_cgi(queryencoding) \
518
[subst -novar -nocommand $buf]
520
} elseif {[info tclversion] >= 8.1} {
521
proc cgi_unquote_input buf {
522
# rewrite "+" back to space
523
regsub -all {\+} $buf { } buf
524
# protect \ from quoting another \ and throwing off other things
525
regsub -all {\\} $buf {\\\\} buf
527
# replace line delimiters with newlines
528
regsub -all -nocase "%0d%0a" $buf "\n" buf
530
# prepare to process all %-escapes
531
regsub -all -nocase {%([a-f0-9][a-f0-9])} $buf {\\u00\1} buf
532
# process \u unicode mapped chars
533
return [subst -novar -nocommand $buf]
536
proc cgi_unquote_input {buf} {
537
# rewrite "+" back to space
538
regsub -all {\+} $buf { } buf
539
# protect \ from quoting another \ and throwing off other things first
540
# protect $ from doing variable expansion
541
# protect [ from doing evaluation
542
# protect " from terminating string
543
regsub -all {([\\["$])} $buf {\\\1} buf
545
# replace line delimiters with newlines
546
regsub -all -nocase "%0d%0a" $buf "\n" buf
547
# Mosaic sends just %0A. This is handled in the next command.
549
# prepare to process all %-escapes
550
regsub -all -nocase {%([a-f0-9][a-f0-9])} $buf {[format %c 0x\1]} buf
551
# process %-escapes and undo all protection
556
# return string but with html-special characters escaped,
557
# necessary if you want to send unknown text to an html-formatted page.
558
proc cgi_quote_html {s} {
559
regsub -all {&} $s {\&} s ;# must be first!
560
regsub -all {"} $s {\"} s
561
regsub -all {<} $s {\<} s
562
regsub -all {>} $s {\>} s
566
proc cgi_dquote_html {s} {
567
return \"[cgi_quote_html $s]\"
570
# return string quoted appropriately to appear in a url
571
proc cgi_quote_url {in} {
572
regsub -all {%} $in "%25" in
573
regsub -all {\+} $in "%2b" in
574
regsub -all { } $in "%20" in
575
regsub -all {"} $in "%22" in
576
regsub -all {\?} $in "%3f" in
580
##################################################
581
# short or single paragraph support
582
##################################################
586
if {[llength $args]} {
587
cgi_put "[_cgi_list_to_string $args]"
592
# generate cgi_h1 and others
593
for {set _cgi(tmp) 1} {$_cgi(tmp)<8} {incr _cgi(tmp)} {
594
proc cgi_h$_cgi(tmp) {{args}} "eval cgi_h $_cgi(tmp) \$args"
596
proc cgi_h {num args} {
598
if {[llength $args] > 1} {
599
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
600
set args [lrange $args end end]
602
cgi_put ">[lindex $args 0]</h$num>"
607
if {[llength $args] > 1} {
608
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
609
set args [lrange $args end end]
611
cgi_put ">[lindex $args 0]</p>"
614
proc cgi_address {s} {cgi_put <address>$s</address>}
615
proc cgi_blockquote {s} {cgi_puts <blockquote>$s</blockquote>}
617
##################################################
618
# long or multiple paragraph support
619
##################################################
621
# Shorthand for <div align=center>. We used to use <center> tags but that
622
# is now officially unsupported.
623
proc cgi_center {cmd} {
624
uplevel 1 "cgi_division align=center [list $cmd]"
627
proc cgi_division {args} {
629
_cgi_close_proc_push "cgi_put </div>"
631
if {[llength $args]} {
632
cgi_put "[_cgi_lrange $args 0 [expr {[llength $args]-2}]]"
635
uplevel 1 [lindex $args end]
639
proc cgi_preformatted {args} {
641
_cgi_close_proc_push "cgi_put </pre>"
643
if {[llength $args]} {
644
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
647
uplevel 1 [lindex $args end]
651
##################################################
653
##################################################
657
if {[llength $args] > 1} {
658
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
660
cgi_put ">[lindex $args end]</li>"
663
proc cgi_number_list {args} {
665
_cgi_close_proc_push "cgi_put </ol>"
667
if {[llength $args] > 1} {
668
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
671
uplevel 1 [lindex $args end]
676
proc cgi_bullet_list {args} {
678
_cgi_close_proc_push "cgi_put </ul>"
680
if {[llength $args] > 1} {
681
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
684
uplevel 1 [lindex $args end]
689
# Following two are normally used from within definition lists
690
# but are actually paragraph types on their own.
691
proc cgi_term {s} {cgi_put <dt>$s</dt>}
692
proc cgi_term_definition {s} {cgi_put <dd>$s</dd>}
694
proc cgi_definition_list {cmd} {
696
_cgi_close_proc_push "cgi_put </dl>"
702
proc cgi_menu_list {cmd} {
704
_cgi_close_proc_push "cgi_put </menu>"
709
proc cgi_directory_list {cmd} {
711
_cgi_close_proc_push "cgi_put </dir>"
717
##################################################
719
##################################################
721
proc cgi_put {s} {cgi_puts -nonewline $s}
723
# some common special characters
724
proc cgi_lt {} {return "<"}
725
proc cgi_gt {} {return ">"}
726
proc cgi_amp {} {return "&"}
727
proc cgi_quote {} {return """}
728
proc cgi_enspace {} {return " "}
729
proc cgi_emspace {} {return " "}
730
proc cgi_nbspace {} {return " "} ;# nonbreaking space
731
proc cgi_tm {} {return "®"} ;# registered trademark
732
proc cgi_copyright {} {return "©"}
733
proc cgi_isochar {n} {return "&#$n;"}
734
proc cgi_breakable {} {return "<wbr />"}
736
proc cgi_unbreakable_string {s} {return "<nobr>$s</nobr>"}
737
proc cgi_unbreakable {cmd} {
739
_cgi_close_proc_push "cgi_put </nobr>"
746
if {[llength $args]} {
747
append buf "[_cgi_list_to_string $args]"
752
proc cgi_bold {s} {return "<b>$s</b>"}
753
proc cgi_italic {s} {return "<i>$s</i>"}
754
proc cgi_underline {s} {return "<u>$s</u>"}
755
proc cgi_strikeout {s} {return "<s>$s</s>"}
756
proc cgi_subscript {s} {return "<sub>$s</sub>"}
757
proc cgi_superscript {s} {return "<sup>$s</sup>"}
758
proc cgi_typewriter {s} {return "<tt>$s</tt>"}
759
proc cgi_blink {s} {return "<blink>$s</blink>"}
760
proc cgi_emphasis {s} {return "<em>$s</em>"}
761
proc cgi_strong {s} {return "<strong>$s</strong>"}
762
proc cgi_cite {s} {return "<cite>$s</cite>"}
763
proc cgi_sample {s} {return "<samp>$s</samp>"}
764
proc cgi_keyboard {s} {return "<kbd>$s</kbd>"}
765
proc cgi_variable {s} {return "<var>$s</var>"}
766
proc cgi_definition {s} {return "<dfn>$s</dfn>"}
767
proc cgi_big {s} {return "<big>$s</big>"}
768
proc cgi_small {s} {return "<small>$s</small>"}
770
proc cgi_basefont {size} {cgi_put "<basefont size=$size />"}
772
proc cgi_font {args} {
776
foreach a [lrange $args 0 [expr [llength $args]-2]] {
777
if {[regexp $_cgi(attr,regexp) $a dummy attr str]} {
778
append buf " $attr=\"$str\""
783
return "$buf>[lindex $args end]</font>"
786
# take a cgi func and have it return what would normally print
787
# This command is reentrant (that's why it's so complex).
788
proc cgi_buffer {cmd} {
791
if {0==[info exists _cgi(returnIndex)]} {
792
set _cgi(returnIndex) 0
795
rename cgi_puts cgi_puts$_cgi(returnIndex)
796
incr _cgi(returnIndex)
797
set _cgi(return[set _cgi(returnIndex)]) ""
801
upvar #0 _cgi(return[set _cgi(returnIndex)]) buffer
803
append buffer [lindex $args end]
804
if {[llength $args] == 1} {
805
append buffer $_cgi(buffer_nl)
809
# must restore things before allowing the eval to fail
810
# so catch here and rethrow later
811
if {[catch {uplevel 1 $cmd} errMsg]} {
813
set savedInfo $errorInfo
816
# not necessary to put remainder of code in close_proc_push since it's
817
# all buffered anyway and hasn't yet put browser into a funky state.
819
set buffer $_cgi(return[set _cgi(returnIndex)])
821
incr _cgi(returnIndex) -1
823
rename cgi_puts$_cgi(returnIndex) cgi_puts
825
if {[info exists savedInfo]} {
826
error $errMsg $savedInfo
831
set _cgi(buffer_nl) "\n"
832
proc cgi_buffer_nl {nl} {
835
set old $_cgi(buffer_nl)
836
set _cgi(buffer_nl) $nl
840
##################################################
841
# html and tags that can appear in html top-level
842
##################################################
844
proc cgi_html {args} {
845
set html [lindex $args end]
846
set argc [llength $args]
848
eval _cgi_html_start [lrange $args 0 [expr {$argc-2}]]
856
proc _cgi_html_start {args} {
859
if {[info exists _cgi(html_in_progress)]} return
860
_cgi_http_head_implicit
862
set _cgi(html_in_progress) 1
867
if {[regexp $_cgi(attr,regexp) $a dummy attr str]} {
868
append buf " $attr=\"$str\""
876
proc _cgi_html_end {} {
878
unset _cgi(html_in_progress)
879
set _cgi(html_done) 1
883
# force closure of all tags and exit without going through normal returns.
884
# Very useful if you want to call exit from a deeply stacked CGI script
885
# and still have the HTML be correct.
888
cgi_html {cgi_body {}}
892
##################################################
894
##################################################
896
proc cgi_head {{head {}}} {
899
if {[info exists _cgi(head_done)]} {
903
# allow us to be recalled so that we can display errors
904
if {0 == [info exists _cgi(head_in_progress)]} {
905
_cgi_http_head_implicit
906
set _cgi(head_in_progress) 1
910
# prevent cgi_html (during error handling) from generating html tags
911
set _cgi(html_in_progress) 1
912
# don't actually generate html tags since there's nothing to clean
915
if {0 == [string length $head]} {
916
if {[catch {cgi_title}]} {
917
set head "cgi_title untitled"
921
if {![info exists _cgi(head_suppress_tag)]} {
924
unset _cgi(head_suppress_tag)
927
set _cgi(head_done) 1
929
# debugging can unset this in the uplevel above
930
catch {unset _cgi(head_in_progress)}
933
# with one arg: set, print, and return title
934
# with no args: return title
935
proc cgi_title {args} {
938
set title [lindex $args 0]
940
if {[llength $args]} {
941
_cgi_http_head_implicit
943
# we could just generate <head></head> tags, but head-level commands
944
# might follow so just suppress the head tags entirely
945
if {![info exists _cgi(head_in_progress)]} {
946
set _cgi(head_in_progress) 1
947
set _cgi(head_suppress_tag) 1
950
set _cgi(title) $title
951
cgi_puts "<title>$title</title>"
956
# This tag can only be called from with cgi_head.
957
# example: cgi_http_equiv Refresh 1
958
# There's really no reason to call this since it can be done directly
959
# from cgi_http_head.
960
proc cgi_http_equiv {type contents} {
961
_cgi_http_head_implicit
962
cgi_puts "<meta http-equiv=\"$type\" content=[cgi_dquote_html $contents]/>"
965
# Do whatever you want with meta tags.
966
# Example: <meta name="author" content="Don Libes">
967
proc cgi_meta {args} {
970
if {[regexp "^(name|content|http-equiv)=(.*)" $a dummy attr str]} {
971
cgi_put " $attr=[cgi_dquote_html $str]"
979
proc cgi_relationship {rel href args} {
980
cgi_puts "<link rel=$rel href=\"$href\""
982
if {[regexp "^title=(.*)" $a dummy str]} {
983
cgi_put " title=[cgi_dquote_html $str]"
984
} elseif {[regexp "^type=(.*)" $a dummy str]} {
985
cgi_put " type=[cgi_dquote_html $str]"
993
proc cgi_name {args} {
996
if {[llength $args]} {
997
set _cgi(name) [lindex $args 0]
1002
##################################################
1003
# body and other top-level support
1004
##################################################
1006
proc cgi_body {args} {
1007
global errorInfo errorCode _cgi
1009
# allow user to "return" from the body without missing _cgi_body_end
1011
eval _cgi_body_start [lrange $args 0 [expr [llength $args]-2]]
1012
uplevel 1 [lindex $args end]
1014
set savedInfo $errorInfo
1015
set savedCode $errorCode
1016
error $errMsg $savedInfo $savedCode
1021
proc _cgi_body_start {args} {
1023
if {[info exists _cgi(body_in_progress)]} return
1027
set _cgi(body_in_progress) 1
1030
foreach a "$args $_cgi(body_args)" {
1031
if {[regexp "^(background|bgcolor|text|link|vlink|alink|onLoad|onUnload)=(.*)" $a dummy attr str]} {
1032
cgi_put " $attr=\"$str\""
1041
catch {cgi_puts "Input: <pre>$_cgi(input)</pre>"}
1042
catch {cgi_puts "Cookie: <pre>$env(HTTP_COOKIE)</pre>"}
1045
if {![info exists _cgi(errorInfo)]} {
1046
uplevel 2 app_body_start
1050
proc _cgi_body_end {} {
1052
if {![info exists _cgi(errorInfo)]} {
1053
uplevel 2 app_body_end
1055
unset _cgi(body_in_progress)
1058
if {[info exists _cgi(multipart)]} {
1059
unset _cgi(http_head_done)
1060
catch {unset _cgi(http_status_done)}
1061
unset _cgi(head_done)
1062
catch {unset _cgi(head_suppress_tag)}
1066
proc cgi_body_args {args} {
1069
set _cgi(body_args) $args
1072
proc cgi_script {args} {
1073
cgi_puts "<script[_cgi_lrange $args 0 [expr [llength $args]-2]]>"
1074
_cgi_close_proc_push "cgi_puts </script>"
1076
uplevel 1 [lindex $args end]
1081
proc cgi_javascript {args} {
1082
cgi_puts "<script[_cgi_lrange $args 0 [expr [llength $args]-2]]>"
1083
cgi_puts "<!--- Hide script from browsers that don't understand JavaScript"
1084
_cgi_close_proc_push {cgi_puts "// End hiding -->\n</script>"}
1086
uplevel 1 [lindex $args end]
1091
proc cgi_noscript {args} {
1092
cgi_puts "<noscript[_cgi_lrange $args 0 [expr [llength $args]-2]]>"
1093
_cgi_close_proc_push {cgi_puts "</noscript>"}
1095
uplevel 1 [lindex $args end]
1100
proc cgi_applet {args} {
1101
cgi_puts "<applet[_cgi_lrange $args 0 [expr [llength $args]-2]]>"
1102
_cgi_close_proc_push "cgi_puts </applet>"
1104
uplevel 1 [lindex $args end]
1108
proc cgi_param {nameval} {
1109
regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value
1114
cgi_puts "<param name=\"$name\" value=[cgi_dquote_html $value]/>"
1117
# record any proc's that must be called prior to displaying an error
1118
proc _cgi_close_proc_push {p} {
1120
if {![info exists _cgi(close_proc)]} {
1121
set _cgi(close_proc) ""
1123
set _cgi(close_proc) "$p; $_cgi(close_proc)"
1126
proc _cgi_close_proc_pop {} {
1128
regexp "^(\[^;]*);(.*)" $_cgi(close_proc) dummy lastproc _cgi(close_proc)
1132
# generic proc to close whatever is on the top of the stack
1133
proc _cgi_close_proc {} {
1134
eval [_cgi_close_proc_pop]
1137
proc _cgi_close_procs {} {
1141
if {[info exists _cgi(close_proc)]} {
1142
uplevel #0 $_cgi(close_proc)
1146
proc _cgi_close_tag {} {
1149
if {[info exists _cgi(tag_in_progress)]} {
1151
unset _cgi(tag_in_progress)
1155
##################################################
1157
##################################################
1159
proc cgi_hr {args} {
1162
if {[regexp "^width=(.*)" $a dummy str]} {
1163
append buf " width=\"$str\""
1171
##################################################
1173
##################################################
1175
proc cgi_form {action args} {
1178
_cgi_form_multiple_check
1179
set _cgi(form_in_progress) 1
1181
_cgi_close_proc_push _cgi_form_end
1182
cgi_put "<form action="
1183
if {[regexp {^[a-z]*:} $action]} {
1184
cgi_put "\"$action\""
1186
cgi_put "\"[cgi_cgi $action]\""
1188
set method "method=post"
1189
foreach a [lrange $args 0 [expr [llength $args]-2]] {
1190
if {[regexp "^method=" $a]} {
1192
} elseif {[regexp "^(target|onReset|onSubmit)=(.*)" $a dummy attr str]} {
1193
cgi_put " $attr=\"$str\""
1194
} elseif {[regexp "^enctype=(.*)" $a dummy str]} {
1195
cgi_put " enctype=\"$str\""
1196
set _cgi(form,enctype) $str
1202
uplevel 1 [lindex $args end]
1203
catch {unset _cgi(form,enctype)}
1207
proc _cgi_form_end {} {
1209
unset _cgi(form_in_progress)
1213
proc _cgi_form_multiple_check {} {
1215
if {[info exists _cgi(form_in_progress)]} {
1216
error "Cannot create form (or isindex) with form already in progress."
1220
proc cgi_isindex {args} {
1221
_cgi_form_multiple_check
1225
if {[regexp "^href=(.*)" $a dummy str]} {
1226
cgi_put " href=\"$str\""
1227
} elseif {[regexp "^prompt=(.*)" $a dummy str]} {
1228
cgi_put " prompt=[cgi_dquote_html $str]"
1236
##################################################
1238
##################################################
1240
proc cgi_input {{fakeinput {}} {fakecookie {}}} {
1241
global env _cgi _cgi_uservar _cgi_cookie _cgi_cookie_shadowed
1243
set _cgi(uservars) {}
1244
set _cgi(uservars,autolist) {}
1246
if {[info exists env(CONTENT_TYPE)] && [regexp ^multipart/form-data $env(CONTENT_TYPE)]} {
1247
if {![info exists env(REQUEST_METHOD)]} {
1249
set fid [open $fakeinput]
1253
if {([info tclversion] >= 8.1) || [catch exp_version] || [info exists _cgi(no_binary_upload)]} {
1254
_cgi_input_multipart $fid
1256
_cgi_input_multipart_binary $fid
1259
if {![info exists env(REQUEST_METHOD)]} {
1260
set input $fakeinput
1261
set env(HTTP_COOKIE) $fakecookie
1262
} elseif { $env(REQUEST_METHOD) == "GET" } {
1264
catch {set input $env(QUERY_STRING)} ;# doesn't have to be set
1265
} elseif { $env(REQUEST_METHOD) == "HEAD" } {
1267
} elseif {![info exists env(CONTENT_LENGTH)]} {
1268
set _cgi(client_error) 1
1269
error "Your browser failed to generate the content-length during a POST method."
1271
set length $env(CONTENT_LENGTH)
1272
if {0!=[string compare $length "-1"]} {
1273
set input [read stdin $env(CONTENT_LENGTH)]
1275
set _cgi(client_error) 1
1276
error "Your browser generated a content-length of -1 during a POST method."
1278
if {[info tclversion] >= 8.1} {
1279
# guess query encoding from Content-Type header
1280
if {[info exists env(CONTENT_TYPE)] \
1281
&& [regexp -nocase -- {charset=([^[:space:]]+)} $env(CONTENT_TYPE) m cs]} {
1282
if {[regexp -nocase -- {iso-?8859-([[:digit:]]+)} $cs m d]} {
1283
set _cgi(queryencoding) "iso8859-$d"
1284
} elseif {[regexp -nocase -- {windows-([[:digit:]]+)} $cs m d]} {
1285
set _cgi(queryencoding) "cp$d"
1286
} elseif {0==[string compare -nocase $cs "utf-8"]} {
1287
set _cgi(queryencoding) "utf-8"
1288
} elseif {0==[string compare -nocase $cs "utf-16"]} {
1289
set _cgi(queryencoding) "unicode"
1292
set _cgi(queryencoding) [encoding system]
1296
# save input for possible diagnostics later
1297
set _cgi(input) $input
1299
set pairs [split $input &]
1300
foreach pair $pairs {
1301
if {0 == [regexp "^(\[^=]*)=(.*)$" $pair dummy varname val]} {
1302
# if no match, unquote and leave it at that
1303
# this is typical of <isindex>-style queries
1304
set varname anonymous
1308
set varname [cgi_unquote_input $varname]
1309
set val [cgi_unquote_input $val]
1310
_cgi_set_uservar $varname $val
1314
# O'Reilly's web server incorrectly uses COOKIE
1315
catch {set env(HTTP_COOKIE) $env(COOKIE)}
1316
if {![info exists env(HTTP_COOKIE)]} return
1317
foreach pair [split $env(HTTP_COOKIE) ";"] {
1318
# pairs are actually split by "; ", sigh
1319
set pair [string trimleft $pair " "]
1320
# spec is not clear but seems to allow = unencoded
1321
# only sensible interpretation is to assume no = in var names
1322
# appears MS IE can omit "=val"
1324
regexp (\[^=]*)=?(.*) $pair dummy varname val
1326
set varname [cgi_unquote_input $varname]
1327
set val [cgi_unquote_input $val]
1329
if {[info exists _cgi_cookie($varname)]} {
1330
lappend _cgi_cookie_shadowed($varname) $val
1332
set _cgi_cookie($varname) $val
1337
proc _cgi_input_multipart {fin} {
1338
global env _cgi _cgi_uservar _cgi_userfile
1340
cgi_debug -noprint {
1341
# save file for debugging purposes
1342
set dbg_filename [file join $_cgi(tmpdir) CGIdbg.[pid]]
1343
# explicitly flush all writes to fout, because sometimes the writer
1344
# can hang and we won't get to the termination code
1345
set dbg_fout [open $dbg_filename w $_cgi(tmpperms)]
1346
set _cgi(input) $dbg_filename
1347
catch {fconfigure $dbg_fout -translation binary}
1350
# figure out boundary
1351
if {0==[regexp boundary=(.*) $env(CONTENT_TYPE) dummy boundary]} {
1352
set _cgi(client_error) 1
1353
error "Your browser failed to generate a \"boundary=\" line in a multipart response (CONTENT_TYPE: $env(CONTENT_TYPE)). Please upgrade (or fix) your browser."
1356
# make boundary into a legal regsub pattern by protecting #
1357
# legal boundary characters include ()+.? (among others)
1358
regsub -all "\\(" $boundary "\\(" boundary
1359
regsub -all "\\)" $boundary "\\)" boundary
1360
regsub -all "\\+" $boundary "\\+" boundary
1361
regsub -all "\\." $boundary "\\." boundary
1362
regsub -all "\\?" $boundary "\\?" boundary
1364
set boundary --$boundary
1366
# don't corrupt or modify uploads yet allow Tcl 7.4 to work
1367
catch {fconfigure $fin -translation binary}
1369
# get first boundary line
1371
if {[info exists dbg_fout]} {puts $dbg_fout $buf; flush $dbg_fout}
1373
set _cgi(file,filecount) 0
1376
# process Content-Disposition:
1377
if {-1 == [gets $fin buf]} break
1378
if {[info exists dbg_fout]} {puts $dbg_fout $buf; flush $dbg_fout}
1379
catch {unset filename}
1380
regexp {name="([^"]*)"} $buf dummy varname
1381
if {0==[info exists varname]} {
1382
# lynx violates spec and doesn't use quotes, so try again but
1383
# assume space is delimiter
1384
regexp {name=([^ ]*)} $buf dummy varname
1385
if {0==[info exists varname]} {
1386
set _cgi(client_error) 1
1387
error "In response to a request for a multipart form, your browser generated a part header without a name field. Please upgrade (or fix) your browser."
1390
# Lame-o encoding (on Netscape at least) doesn't escape field
1391
# delimiters (like quotes)!! Since all we've ever seen is filename=
1392
# at end of line, assuming nothing follows. Sigh.
1393
regexp {filename="(.*)"} $buf dummy filename
1395
# Skip remaining headers until blank line.
1396
# Content-Type: can appear here.
1399
if {-1 == [gets $fin buf]} break
1400
if {[info exists dbg_fout]} {puts $dbg_fout $buf; flush $dbg_fout}
1401
if {0==[string compare $buf "\r"]} break
1402
regexp -nocase "^Content-Type:\[ \t]+(.*)\r" $buf x conttype
1405
if {[info exists filename]} {
1406
if {$_cgi(file,filecount) > $_cgi(file,filelimit)} {
1407
error "Too many files submitted. Max files allowed: $_cgi(file,filelimit)"
1410
# read the part into a file
1411
set foutname [file join $_cgi(tmpdir) CGI[pid].[incr _cgi(file,filecount)]]
1412
set fout [open $foutname w $_cgi(tmpperms)]
1413
# "catch" permits this to work with Tcl 7.4
1414
catch {fconfigure $fout -translation binary}
1415
_cgi_set_uservar $varname [list $foutname $filename $conttype]
1416
set _cgi_userfile($varname) [list $foutname $filename $conttype]
1419
# Look for a boundary line preceded by \r\n.
1421
# To do this, we buffer line terminators that might
1422
# be the start of the special \r\n$boundary sequence.
1423
# The buffer is called "leftover" and is just inserted
1424
# into the front of the next output (assuming it's
1425
# not a boundary line).
1429
if {-1 == [gets $fin buf]} break
1430
if {[info exists dbg_fout]} {puts $dbg_fout $buf; flush $dbg_fout}
1432
if {0 == [string compare "\r\n" $leftover]} {
1433
if {[regexp ^[set boundary](--)?\r?$ $buf dummy dashdash]} {
1434
if {$dashdash == "--"} {set eof 1}
1438
if {[regexp (.*)\r$ $buf x data]} {
1439
puts -nonewline $fout $leftover$data
1442
puts -nonewline $fout $leftover$buf
1445
if {[file size $foutname] > $_cgi(file,charlimit)} {
1446
error "File size exceeded. Max file size allowed: $_cgi(file,charlimit)"
1453
# read the part into a variable
1457
if {-1 == [gets $fin buf]} break
1458
if {[info exists dbg_fout]} {puts $dbg_fout $buf; flush $dbg_fout}
1459
if {[regexp ^[set boundary](--)?\r?$ $buf dummy dashdash]} {
1460
if {$dashdash == "--"} {set eof 1}
1463
if {0!=[string compare $val ""]} {
1466
regexp (.*)\r$ $buf dummy buf
1467
if {[info exists blanks]} {
1468
if {0!=[string compare $buf ""]} {
1470
append val [string repeat \n [incr blanks]]
1479
_cgi_set_uservar $varname $val
1481
if {[info exists eof]} break
1483
if {[info exists dbg_fout]} {close $dbg_fout}
1486
proc _cgi_input_multipart_binary {fin} {
1487
global env _cgi _cgi_uservar _cgi_userfile
1492
cgi_debug -noprint {
1493
# save file for debugging purposes
1494
set dbg_filename [file join $_cgi(tmpdir) CGIdbg.[pid]]
1495
set _cgi(input) $dbg_filename
1496
spawn -open [open $dbg_filename w $_cgi(tmpperms)]
1497
set dbg_sid $spawn_id
1500
set fin_sid $spawn_id
1504
# dump input to screen
1509
-re ^\r {puts -nonewline "CR"; exp_continue}
1510
-re ^\n {puts "NL"; exp_continue}
1511
-re . {puts -nonewline $expect_out(buffer); exp_continue}
1518
# figure out boundary
1519
if {0==[regexp boundary=(.*) $env(CONTENT_TYPE) dummy boundary]} {
1520
set _cgi(client_error) 1
1521
error "Your browser failed to generate a \"boundary=\" definition in a multipart response (CONTENT_TYPE: $env(CONTENT_TYPE)). Please upgrade (or fix) your browser."
1524
# make boundary into a legal regsub pattern by protecting #
1525
# legal boundary characters include ()+.? (among others)
1526
regsub -all "\\(" $boundary "\\(" boundary
1527
regsub -all "\\)" $boundary "\\)" boundary
1528
regsub -all "\\+" $boundary "\\+" boundary
1529
regsub -all "\\." $boundary "\\." boundary
1530
regsub -all "\\?" $boundary "\\?" boundary
1532
set boundary --$boundary
1533
set linepat "(\[^\r]*)\r\n"
1535
# get first boundary line
1539
set buf $expect_out(1,string)
1540
if {[info exists dbg_sid]} {send -i $dbg_sid -- $buf\n}
1543
set _cgi(client_error) 1
1544
error "Your browser failed to provide an initial boundary ($boundary) in a multipart response. Please upgrade (or fix) your browser."
1548
set _cgi(file,filecount) 0
1551
# process Content-Disposition:
1555
set buf $expect_out(1,string)
1556
if {[info exists dbg_sid]} {send -i $dbg_sid -- $buf\n}
1560
catch {unset filename}
1561
regexp {name="([^"]*)"} $buf dummy varname
1562
if {0==[info exists varname]} {
1563
set _cgi(client_error) 1
1564
error "In response to a request for a multipart form, your browser generated a part header without a name field. Please upgrade (or fix) your browser."
1567
# Lame-o encoding (on Netscape at least) doesn't escape field
1568
# delimiters (like quotes)!! Since all we've ever seen is filename=
1569
# at end of line, assuming nothing follows. Sigh.
1570
regexp {filename="(.*)"} $buf dummy filename
1572
# Skip remaining headers until blank line.
1573
# Content-Type: can appear here.
1578
set buf $expect_out(1,string)
1579
if {[info exists dbg_sid]} {send -i $dbg_sid -- $buf\n}
1580
if {0!=[string compare $buf ""]} exp_continue
1581
regexp -nocase "^Content-Type:\[ \t]+(.*)\r" $buf x conttype
1586
if {[info exists filename]} {
1587
if {$_cgi(file,filecount) > $_cgi(file,filelimit)} {
1588
error "Too many files submitted. Max files allowed: $_cgi(file,filelimit)"
1591
# read the part into a file
1592
set foutname [file join $_cgi(tmpdir) CGI[pid].[incr _cgi(file,filecount)]]
1593
spawn -open [open $foutname w $_cgi(tmpperms)]
1594
set fout_sid $spawn_id
1596
_cgi_set_uservar $varname [list $foutname $filename $conttype]
1597
set _cgi_userfile($varname) [list $foutname $filename $conttype]
1599
# This is tricky stuff - be very careful changing anything here!
1600
# In theory, all we have to is record everything up to
1601
# \r\n$boundary\r\n. Unfortunately, we can't simply wait on
1602
# such a pattern because the input can overflow any possible
1603
# buffer we might choose. We can't simply catch buffer_full
1604
# because the boundary might straddle a buffer. I doubt that
1605
# doing my own buffering would be any faster than taking the
1606
# approach I've done here.
1608
# The code below basically implements a simple scanner that
1609
# keeps track of whether it's seen crlfs or pieces of them.
1610
# The idea is that we look for crlf pairs, separated by
1611
# things that aren't crlfs (or pieces of them). As we encounter
1612
# things that aren't crlfs (or pieces of them), or when we decide
1613
# they can't be, we mark them for output and resume scanning for
1616
# The scanner runs tolerably fast because the [...]+ pattern picks
1617
# up most things. The \r and \n are ^-anchored so the pattern
1618
# match is pretty fast and these don't happen that often so the
1619
# huge \n action is executed rarely (once per line on text files).
1620
# The null pattern is, of course, only used when everything
1623
# crlf == "\r\n" if we've seen one, else == ""
1624
# cr == "\r" if we JUST saw one, else == ""
1625
# Yes, strange, but so much more efficient
1626
# that I'm willing to sacrifice readability, sigh.
1627
# buf accumulated data between crlf pairs
1643
if {$crlf == "\r\n"} {
1645
if {[regexp ^[set boundary](--)?$ $buf dummy dashdash]} {
1646
if {$dashdash == "--"} {
1650
# boundary test failed
1651
if {[info exists dbg_sid]} {send -i $dbg_sid -- \r\n$buf}
1652
send -i $fout_sid \r\n$buf ; set buf ""
1659
if {[info exists dbg_sid]} {send -i $dbg_sid -- $buf}
1660
send -i $fout_sid -- $buf ; set buf ""
1664
if {[info exists dbg_sid]} {send -i $dbg_sid -- $crlf$buf\n}
1665
send -i $fout_sid -- $crlf$buf\n ; set buf ""
1671
set buf $crlf$buf\r$expect_out(buffer)
1675
append buf $expect_out(buffer)
1679
if {[info exists dbg_sid]} {
1680
send -i $dbg_sid -- $crlf$buf$cr
1681
send -i $dbg_sid -null
1683
send -i $fout_sid -- $crlf$buf$cr ; set buf ""
1684
send -i $fout_sid -null
1689
set _cgi(client_error) 1
1690
error "Your browser failed to provide an ending boundary ($boundary) in a multipart response. Please upgrade (or fix) your browser."
1693
exp_close -i $fout_sid ;# implicitly closes fout
1694
exp_wait -i $fout_sid
1697
# read the part into a variable
1702
set buf $expect_out(1,string)
1703
if {[info exists dbg_sid]} {send -i $dbg_sid -- $buf\n}
1704
if {[regexp ^[set boundary](--)?$ $buf dummy dashdash]} {
1705
if {$dashdash == "--"} {set eof 1}
1707
regexp (.*)\r$ $buf dummy buf
1708
if {0!=[string compare $val ""]} {
1716
_cgi_set_uservar $varname $val
1718
if {[info exists eof]} break
1720
if {[info exists fout]} {
1721
exp_close -i $dbg_sid
1722
exp_wait -i $dbg_sid
1725
# no need to close fin, fin_sid, or dbg_sid
1728
# internal routine for defining user variables
1729
proc _cgi_set_uservar {varname val} {
1730
global _cgi _cgi_uservar
1732
set exists [info exists _cgi_uservar($varname)]
1734
# anything we've seen before and is being set yet again necessarily
1735
# has to be (or become a list)
1738
lappend _cgi(uservars) $varname
1741
if {[regexp List$ $varname]} {
1743
} elseif {$exists} {
1744
# vars that we've seen before but aren't marked as lists
1745
# need to be "listified" so we can do appends later
1746
if {-1 == [lsearch $_cgi(uservars,autolist) $varname]} {
1747
# remember that we've listified it
1748
lappend _cgi(uservars,autolist) $varname
1749
set _cgi_uservar($varname) [list $_cgi_uservar($varname)]
1753
lappend _cgi_uservar($varname) $val
1755
set _cgi_uservar($varname) $val
1759
# export named variable
1760
proc cgi_export {nameval} {
1761
regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value
1764
set value [uplevel 1 set [list $name]]
1767
cgi_put "<input type=hidden name=\"$name\" value=[cgi_dquote_html $value]/>"
1770
proc cgi_export_cookie {name args} {
1772
eval cgi_cookie_set [list $name=$x] $args
1775
# return list of variables available for import
1776
# Explicit list is used to keep items in order originally found in form.
1777
proc cgi_import_list {} {
1780
return $_cgi(uservars)
1783
# import named variable
1784
proc cgi_import {name} {
1788
set var $_cgi_uservar($name)
1791
proc cgi_import_as {name tclvar} {
1795
set var $_cgi_uservar($name)
1798
# like cgi_import but if not available, try cookie
1799
proc cgi_import_cookie {name} {
1803
if {0==[catch {set var $_cgi_uservar($name)}]} return
1804
set var [cgi_cookie_get $name]
1807
# like cgi_import but if not available, try cookie
1808
proc cgi_import_cookie_as {name tclvar} {
1812
if {0==[catch {set var $_cgi_uservar($name)}]} return
1813
set var [cgi_cookie_get $name]
1816
proc cgi_import_file {type name} {
1817
global _cgi_userfile
1820
set var $_cgi_userfile($name)
1832
# deprecated, use cgi_import_file
1833
proc cgi_import_filename {type name} {
1834
global _cgi_userfile
1837
set var $_cgi_userfile($name)
1838
if {$type == "-server" || $type == "-local"} {
1839
# -local is deprecated
1846
# set the urlencoding
1847
proc cgi_urlencoding {{encoding ""}} {
1850
set result [expr {[info exists _cgi(queryencoding)]
1851
? $_cgi(queryencoding)
1854
# check if the encoding is available
1855
if {[info tclversion] >= 8.1
1856
&& [lsearch -exact [encoding names] $encoding] != -1 } {
1857
set _cgi(queryencoding) $encoding
1863
##################################################
1865
##################################################
1867
# not sure about arg handling, do we need to support "name="?
1868
proc cgi_button {value args} {
1869
cgi_put "<input type=button value=[cgi_dquote_html $value]"
1871
if {[regexp "^onClick=(.*)" $a dummy str]} {
1872
cgi_put " onClick=\"$str\""
1880
# Derive a button from a link predefined by cgi_link
1881
proc cgi_button_link {args} {
1884
set tag [lindex $args 0]
1885
if {[llength $args] == 2} {
1886
set label [lindex $args end]
1888
set label $_cgi_link($tag,label)
1891
cgi_button $label onClick=$_cgi_link($tag,url)
1894
proc cgi_submit_button {{nameval {=Submit Query}} args} {
1895
regexp "(\[^=]*)=(.*)" $nameval dummy name value
1896
cgi_put "<input type=submit"
1897
if {0!=[string compare "" $name]} {
1898
cgi_put " name=\"$name\""
1900
cgi_put " value=[cgi_dquote_html $value]"
1902
if {[regexp "^onClick=(.*)" $a dummy str]} {
1903
cgi_put " onClick=\"$str\""
1912
proc cgi_reset_button {{value Reset} args} {
1913
cgi_put "<input type=reset value=[cgi_dquote_html $value]"
1916
if {[regexp "^onClick=(.*)" $a dummy str]} {
1917
cgi_put " onClick=\"$str\""
1925
proc cgi_radio_button {nameval args} {
1926
regexp "(\[^=]*)=(.*)" $nameval dummy name value
1928
cgi_put "<input type=radio name=\"$name\" value=[cgi_dquote_html $value]"
1931
if {[regexp "^checked_if_equal=(.*)" $a dummy default]} {
1932
if {0==[string compare $default $value]} {
1935
} elseif {[regexp "^checked=(.*)" $a dummy checked]} {
1936
# test explicitly to avoid forcing user eval
1940
} elseif {[regexp "^onClick=(.*)" $a dummy str]} {
1941
cgi_put " onClick=\"$str\""
1949
proc cgi_image_button {nameval args} {
1950
regexp "(\[^=]*)=(.*)" $nameval dummy name value
1951
cgi_put "<input type=image"
1952
if {0!=[string compare "" $name]} {
1953
cgi_put " name=\"$name\""
1955
cgi_put " src=\"$value\""
1957
if {[regexp "^onClick=(.*)" $a dummy str]} {
1958
cgi_put " onClick=\"$str\""
1966
# map/area implement client-side image maps
1967
proc cgi_map {name cmd} {
1968
cgi_put "<map name=\"$name\">"
1969
_cgi_close_proc_push "cgi_put </map>"
1975
proc cgi_area {args} {
1978
if {[regexp "^(coords|shape|href|target|onMouseOut|alt)=(.*)" $a dummy attr str]} {
1979
cgi_put " $attr=\"$str\""
1987
##################################################
1989
##################################################
1991
proc cgi_checkbox {nameval args} {
1992
regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value
1993
cgi_put "<input type=checkbox name=\"$name\""
1995
if {0!=[string compare "" $value]} {
1996
cgi_put " value=[cgi_dquote_html $value]"
2000
if {[regexp "^checked_if_equal=(.*)" $a dummy default]} {
2001
if {0==[string compare $default $value]} {
2004
} elseif {[regexp "^checked=(.*)" $a dummy checked]} {
2005
# test explicitly to avoid forcing user eval
2009
} elseif {[regexp "^onClick=(.*)" $a dummy str]} {
2010
cgi_put " onClick=\"$str\""
2018
##################################################
2020
##################################################
2022
proc cgi_text {nameval args} {
2023
regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value
2025
cgi_put "<input name=\"$name\""
2028
set value [uplevel 1 set [list $name]]
2030
cgi_put " value=[cgi_dquote_html $value]"
2033
if {[regexp "^on(Select|Focus|Blur|Change)=(.*)" $a dummy event str]} {
2034
cgi_put " on$event=\"$str\""
2042
##################################################
2044
##################################################
2046
proc cgi_textarea {nameval args} {
2047
regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value
2049
cgi_put "<textarea name=\"$name\""
2051
if {[regexp "^on(Select|Focus|Blur|Change)=(.*)" $a dummy event str]} {
2052
cgi_put " on$event=\"$str\""
2060
set value [uplevel 1 set [list $name]]
2062
cgi_put "[cgi_quote_html $value]</textarea>"
2065
##################################################
2066
# file upload support
2067
##################################################
2069
# for this to work, pass enctype=multipart/form-data to cgi_form
2070
proc cgi_file_button {name args} {
2072
if {[info exists _cgi(formtype)] && ("multipart/form-data" != $_cgi(form,enctype))} {
2073
error "cgi_file_button requires that cgi_form have the argument enctype=multipart/form-data"
2075
cgi_put "<input type=file name=\"$name\"[_cgi_list_to_string $args]/>"
2078
# establish a per-file limit for uploads
2080
proc cgi_file_limit {files chars} {
2083
set _cgi(file,filelimit) $files
2084
set _cgi(file,charlimit) $chars
2087
##################################################
2089
##################################################
2091
proc cgi_select {name args} {
2092
cgi_put "<select name=\"$name\""
2093
_cgi_close_proc_push "cgi_put </select>"
2094
foreach a [lrange $args 0 [expr [llength $args]-2]] {
2095
if {[regexp "^on(Focus|Blur|Change)=(.*)" $a dummy event str]} {
2096
cgi_put " on$event=\"$str\""
2098
if {0==[string compare multiple $a]} {
2100
if {![regexp "List$" $name]} {
2101
cgi_puts ">" ;# prevent error from being absorbed
2102
error "When selecting multiple options, select variable \
2103
must end in \"List\" to allow the value to be \
2104
recognized as a list when it is processed later."
2111
uplevel 1 [lindex $args end]
2115
proc cgi_option {o args} {
2120
if {[regexp "^selected_if_equal=(.*)" $a dummy selected_if_equal]} {
2121
} elseif {[regexp "^value=(.*)" $a dummy value]} {
2122
cgi_put " value=[cgi_dquote_html $value]"
2127
if {[info exists selected_if_equal]} {
2128
if {0 == [string compare $selected_if_equal $value]} {
2132
cgi_puts ">[cgi_quote_html $o]</option>"
2135
##################################################
2137
##################################################
2139
proc cgi_embed {src wh args} {
2140
regexp (.*)x(.*) $wh dummy width height
2141
cgi_put "<embed src=[cgi_dquote_html $src] width=\"$width\" height=\"$height\""
2143
if {[regexp "^palette=(.*)" $a dummy str]} {
2144
cgi_put " palette=\"$str\""
2145
} elseif {[regexp -- "-quote" $a]} {
2148
if {[info exists quote]} {
2149
regexp "(\[^=]*)=(.*)" $a dummy var val
2150
cgi_put " var=[cgi_dquote_html $var]"
2159
##################################################
2161
##################################################
2163
# mail to/from the service itself
2164
proc cgi_mail_addr {args} {
2167
if {[llength $args]} {
2168
set _cgi(email) [lindex $args 0]
2173
proc cgi_mail_start {to} {
2176
set _cgi(mailfile) [file join $_cgi(tmpdir) cgimail.[pid]]
2177
set _cgi(mailfid) [open $_cgi(mailfile) w+]
2178
set _cgi(mailto) $to
2180
# mail is actually sent by "nobody". To force bounce messages
2181
# back to us, override the default return-path.
2182
cgi_mail_add "Return-Path: <$_cgi(email)>"
2183
cgi_mail_add "From: [cgi_name] <$_cgi(email)>"
2184
cgi_mail_add "To: $to"
2187
# add another line to outgoing mail
2188
# if no arg, add a blank line
2189
proc cgi_mail_add {{arg {}}} {
2192
puts $_cgi(mailfid) $arg
2195
# end the outgoing mail and send it
2196
proc cgi_mail_end {} {
2199
flush $_cgi(mailfid)
2201
foreach sendmail in $_cgi(sendmail) {
2202
if {[file executable $sendmail]} {
2203
exec $sendmail -t -odb < $_cgi(mailfile)
2205
# -t means: pick up recipient from body
2206
# -odb means: deliver in background
2207
# note: bogus local address cause sendmail to fail immediately
2212
if {0==[info exists sent]} {
2213
# fallback for sites without sendmail
2215
if {0==[info exists _cgi(mail_relay)]} {
2216
regexp "@(.*)" $_cgi(mailto) dummy _cgi(mail_relay)
2219
set s [socket $_cgi(mail_relay) 25]
2221
if {[lindex $answer 0] != 220} {error $answer}
2223
puts $s "HELO [info host]";flush $s
2225
if {[lindex $answer 0] != 250} {error $answer}
2227
puts $s "MAIL FROM:<$_cgi(email)>";flush $s
2229
if {[lindex $answer 0] != 250} {error $answer}
2231
puts $s "RCPT TO:<$_cgi(mailto)>";flush $s
2233
if {[lindex $answer 0] != 250} {error $answer}
2235
puts $s DATA;flush $s
2237
if {[lindex $answer 0] != 354} {error $answer}
2239
seek $_cgi(mailfid) 0 start
2240
puts $s [read $_cgi(mailfid)];flush $s
2243
if {[lindex $answer 0] != 250} {error $answer}
2247
close $_cgi(mailfid)
2248
file delete -force $_cgi(mailfile)
2251
proc cgi_mail_relay {host} {
2254
set _cgi(mail_relay) $host
2257
proc cgi_sendmail {path} {
2260
set _cgi(sendmail) $path
2263
##################################################
2265
##################################################
2267
# calls to cookie_set look like this:
2268
# cgi_cookie_set user=don domain=nist.gov expires=never
2269
# cgi_cookie_set user=don domain=nist.gov expires=now
2270
# cgi_cookie_set user=don domain=nist.gov expires=...actual date...
2272
proc cgi_cookie_set {nameval args} {
2275
if {![info exists _cgi(http_head_in_progress)]} {
2276
error "Cookies must be set from within cgi_http_head."
2278
cgi_puts -nonewline "Set-Cookie: [cgi_cookie_encode $nameval];"
2281
if {[regexp "^expires=(.*)" $a dummy expiration]} {
2282
if {0==[string compare $expiration "never"]} {
2283
set expiration "Friday, 11-Jan-2038 23:59:59 GMT"
2284
} elseif {0==[string compare $expiration "now"]} {
2285
set expiration "Friday, 31-Dec-1990 23:59:59 GMT"
2287
cgi_puts -nonewline " expires=$expiration;"
2288
} elseif {[regexp "^(domain|path)=(.*)" $a dummy attr str]} {
2289
cgi_puts -nonewline " $attr=[cgi_cookie_encode $str];"
2290
} elseif {[regexp "^secure$" $a]} {
2291
cgi_puts -nonewline " secure;"
2297
# return list of cookies available for import
2298
proc cgi_cookie_list {} {
2301
array names _cgi_cookie
2304
proc cgi_cookie_get {args} {
2309
set flag [lindex $args 0]
2310
if {$flag == "-all"} {
2311
set args [lrange $args 1 end]
2314
set name [lindex $args 0]
2317
global _cgi_cookie_shadowed
2319
if {[info exists _cgi_cookie_shadowed($name)]} {
2320
return [concat $_cgi_cookie($name) $_cgi_cookie_shadowed($name)]
2322
return [concat $_cgi_cookie($name)]
2325
return $_cgi_cookie($name)
2328
proc cgi_cookie_encode {in} {
2329
regsub -all " " $in "+" in
2330
regsub -all "%" $in "%25" in ;# must preceed other subs that produce %
2331
regsub -all ";" $in "%3B" in
2332
regsub -all "," $in "%2C" in
2333
regsub -all "\n" $in "%0D%0A" in
2337
##################################################
2339
##################################################
2341
proc cgi_table {args} {
2343
_cgi_close_proc_push "cgi_put </table>"
2345
if {[llength $args]} {
2346
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
2349
uplevel 1 [lindex $args end]
2353
proc cgi_caption {args} {
2355
_cgi_close_proc_push "cgi_put </caption>"
2357
if {[llength $args]} {
2358
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
2361
uplevel 1 [lindex $args end]
2365
proc cgi_table_row {args} {
2367
_cgi_close_proc_push "cgi_put </tr>"
2368
if {[llength $args]} {
2369
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
2372
uplevel 1 [lindex $args end]
2376
# like table_row but without eval
2377
proc cgi_tr {args} {
2379
if {[llength $args] > 1} {
2380
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
2383
foreach i [lindex $args end] {
2389
proc cgi_table_head {args} {
2391
_cgi_close_proc_push "cgi_put </th>"
2393
if {[llength $args]} {
2394
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
2397
uplevel 1 [lindex $args end]
2401
# like table_head but without eval
2402
proc cgi_th {args} {
2405
if {[llength $args] > 1} {
2406
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
2408
cgi_put ">[lindex $args end]</th>"
2411
proc cgi_table_data {args} {
2413
_cgi_close_proc_push "cgi_put </td>"
2415
if {[llength $args]} {
2416
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
2419
uplevel 1 [lindex $args end]
2423
# like table_data but without eval
2424
proc cgi_td {args} {
2427
if {[llength $args] > 1} {
2428
cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
2430
cgi_put ">[lindex $args end]</td>"
2433
##################################################
2434
# stylesheets - not yet documented
2435
##################################################
2437
proc cgi_stylesheet {href} {
2438
cgi_puts "<link rel=stylesheet href=\"$href\" type=\"text/css\"/>"
2441
proc cgi_span {args} {
2443
foreach a [lrange $args 0 [expr [llength $args]-2]] {
2444
if {[regexp "style=(.*)" $a dummy str]} {
2445
append buf " style=\"$str\""
2446
} elseif {[regexp "class=(.*)" $a dummy str]} {
2447
append buf " class=\"$str\""
2452
return "$buf>[lindex $args end]</span>"
2455
##################################################
2457
##################################################
2459
proc cgi_frameset {args} {
2460
cgi_head ;# force it out, just in case none
2463
_cgi_close_proc_push "cgi_puts </frameset>"
2465
foreach a [lrange $args 0 [expr [llength $args]-2]] {
2466
if {[regexp "^(rows|cols|onUnload|onLoad|onBlur)=(.*)" $a dummy attr str]} {
2467
cgi_put " $attr=\"$str\""
2473
uplevel 1 [lindex $args end]
2477
proc cgi_frame {namesrc args} {
2480
regexp "(\[^=]*)(=?)(.*)" $namesrc dummy name q src
2483
cgi_put " name=\"$name\""
2487
cgi_put " src=\"$src\""
2491
if {[regexp "^(marginwidth|marginheight|scrolling|onFocus)=(.*)" $a dummy attr str]} {
2492
cgi_put " $attr=\"$str\""
2500
proc cgi_noframes {args} {
2501
cgi_puts "<noframes>"
2502
_cgi_close_proc_push "cgi_puts </noframes>"
2503
uplevel 1 [lindex $args end]
2507
##################################################
2509
##################################################
2511
# mail address of the administrator
2512
proc cgi_admin_mail_addr {args} {
2515
if {[llength $args]} {
2516
set _cgi(admin_email) [lindex $args 0]
2518
return $_cgi(admin_email)
2521
##################################################
2522
# if possible, make each cmd available without cgi_ prefix
2523
##################################################
2525
if {[info tclversion] >= 7.5} {
2526
foreach _cgi(old) [info procs cgi_*] {
2527
regexp "^cgi_(.*)" $_cgi(old) _cgi(dummy) _cgi(new)
2528
if {[llength [info commands $_cgi(new)]]} continue
2529
interp alias {} $_cgi(new) {} $_cgi(old)
2532
foreach _cgi(old) [info procs cgi_*] {
2533
regexp "^cgi_(.*)" $_cgi(old) _cgi(dummy) _cgi(new)
2534
if {[llength [info commands $_cgi(new)]]} continue
2535
proc $_cgi(new) {args} "uplevel 1 $_cgi(old) \$args"
2539
##################################################
2540
# internal utilities
2541
##################################################
2543
# undo Tcl's quoting due to list protection
2544
# This leaves a space at the beginning if the string is non-null
2545
# but this is always desirable in the HTML context in which it is called
2546
# and the resulting HTML looks more readable.
2547
# (It makes the Tcl callers a little less readable - however, there aren't
2548
# more than a handful and they're all right here, so we'll live with it.)
2549
proc _cgi_list_to_string {list} {
2554
# remove first space if possible
2555
# regexp "^ ?(.*)" $string dummy string
2559
# do lrange but return as string
2560
# needed for stuff like: cgi_puts "[_cgi_lrange $args ...]
2561
# Like _cgi_list_to_string, also returns string with initial blank if non-null
2562
proc _cgi_lrange {list i1 i2} {
2563
_cgi_list_to_string [lrange $list $i1 $i2]
2566
##################################################
2567
# temporary file procedures
2568
##################################################
2570
# set appropriate temporary file modes
2571
proc cgi_tmpfile_permissions {{mode ""}} {
2574
if {[string length $mode]} {
2575
set _cgi(tmpperms) $mode
2578
return $_cgi(tmpperms)
2581
##################################################
2582
# user-defined procedures
2583
##################################################
2585
# User-defined procedure called immediately after <body>
2586
# Good mechanism for controlling things such as if all of your pages
2587
# start with the same graphic or other boilerplate.
2588
proc app_body_start {} {}
2590
# User-defined procedure called just before </body>
2591
# Good place to generate signature lines, last-updated-by, etc.
2592
proc app_body_end {} {}
2594
proc cgi_puts {args} {
2598
# User-defined procedure to generate DOCTYPE declaration
2599
proc cgi_doctype {} {}
2601
##################################################
2602
# do some initialization
2603
##################################################
2605
# cgi_init initializes to a known state.
2611
# set explicitly for speed
2612
set _cgi(debug) -off
2613
set _cgi(buffer_nl) "\n"
2618
cgi_file_limit 10 100000000
2620
if {[info tclversion] >= 8.1} {
2621
# set initial urlencoding
2622
if { [lsearch -exact [encoding names] "utf-8"] != -1} {
2623
cgi_urlencoding "utf-8"
2625
cgi_urlencoding [encoding system]
2629
# email addr of person responsible for this service
2630
cgi_admin_mail_addr "root" ;# you should override this!
2632
# most services won't have an actual email addr
2633
cgi_mail_addr "CGI script - do not reply"
2637
# deduce tmp directory
2638
switch $tcl_platform(platform) {
2640
set _cgi(tmpdir) /tmp
2641
set _cgi(tmpperms) 0644
2642
set _cgi(sendmail) [list /usr/lib/sendmail /usr/sbin/sendmail]
2644
set _cgi(tmpdir) [pwd]
2645
set _cgi(tmpperms) {}
2646
set _cgi(sendmail) {}
2648
set _cgi(tmpdir) [pwd]
2649
catch {set _cgi(tmpdir) $env(TMP)}
2650
catch {set _cgi(tmpdir) $env(TEMP)}
2651
set _cgi(tmpperms) {}
2652
set _cgi(sendmail) {}
2656
# regexp for matching attr=val
2657
set _cgi(attr,regexp) "^(\[^=]*)=(\[^\"].*)"
2659
package provide cgi @CGI_VERSION_FULL@
added
removed
web/src/cgi.tcl-1.10/cgi.tcl.in
