summaryrefslogtreecommitdiff
path: root/web/src/cgi.tcl-1.10/cgi.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'web/src/cgi.tcl-1.10/cgi.tcl')
-rw-r--r--web/src/cgi.tcl-1.10/cgi.tcl2659
1 files changed, 2659 insertions, 0 deletions
diff --git a/web/src/cgi.tcl-1.10/cgi.tcl b/web/src/cgi.tcl-1.10/cgi.tcl
new file mode 100644
index 00000000..81667179
--- /dev/null
+++ b/web/src/cgi.tcl-1.10/cgi.tcl
@@ -0,0 +1,2659 @@
+##################################################
+#
+# cgi.tcl - routines for writing CGI scripts in Tcl
+# Author: Don Libes <libes@nist.gov>, January '95
+#
+# These routines implement the code described in the paper
+# "Writing CGI scripts in Tcl" which appeared in the Tcl '96 conference.
+# Please read the paper before using this code. The paper is:
+# http://expect.nist.gov/doc/cgi.pdf
+#
+##################################################
+
+##################################################
+# http header support
+##################################################
+
+proc cgi_http_head {args} {
+ global _cgi env errorInfo
+
+ if {[info exists _cgi(http_head_done)]} return
+
+ set _cgi(http_head_in_progress) 1
+
+ if {0 == [llength $args]} {
+ cgi_content_type
+ } else {
+ if {[catch {uplevel 1 [lindex $args 0]} errMsg]} {
+ set savedInfo $errorInfo
+ cgi_content_type
+ }
+ }
+ cgi_puts ""
+
+ unset _cgi(http_head_in_progress)
+ set _cgi(http_head_done) 1
+
+ if {[info exists savedInfo]} {
+ error $errMsg $savedInfo
+ }
+}
+
+# avoid generating http head if not in CGI environment
+# to allow generation of pure HTML files
+proc _cgi_http_head_implicit {} {
+ global env
+
+ if {[info exists env(REQUEST_METHOD)]} cgi_http_head
+}
+
+proc cgi_status {num str} {
+ global _cgi
+
+ if {[info exists _cgi(http_status_done)]} return
+ set _cgi(http_status_done) 1
+ cgi_puts "Status: $num $str"
+}
+
+# If these are called manually, they automatically generate the extra newline
+
+proc cgi_content_type {args} {
+ global _cgi
+
+ if {0==[llength $args]} {
+ set t text/html
+ } else {
+ set t [lindex $args 0]
+ if {[regexp ^multipart/ $t]} {
+ set _cgi(multipart) 1
+ }
+ }
+
+ if {[info exists _cgi(http_head_in_progress)]} {
+ cgi_puts "Content-type: $t"
+ } else {
+ cgi_http_head [list cgi_content_type $t]
+ }
+}
+
+proc cgi_redirect {t} {
+ global _cgi
+
+ if {[info exists _cgi(http_head_in_progress)]} {
+ cgi_status 302 Redirected
+ cgi_puts "Uri: $t"
+ cgi_puts "Location: $t"
+ } else {
+ cgi_http_head {
+ cgi_redirect $t
+ }
+ }
+}
+
+# deprecated, use cgi_redirect
+proc cgi_location {t} {
+ global _cgi
+
+ if {[info exists _cgi(http_head_in_progress)]} {
+ cgi_puts "Location: $t"
+ } else {
+ cgi_http_head "cgi_location $t"
+ }
+}
+
+proc cgi_target {t} {
+ global _cgi
+
+ if {![info exists _cgi(http_head_in_progress)]} {
+ error "cgi_target must be set from within cgi_http_head."
+ }
+ cgi_puts "Window-target: $t"
+}
+
+# Make client retrieve url in this many seconds ("client pull").
+# With no 2nd arg, current url is retrieved.
+proc cgi_refresh {seconds {url ""}} {
+ global _cgi
+
+ if {![info exists _cgi(http_head_in_progress)]} {
+ error "cgi_refresh must be set from within cgi_http_head. Try using cgi_http_equiv instead."
+ }
+ cgi_put "Refresh: $seconds"
+
+ if {0!=[string compare $url ""]} {
+ cgi_put "; $url"
+ }
+ cgi_puts ""
+}
+
+# Example: cgi_pragma no-cache
+proc cgi_pragma {arg} {
+ global _cgi
+
+ if {![info exists _cgi(http_head_in_progress)]} {
+ error "cgi_pragma must be set from within cgi_http_head."
+ }
+ cgi_puts "Pragma: $arg"
+}
+
+##################################################
+# support for debugging or other crucial things we need immediately
+##################################################
+
+proc cgi_comment {args} {} ;# need this asap
+
+proc cgi_html_comment {args} {
+ regsub -all {>} $args {\&gt;} args
+ cgi_put "<!--[_cgi_list_to_string $args] -->"
+}
+
+set _cgi(debug) -off
+proc cgi_debug {args} {
+ global _cgi
+
+ set old $_cgi(debug)
+ set arg [lindex $args 0]
+ if {$arg == "-on"} {
+ set _cgi(debug) -on
+ set args [lrange $args 1 end]
+ } elseif {$arg == "-off"} {
+ set _cgi(debug) -off
+ set args [lrange $args 1 end]
+ } elseif {[regexp "^-t" $arg]} {
+ set temp 1
+ set _cgi(debug) -on
+ set args [lrange $args 1 end]
+ } elseif {[regexp "^-noprint$" $arg]} {
+ set noprint 1
+ set args [lrange $args 1 end]
+ }
+
+ set arg [lindex $args 0]
+ if {$arg == "--"} {
+ set args [lrange $args 1 end]
+ }
+
+ if {[llength $args]} {
+ if {$_cgi(debug) == "-on"} {
+
+ _cgi_close_tag
+ # force http head and open html, head, body
+ catch {
+ if {[info exists noprint]} {
+ uplevel 1 [lindex $args 0]
+ } else {
+ cgi_html {
+ cgi_head {
+ cgi_title "debugging before complete HTML head"
+ }
+ # force body open and leave open
+ _cgi_body_start
+ uplevel 1 [lindex $args 0]
+ # bop back out to catch, so we don't close body
+ error "ignore"
+ }
+ }
+ }
+ }
+ }
+
+ if {[info exists temp]} {
+ set _cgi(debug) $old
+ }
+ return $old
+}
+
+proc cgi_uid_check {user} {
+ global env
+
+ # leave in so old scripts don't blow up
+ if {[regexp "^-off$" $user]} return
+
+ if {[info exists env(USER)]} {
+ set whoami $env(USER)
+ } elseif {0==[catch {exec whoami} whoami]} {
+ # "who am i" on some Linux hosts returns "" so try whoami first
+ } elseif {0==[catch {exec who am i} whoami]} {
+ # skip over "host!"
+ regexp "(.*!)?(\[^ \t]*)" $whoami dummy dummy whoami
+ } elseif {0==[catch {package require registry}]} {
+ set whoami [registry get HKEY_LOCAL_MACHINE\\Network\\Logon username]
+ } else {
+ set whoami $user ;# give up and let go
+ }
+ if {$whoami != "$user"} {
+ error "Warning: This CGI script expects to run with uid \"$user\". However, this script is running as \"$whoami\"."
+ }
+}
+
+# print out elements of an array
+# like Tcl's parray, but formatted for browser
+proc cgi_parray {a {pattern *}} {
+ upvar 1 $a array
+ if {![array exists array]} {
+ error "\"$a\" isn't an array"
+ }
+
+ set maxl 0
+ foreach name [lsort [array names array $pattern]] {
+ if {[string length $name] > $maxl} {
+ set maxl [string length $name]
+ }
+ }
+ cgi_preformatted {
+ set maxl [expr {$maxl + [string length $a] + 2}]
+ foreach name [lsort [array names array $pattern]] {
+ set nameString [format %s(%s) $a $name]
+ cgi_puts [cgi_quote_html [format "%-*s = %s" $maxl $nameString $array($name)]]
+ }
+ }
+}
+
+proc cgi_eval {cmd} {
+ global env _cgi
+
+ # put cmd somewhere that uplevel can find it
+ set _cgi(body) $cmd
+
+ uplevel 1 {
+ global env _cgi errorInfo
+
+ if {1==[catch $_cgi(body) errMsg]} {
+ # error occurred, handle it
+ set _cgi(errorInfo) $errorInfo
+
+ if {![info exists env(REQUEST_METHOD)]} {
+ puts stderr $_cgi(errorInfo)
+ return
+ }
+ # the following code is all to force browsers into a state
+ # such that diagnostics can be reliably shown
+
+ # close irrelevant things
+ _cgi_close_procs
+ # force http head and open html, head, body
+ cgi_html {
+ cgi_body {
+ if {[info exists _cgi(client_error)]} {
+ cgi_h3 "Client Error"
+ cgi_p "$errMsg Report this to your system administrator or browser vendor."
+ } else {
+ cgi_put [cgi_anchor_name cgierror]
+ cgi_h3 "An internal error was detected in the service\
+ software. The diagnostics are being emailed to\
+ the service system administrator ($_cgi(admin_email))."
+
+ if {$_cgi(debug) == "-on"} {
+ cgi_puts "Heck, since you're debugging, I'll show you the\
+ errors right here:"
+ # suppress formatting
+ cgi_preformatted {
+ cgi_puts [cgi_quote_html $_cgi(errorInfo)]
+ }
+ } else {
+ cgi_mail_start $_cgi(admin_email)
+ cgi_mail_add "Subject: [cgi_name] CGI problem"
+ cgi_mail_add
+ cgi_mail_add "CGI environment:"
+ cgi_mail_add "REQUEST_METHOD: $env(REQUEST_METHOD)"
+ cgi_mail_add "SCRIPT_NAME: $env(SCRIPT_NAME)"
+ # this next few things probably don't need
+ # a catch but I'm not positive
+ catch {cgi_mail_add "HTTP_USER_AGENT: $env(HTTP_USER_AGENT)"}
+ catch {cgi_mail_add "HTTP_REFERER: $env(HTTP_REFERER)"}
+ catch {cgi_mail_add "HTTP_HOST: $env(HTTP_HOST)"}
+ catch {cgi_mail_add "REMOTE_HOST: $env(REMOTE_HOST)"}
+ catch {cgi_mail_add "REMOTE_ADDR: $env(REMOTE_ADDR)"}
+ cgi_mail_add "cgi.tcl version: 1.10.0"
+ cgi_mail_add "input:"
+ catch {cgi_mail_add $_cgi(input)}
+ cgi_mail_add "cookie:"
+ catch {cgi_mail_add $env(HTTP_COOKIE)}
+ cgi_mail_add "errorInfo:"
+ cgi_mail_add "$_cgi(errorInfo)"
+ cgi_mail_end
+ }
+ }
+ } ;# end cgi_body
+ } ;# end cgi_html
+ } ;# end catch
+ } ;# end uplevel
+}
+
+# return true if cgi_eval caught an error
+proc cgi_error_occurred {} {
+ global _cgi
+
+ return [info exists _cgi(errorInfo)]
+}
+
+##################################################
+# CGI URL creation
+##################################################
+
+# declare location of root of CGI files
+# this allows all CGI references to be relative in the source
+# making it easy to move everything in the future
+# If you have multiple roots, just don't call this.
+proc cgi_root {args} {
+ global _cgi
+
+ if {[llength $args]} {
+ set _cgi(root) [lindex $args 0]
+ } else {
+ set _cgi(root)
+ }
+}
+
+# make a URL for a CGI script
+proc cgi_cgi {args} {
+ global _cgi
+
+ set root $_cgi(root)
+ if {0!=[string compare $root ""]} {
+ if {![regexp "/$" $root]} {
+ append root "/"
+ }
+ }
+
+ set suffix [cgi_suffix]
+
+ set arg [lindex $args 0]
+ if {0==[string compare $arg "-suffix"]} {
+ set suffix [lindex $args 1]
+ set args [lrange $args 2 end]
+ }
+
+ if {[llength $args]==1} {
+ return $root[lindex $args 0]$suffix
+ } else {
+ return $root[lindex $args 0]$suffix?[join [lrange $args 1 end] &]
+ }
+}
+
+proc cgi_suffix {args} {
+ global _cgi
+ if {[llength $args] > 0} {
+ set _cgi(suffix) [lindex $args 0]
+ }
+ if {![info exists _cgi(suffix)]} {
+ return .cgi
+ } else {
+ return $_cgi(suffix)
+ }
+}
+
+proc cgi_cgi_set {variable value} {
+ regsub -all {%} $value "%25" value
+ regsub -all {&} $value "%26" value
+ regsub -all {\+} $value "%2b" value
+ regsub -all { } $value "+" value
+ regsub -all {=} $value "%3d" value
+ regsub -all {#} $value "%23" value
+ regsub -all {/} $value "%2f" value ;# Added...
+ return $variable=$value
+}
+
+##################################################
+# URL dictionary support
+##################################################
+
+proc cgi_link {args} {
+ global _cgi_link
+
+ set tag [lindex $args 0]
+ switch -- [llength $args] {
+ 1 {
+ set label $_cgi_link($tag,label)
+ } 2 {
+ set label [lindex $args end]
+ } default {
+ set _cgi_link($tag,label) [set label [lindex $args 1]]
+ set _cgi_link($tag,url) [lrange $args 2 end]
+ }
+ }
+
+ return [eval cgi_url [list $label] $_cgi_link($tag,url)]
+}
+
+# same as above but for images
+# note: uses different namespace
+proc cgi_imglink {args} {
+ global _cgi_imglink
+
+ set tag [lindex $args 0]
+ if {[llength $args] >= 2} {
+ set _cgi_imglink($tag) [eval cgi_img [lrange $args 1 end]]
+ }
+ return $_cgi_imglink($tag)
+}
+
+proc cgi_link_label {tag} {
+ global _cgi_link
+ return $_cgi_link($tag,label)
+}
+
+proc cgi_link_url {tag} {
+ global _cgi_link
+ return $_cgi_link($tag,url)
+}
+
+##################################################
+# hyperlink support
+##################################################
+
+# construct a hyperlink labeled "display"
+# last arg is the link destination
+# any other args are passed through into <a> display
+proc cgi_url {display args} {
+ global _cgi
+
+ set buf "<a href=\"[lindex $args 0]\""
+ foreach a [lrange $args 1 end] {
+ if {[regexp $_cgi(attr,regexp) $a dummy attr str]} {
+ append buf " $attr=\"$str\""
+ } else {
+ append buf " $a"
+ }
+ }
+ return "$buf>$display</a>"
+}
+
+# generate an image reference (<img ...>)
+# first arg is image url
+# other args are passed through into <img> tag
+proc cgi_img {args} {
+ global _cgi
+
+ set buf "<img src=\"[lindex $args 0]\""
+ foreach a [lrange $args 1 end] {
+ if {[regexp "^(alt|lowsrc|usemap)=(.*)" $a dummy attr str]} {
+ append buf " $attr=[cgi_dquote_html $str]"
+ } elseif {[regexp $_cgi(attr,regexp) $a dummy attr str]} {
+ append buf " $attr=\"$str\""
+ } else {
+ append buf " $a"
+ }
+ }
+ return "$buf />"
+}
+
+# names an anchor so that it can be linked to
+proc cgi_anchor_name {name} {
+ return "<a name=\"$name\"/>"
+}
+
+proc cgi_base {args} {
+ global _cgi
+
+ cgi_put "<base"
+ foreach a $args {
+ if {[regexp "^href=(.*)" $a dummy str]} {
+ cgi_put " href=[cgi_dquote_html $str]"
+ } elseif {[regexp $_cgi(attr,regexp) $a dummy attr str]} {
+ cgi_put " $attr=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_puts " />"
+}
+
+##################################################
+# quoting support
+##################################################
+
+if {[info tclversion] >= 8.2} {
+ proc cgi_unquote_input buf {
+ # rewrite "+" back to space
+ # protect \ from quoting another \ and throwing off other things
+ # replace line delimiters with newlines
+ set buf [string map -nocase [list + { } "\\" "\\\\" %0d%0a \n] $buf]
+
+ # prepare to process all %-escapes
+ regsub -all -nocase {%([a-f0-9][a-f0-9])} $buf {\\u00\1} buf
+
+ # process \u unicode mapped chars
+ encoding convertfrom $::_cgi(queryencoding) \
+ [subst -novar -nocommand $buf]
+ }
+} elseif {[info tclversion] >= 8.1} {
+ proc cgi_unquote_input buf {
+ # rewrite "+" back to space
+ regsub -all {\+} $buf { } buf
+ # protect \ from quoting another \ and throwing off other things
+ regsub -all {\\} $buf {\\\\} buf
+
+ # replace line delimiters with newlines
+ regsub -all -nocase "%0d%0a" $buf "\n" buf
+
+ # prepare to process all %-escapes
+ regsub -all -nocase {%([a-f0-9][a-f0-9])} $buf {\\u00\1} buf
+ # process \u unicode mapped chars
+ return [subst -novar -nocommand $buf]
+ }
+} else {
+ proc cgi_unquote_input {buf} {
+ # rewrite "+" back to space
+ regsub -all {\+} $buf { } buf
+ # protect \ from quoting another \ and throwing off other things first
+ # protect $ from doing variable expansion
+ # protect [ from doing evaluation
+ # protect " from terminating string
+ regsub -all {([\\["$])} $buf {\\\1} buf
+
+ # replace line delimiters with newlines
+ regsub -all -nocase "%0d%0a" $buf "\n" buf
+ # Mosaic sends just %0A. This is handled in the next command.
+
+ # prepare to process all %-escapes
+ regsub -all -nocase {%([a-f0-9][a-f0-9])} $buf {[format %c 0x\1]} buf
+ # process %-escapes and undo all protection
+ eval return \"$buf\"
+ }
+}
+
+# return string but with html-special characters escaped,
+# necessary if you want to send unknown text to an html-formatted page.
+proc cgi_quote_html {s} {
+ regsub -all {&} $s {\&amp;} s ;# must be first!
+ regsub -all {"} $s {\&quot;} s
+ regsub -all {<} $s {\&lt;} s
+ regsub -all {>} $s {\&gt;} s
+ return $s
+}
+
+proc cgi_dquote_html {s} {
+ return \"[cgi_quote_html $s]\"
+}
+
+# return string quoted appropriately to appear in a url
+proc cgi_quote_url {in} {
+ regsub -all {%} $in "%25" in
+ regsub -all {\+} $in "%2b" in
+ regsub -all { } $in "%20" in
+ regsub -all {"} $in "%22" in
+ regsub -all {\?} $in "%3f" in
+ return $in
+}
+
+##################################################
+# short or single paragraph support
+##################################################
+
+proc cgi_br {args} {
+ cgi_put "<br"
+ if {[llength $args]} {
+ cgi_put "[_cgi_list_to_string $args]"
+ }
+ cgi_put " />"
+}
+
+# generate cgi_h1 and others
+for {set _cgi(tmp) 1} {$_cgi(tmp)<8} {incr _cgi(tmp)} {
+ proc cgi_h$_cgi(tmp) {{args}} "eval cgi_h $_cgi(tmp) \$args"
+}
+proc cgi_h {num args} {
+ cgi_put "<h$num"
+ if {[llength $args] > 1} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ set args [lrange $args end end]
+ }
+ cgi_put ">[lindex $args 0]</h$num>"
+}
+
+proc cgi_p {args} {
+ cgi_put "<p"
+ if {[llength $args] > 1} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ set args [lrange $args end end]
+ }
+ cgi_put ">[lindex $args 0]</p>"
+}
+
+proc cgi_address {s} {cgi_put <address>$s</address>}
+proc cgi_blockquote {s} {cgi_puts <blockquote>$s</blockquote>}
+
+##################################################
+# long or multiple paragraph support
+##################################################
+
+# Shorthand for <div align=center>. We used to use <center> tags but that
+# is now officially unsupported.
+proc cgi_center {cmd} {
+ uplevel 1 "cgi_division align=center [list $cmd]"
+}
+
+proc cgi_division {args} {
+ cgi_put "<div"
+ _cgi_close_proc_push "cgi_put </div>"
+
+ if {[llength $args]} {
+ cgi_put "[_cgi_lrange $args 0 [expr {[llength $args]-2}]]"
+ }
+ cgi_put ">"
+ uplevel 1 [lindex $args end]
+ _cgi_close_proc
+}
+
+proc cgi_preformatted {args} {
+ cgi_put "<pre"
+ _cgi_close_proc_push "cgi_put </pre>"
+
+ if {[llength $args]} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ }
+ cgi_put ">"
+ uplevel 1 [lindex $args end]
+ _cgi_close_proc
+}
+
+##################################################
+# list support
+##################################################
+
+proc cgi_li {args} {
+ cgi_put <li
+ if {[llength $args] > 1} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ }
+ cgi_put ">[lindex $args end]</li>"
+}
+
+proc cgi_number_list {args} {
+ cgi_put "<ol"
+ _cgi_close_proc_push "cgi_put </ol>"
+
+ if {[llength $args] > 1} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ }
+ cgi_put ">"
+ uplevel 1 [lindex $args end]
+
+ _cgi_close_proc
+}
+
+proc cgi_bullet_list {args} {
+ cgi_put "<ul"
+ _cgi_close_proc_push "cgi_put </ul>"
+
+ if {[llength $args] > 1} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ }
+ cgi_put ">"
+ uplevel 1 [lindex $args end]
+
+ _cgi_close_proc
+}
+
+# Following two are normally used from within definition lists
+# but are actually paragraph types on their own.
+proc cgi_term {s} {cgi_put <dt>$s</dt>}
+proc cgi_term_definition {s} {cgi_put <dd>$s</dd>}
+
+proc cgi_definition_list {cmd} {
+ cgi_put "<dl>"
+ _cgi_close_proc_push "cgi_put </dl>"
+
+ uplevel 1 $cmd
+ _cgi_close_proc
+}
+
+proc cgi_menu_list {cmd} {
+ cgi_put "<menu>"
+ _cgi_close_proc_push "cgi_put </menu>"
+
+ uplevel 1 $cmd
+ _cgi_close_proc
+}
+proc cgi_directory_list {cmd} {
+ cgi_put "<dir>"
+ _cgi_close_proc_push "cgi_put </dir>"
+
+ uplevel 1 $cmd
+ _cgi_close_proc
+}
+
+##################################################
+# text support
+##################################################
+
+proc cgi_put {s} {cgi_puts -nonewline $s}
+
+# some common special characters
+proc cgi_lt {} {return "&lt;"}
+proc cgi_gt {} {return "&gt;"}
+proc cgi_amp {} {return "&amp;"}
+proc cgi_quote {} {return "&quot;"}
+proc cgi_enspace {} {return "&ensp;"}
+proc cgi_emspace {} {return "&emsp;"}
+proc cgi_nbspace {} {return "&#160;"} ;# nonbreaking space
+proc cgi_tm {} {return "&#174;"} ;# registered trademark
+proc cgi_copyright {} {return "&#169;"}
+proc cgi_isochar {n} {return "&#$n;"}
+proc cgi_breakable {} {return "<wbr />"}
+
+proc cgi_unbreakable_string {s} {return "<nobr>$s</nobr>"}
+proc cgi_unbreakable {cmd} {
+ cgi_put "<nobr>"
+ _cgi_close_proc_push "cgi_put </nobr>"
+ uplevel 1 $cmd
+ _cgi_close_proc
+}
+
+proc cgi_nl {args} {
+ set buf "<br"
+ if {[llength $args]} {
+ append buf "[_cgi_list_to_string $args]"
+ }
+ return "$buf />"
+}
+
+proc cgi_bold {s} {return "<b>$s</b>"}
+proc cgi_italic {s} {return "<i>$s</i>"}
+proc cgi_underline {s} {return "<u>$s</u>"}
+proc cgi_strikeout {s} {return "<s>$s</s>"}
+proc cgi_subscript {s} {return "<sub>$s</sub>"}
+proc cgi_superscript {s} {return "<sup>$s</sup>"}
+proc cgi_typewriter {s} {return "<tt>$s</tt>"}
+proc cgi_blink {s} {return "<blink>$s</blink>"}
+proc cgi_emphasis {s} {return "<em>$s</em>"}
+proc cgi_strong {s} {return "<strong>$s</strong>"}
+proc cgi_cite {s} {return "<cite>$s</cite>"}
+proc cgi_sample {s} {return "<samp>$s</samp>"}
+proc cgi_keyboard {s} {return "<kbd>$s</kbd>"}
+proc cgi_variable {s} {return "<var>$s</var>"}
+proc cgi_definition {s} {return "<dfn>$s</dfn>"}
+proc cgi_big {s} {return "<big>$s</big>"}
+proc cgi_small {s} {return "<small>$s</small>"}
+
+proc cgi_basefont {size} {cgi_put "<basefont size=$size />"}
+
+proc cgi_font {args} {
+ global _cgi
+
+ set buf "<font"
+ foreach a [lrange $args 0 [expr [llength $args]-2]] {
+ if {[regexp $_cgi(attr,regexp) $a dummy attr str]} {
+ append buf " $attr=\"$str\""
+ } else {
+ append buf " $a"
+ }
+ }
+ return "$buf>[lindex $args end]</font>"
+}
+
+# take a cgi func and have it return what would normally print
+# This command is reentrant (that's why it's so complex).
+proc cgi_buffer {cmd} {
+ global _cgi
+
+ if {0==[info exists _cgi(returnIndex)]} {
+ set _cgi(returnIndex) 0
+ }
+
+ rename cgi_puts cgi_puts$_cgi(returnIndex)
+ incr _cgi(returnIndex)
+ set _cgi(return[set _cgi(returnIndex)]) ""
+
+ proc cgi_puts args {
+ global _cgi
+ upvar #0 _cgi(return[set _cgi(returnIndex)]) buffer
+
+ append buffer [lindex $args end]
+ if {[llength $args] == 1} {
+ append buffer $_cgi(buffer_nl)
+ }
+ }
+
+ # must restore things before allowing the eval to fail
+ # so catch here and rethrow later
+ if {[catch {uplevel 1 $cmd} errMsg]} {
+ global errorInfo
+ set savedInfo $errorInfo
+ }
+
+ # not necessary to put remainder of code in close_proc_push since it's
+ # all buffered anyway and hasn't yet put browser into a funky state.
+
+ set buffer $_cgi(return[set _cgi(returnIndex)])
+
+ incr _cgi(returnIndex) -1
+ rename cgi_puts ""
+ rename cgi_puts$_cgi(returnIndex) cgi_puts
+
+ if {[info exists savedInfo]} {
+ error $errMsg $savedInfo
+ }
+ return $buffer
+}
+
+set _cgi(buffer_nl) "\n"
+proc cgi_buffer_nl {nl} {
+ global _cgi
+
+ set old $_cgi(buffer_nl)
+ set _cgi(buffer_nl) $nl
+ return $old
+}
+
+##################################################
+# html and tags that can appear in html top-level
+##################################################
+
+proc cgi_html {args} {
+ set html [lindex $args end]
+ set argc [llength $args]
+ if {$argc > 1} {
+ eval _cgi_html_start [lrange $args 0 [expr {$argc-2}]]
+ } else {
+ _cgi_html_start
+ }
+ uplevel 1 $html
+ _cgi_html_end
+}
+
+proc _cgi_html_start {args} {
+ global _cgi
+
+ if {[info exists _cgi(html_in_progress)]} return
+ _cgi_http_head_implicit
+
+ set _cgi(html_in_progress) 1
+ cgi_doctype
+
+ append buf "<html"
+ foreach a $args {
+ if {[regexp $_cgi(attr,regexp) $a dummy attr str]} {
+ append buf " $attr=\"$str\""
+ } else {
+ append buf " $a"
+ }
+ }
+ cgi_puts "$buf>"
+}
+
+proc _cgi_html_end {} {
+ global _cgi
+ unset _cgi(html_in_progress)
+ set _cgi(html_done) 1
+ cgi_puts "</html>"
+}
+
+# force closure of all tags and exit without going through normal returns.
+# Very useful if you want to call exit from a deeply stacked CGI script
+# and still have the HTML be correct.
+proc cgi_exit {} {
+ _cgi_close_procs
+ cgi_html {cgi_body {}}
+ exit
+}
+
+##################################################
+# head support
+##################################################
+
+proc cgi_head {{head {}}} {
+ global _cgi
+
+ if {[info exists _cgi(head_done)]} {
+ return
+ }
+
+ # allow us to be recalled so that we can display errors
+ if {0 == [info exists _cgi(head_in_progress)]} {
+ _cgi_http_head_implicit
+ set _cgi(head_in_progress) 1
+ cgi_puts "<head>"
+ }
+
+ # prevent cgi_html (during error handling) from generating html tags
+ set _cgi(html_in_progress) 1
+ # don't actually generate html tags since there's nothing to clean
+ # them up
+
+ if {0 == [string length $head]} {
+ if {[catch {cgi_title}]} {
+ set head "cgi_title untitled"
+ }
+ }
+ uplevel 1 $head
+ if {![info exists _cgi(head_suppress_tag)]} {
+ cgi_puts "</head>"
+ } else {
+ unset _cgi(head_suppress_tag)
+ }
+
+ set _cgi(head_done) 1
+
+ # debugging can unset this in the uplevel above
+ catch {unset _cgi(head_in_progress)}
+}
+
+# with one arg: set, print, and return title
+# with no args: return title
+proc cgi_title {args} {
+ global _cgi
+
+ set title [lindex $args 0]
+
+ if {[llength $args]} {
+ _cgi_http_head_implicit
+
+ # we could just generate <head></head> tags, but head-level commands
+ # might follow so just suppress the head tags entirely
+ if {![info exists _cgi(head_in_progress)]} {
+ set _cgi(head_in_progress) 1
+ set _cgi(head_suppress_tag) 1
+ }
+
+ set _cgi(title) $title
+ cgi_puts "<title>$title</title>"
+ }
+ return $_cgi(title)
+}
+
+# This tag can only be called from with cgi_head.
+# example: cgi_http_equiv Refresh 1
+# There's really no reason to call this since it can be done directly
+# from cgi_http_head.
+proc cgi_http_equiv {type contents} {
+ _cgi_http_head_implicit
+ cgi_puts "<meta http-equiv=\"$type\" content=[cgi_dquote_html $contents]/>"
+}
+
+# Do whatever you want with meta tags.
+# Example: <meta name="author" content="Don Libes">
+proc cgi_meta {args} {
+ cgi_put "<meta"
+ foreach a $args {
+ if {[regexp "^(name|content|http-equiv)=(.*)" $a dummy attr str]} {
+ cgi_put " $attr=[cgi_dquote_html $str]"
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_puts " />"
+}
+
+proc cgi_relationship {rel href args} {
+ cgi_puts "<link rel=$rel href=\"$href\""
+ foreach a $args {
+ if {[regexp "^title=(.*)" $a dummy str]} {
+ cgi_put " title=[cgi_dquote_html $str]"
+ } elseif {[regexp "^type=(.*)" $a dummy str]} {
+ cgi_put " type=[cgi_dquote_html $str]"
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_puts "/>"
+}
+
+proc cgi_name {args} {
+ global _cgi
+
+ if {[llength $args]} {
+ set _cgi(name) [lindex $args 0]
+ }
+ return $_cgi(name)
+}
+
+##################################################
+# body and other top-level support
+##################################################
+
+proc cgi_body {args} {
+ global errorInfo errorCode _cgi
+
+ # allow user to "return" from the body without missing _cgi_body_end
+ if {1==[catch {
+ eval _cgi_body_start [lrange $args 0 [expr [llength $args]-2]]
+ uplevel 1 [lindex $args end]
+ } errMsg]} {
+ set savedInfo $errorInfo
+ set savedCode $errorCode
+ error $errMsg $savedInfo $savedCode
+ }
+ _cgi_body_end
+}
+
+proc _cgi_body_start {args} {
+ global _cgi
+ if {[info exists _cgi(body_in_progress)]} return
+
+ cgi_head
+
+ set _cgi(body_in_progress) 1
+
+ cgi_put "<body"
+ foreach a "$args $_cgi(body_args)" {
+ if {[regexp "^(background|bgcolor|text|link|vlink|alink|onLoad|onUnload)=(.*)" $a dummy attr str]} {
+ cgi_put " $attr=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_puts ">"
+
+ cgi_debug {
+ global env
+ catch {cgi_puts "Input: <pre>$_cgi(input)</pre>"}
+ catch {cgi_puts "Cookie: <pre>$env(HTTP_COOKIE)</pre>"}
+ }
+
+ if {![info exists _cgi(errorInfo)]} {
+ uplevel 2 app_body_start
+ }
+}
+
+proc _cgi_body_end {} {
+ global _cgi
+ if {![info exists _cgi(errorInfo)]} {
+ uplevel 2 app_body_end
+ }
+ unset _cgi(body_in_progress)
+ cgi_puts "</body>"
+
+ if {[info exists _cgi(multipart)]} {
+ unset _cgi(http_head_done)
+ catch {unset _cgi(http_status_done)}
+ unset _cgi(head_done)
+ catch {unset _cgi(head_suppress_tag)}
+ }
+}
+
+proc cgi_body_args {args} {
+ global _cgi
+
+ set _cgi(body_args) $args
+}
+
+proc cgi_script {args} {
+ cgi_puts "<script[_cgi_lrange $args 0 [expr [llength $args]-2]]>"
+ _cgi_close_proc_push "cgi_puts </script>"
+
+ uplevel 1 [lindex $args end]
+
+ _cgi_close_proc
+}
+
+proc cgi_javascript {args} {
+ cgi_puts "<script[_cgi_lrange $args 0 [expr [llength $args]-2]]>"
+ cgi_puts "<!--- Hide script from browsers that don't understand JavaScript"
+ _cgi_close_proc_push {cgi_puts "// End hiding -->\n</script>"}
+
+ uplevel 1 [lindex $args end]
+
+ _cgi_close_proc
+}
+
+proc cgi_noscript {args} {
+ cgi_puts "<noscript[_cgi_lrange $args 0 [expr [llength $args]-2]]>"
+ _cgi_close_proc_push {cgi_puts "</noscript>"}
+
+ uplevel 1 [lindex $args end]
+
+ _cgi_close_proc
+}
+
+proc cgi_applet {args} {
+ cgi_puts "<applet[_cgi_lrange $args 0 [expr [llength $args]-2]]>"
+ _cgi_close_proc_push "cgi_puts </applet>"
+
+ uplevel 1 [lindex $args end]
+ _cgi_close_proc
+}
+
+proc cgi_param {nameval} {
+ regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value
+
+ if {$q != "="} {
+ set value ""
+ }
+ cgi_puts "<param name=\"$name\" value=[cgi_dquote_html $value]/>"
+}
+
+# record any proc's that must be called prior to displaying an error
+proc _cgi_close_proc_push {p} {
+ global _cgi
+ if {![info exists _cgi(close_proc)]} {
+ set _cgi(close_proc) ""
+ }
+ set _cgi(close_proc) "$p; $_cgi(close_proc)"
+}
+
+proc _cgi_close_proc_pop {} {
+ global _cgi
+ regexp "^(\[^;]*);(.*)" $_cgi(close_proc) dummy lastproc _cgi(close_proc)
+ return $lastproc
+}
+
+# generic proc to close whatever is on the top of the stack
+proc _cgi_close_proc {} {
+ eval [_cgi_close_proc_pop]
+}
+
+proc _cgi_close_procs {} {
+ global _cgi
+
+ _cgi_close_tag
+ if {[info exists _cgi(close_proc)]} {
+ uplevel #0 $_cgi(close_proc)
+ }
+}
+
+proc _cgi_close_tag {} {
+ global _cgi
+
+ if {[info exists _cgi(tag_in_progress)]} {
+ cgi_put ">"
+ unset _cgi(tag_in_progress)
+ }
+}
+
+##################################################
+# hr support
+##################################################
+
+proc cgi_hr {args} {
+ set buf "<hr"
+ foreach a $args {
+ if {[regexp "^width=(.*)" $a dummy str]} {
+ append buf " width=\"$str\""
+ } else {
+ append buf " $a"
+ }
+ }
+ cgi_put "$buf />"
+}
+
+##################################################
+# form & isindex
+##################################################
+
+proc cgi_form {action args} {
+ global _cgi
+
+ _cgi_form_multiple_check
+ set _cgi(form_in_progress) 1
+
+ _cgi_close_proc_push _cgi_form_end
+ cgi_put "<form action="
+ if {[regexp {^[a-z]*:} $action]} {
+ cgi_put "\"$action\""
+ } else {
+ cgi_put "\"[cgi_cgi $action]\""
+ }
+ set method "method=post"
+ foreach a [lrange $args 0 [expr [llength $args]-2]] {
+ if {[regexp "^method=" $a]} {
+ set method $a
+ } elseif {[regexp "^(target|onReset|onSubmit)=(.*)" $a dummy attr str]} {
+ cgi_put " $attr=\"$str\""
+ } elseif {[regexp "^enctype=(.*)" $a dummy str]} {
+ cgi_put " enctype=\"$str\""
+ set _cgi(form,enctype) $str
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_put " $method>"
+ uplevel 1 [lindex $args end]
+ catch {unset _cgi(form,enctype)}
+ _cgi_close_proc
+}
+
+proc _cgi_form_end {} {
+ global _cgi
+ unset _cgi(form_in_progress)
+ cgi_put "</form>"
+}
+
+proc _cgi_form_multiple_check {} {
+ global _cgi
+ if {[info exists _cgi(form_in_progress)]} {
+ error "Cannot create form (or isindex) with form already in progress."
+ }
+}
+
+proc cgi_isindex {args} {
+ _cgi_form_multiple_check
+
+ cgi_put "<isindex"
+ foreach a $args {
+ if {[regexp "^href=(.*)" $a dummy str]} {
+ cgi_put " href=\"$str\""
+ } elseif {[regexp "^prompt=(.*)" $a dummy str]} {
+ cgi_put " prompt=[cgi_dquote_html $str]"
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_put "/>"
+}
+
+##################################################
+# argument handling
+##################################################
+
+proc cgi_input {{fakeinput {}} {fakecookie {}}} {
+ global env _cgi _cgi_uservar _cgi_cookie _cgi_cookie_shadowed
+
+ set _cgi(uservars) {}
+ set _cgi(uservars,autolist) {}
+
+ if {[info exists env(CONTENT_TYPE)] && [regexp ^multipart/form-data $env(CONTENT_TYPE)]} {
+ if {![info exists env(REQUEST_METHOD)]} {
+ # running by hand
+ set fid [open $fakeinput]
+ } else {
+ set fid stdin
+ }
+ if {([info tclversion] >= 8.1) || [catch exp_version] || [info exists _cgi(no_binary_upload)]} {
+ _cgi_input_multipart $fid
+ } else {
+ _cgi_input_multipart_binary $fid
+ }
+ } else {
+ if {![info exists env(REQUEST_METHOD)]} {
+ set input $fakeinput
+ set env(HTTP_COOKIE) $fakecookie
+ } elseif { $env(REQUEST_METHOD) == "GET" } {
+ set input ""
+ catch {set input $env(QUERY_STRING)} ;# doesn't have to be set
+ } elseif { $env(REQUEST_METHOD) == "HEAD" } {
+ set input ""
+ } elseif {![info exists env(CONTENT_LENGTH)]} {
+ set _cgi(client_error) 1
+ error "Your browser failed to generate the content-length during a POST method."
+ } else {
+ set length $env(CONTENT_LENGTH)
+ if {0!=[string compare $length "-1"]} {
+ set input [read stdin $env(CONTENT_LENGTH)]
+ } else {
+ set _cgi(client_error) 1
+ error "Your browser generated a content-length of -1 during a POST method."
+ }
+ if {[info tclversion] >= 8.1} {
+ # guess query encoding from Content-Type header
+ if {[info exists env(CONTENT_TYPE)] \
+ && [regexp -nocase -- {charset=([^[:space:]]+)} $env(CONTENT_TYPE) m cs]} {
+ if {[regexp -nocase -- {iso-?8859-([[:digit:]]+)} $cs m d]} {
+ set _cgi(queryencoding) "iso8859-$d"
+ } elseif {[regexp -nocase -- {windows-([[:digit:]]+)} $cs m d]} {
+ set _cgi(queryencoding) "cp$d"
+ } elseif {0==[string compare -nocase $cs "utf-8"]} {
+ set _cgi(queryencoding) "utf-8"
+ } elseif {0==[string compare -nocase $cs "utf-16"]} {
+ set _cgi(queryencoding) "unicode"
+ }
+ } else {
+ set _cgi(queryencoding) [encoding system]
+ }
+ }
+ }
+ # save input for possible diagnostics later
+ set _cgi(input) $input
+
+ set pairs [split $input &]
+ foreach pair $pairs {
+ if {0 == [regexp "^(\[^=]*)=(.*)$" $pair dummy varname val]} {
+ # if no match, unquote and leave it at that
+ # this is typical of <isindex>-style queries
+ set varname anonymous
+ set val $pair
+ }
+
+ set varname [cgi_unquote_input $varname]
+ set val [cgi_unquote_input $val]
+ _cgi_set_uservar $varname $val
+ }
+ }
+
+ # O'Reilly's web server incorrectly uses COOKIE
+ catch {set env(HTTP_COOKIE) $env(COOKIE)}
+ if {![info exists env(HTTP_COOKIE)]} return
+ foreach pair [split $env(HTTP_COOKIE) ";"] {
+ # pairs are actually split by "; ", sigh
+ set pair [string trimleft $pair " "]
+ # spec is not clear but seems to allow = unencoded
+ # only sensible interpretation is to assume no = in var names
+ # appears MS IE can omit "=val"
+ set val ""
+ regexp (\[^=]*)=?(.*) $pair dummy varname val
+
+ set varname [cgi_unquote_input $varname]
+ set val [cgi_unquote_input $val]
+
+ if {[info exists _cgi_cookie($varname)]} {
+ lappend _cgi_cookie_shadowed($varname) $val
+ } else {
+ set _cgi_cookie($varname) $val
+ }
+ }
+}
+
+proc _cgi_input_multipart {fin} {
+ global env _cgi _cgi_uservar _cgi_userfile
+
+ cgi_debug -noprint {
+ # save file for debugging purposes
+ set dbg_filename [file join $_cgi(tmpdir) CGIdbg.[pid]]
+ # explicitly flush all writes to fout, because sometimes the writer
+ # can hang and we won't get to the termination code
+ set dbg_fout [open $dbg_filename w $_cgi(tmpperms)]
+ set _cgi(input) $dbg_filename
+ catch {fconfigure $dbg_fout -translation binary}
+ }
+
+ # figure out boundary
+ if {0==[regexp boundary=(.*) $env(CONTENT_TYPE) dummy boundary]} {
+ set _cgi(client_error) 1
+ error "Your browser failed to generate a \"boundary=\" line in a multipart response (CONTENT_TYPE: $env(CONTENT_TYPE)). Please upgrade (or fix) your browser."
+ }
+
+ # make boundary into a legal regsub pattern by protecting #
+ # legal boundary characters include ()+.? (among others)
+ regsub -all "\\(" $boundary "\\(" boundary
+ regsub -all "\\)" $boundary "\\)" boundary
+ regsub -all "\\+" $boundary "\\+" boundary
+ regsub -all "\\." $boundary "\\." boundary
+ regsub -all "\\?" $boundary "\\?" boundary
+
+ set boundary --$boundary
+
+ # don't corrupt or modify uploads yet allow Tcl 7.4 to work
+ catch {fconfigure $fin -translation binary}
+
+ # get first boundary line
+ gets $fin buf
+ if {[info exists dbg_fout]} {puts $dbg_fout $buf; flush $dbg_fout}
+
+ set _cgi(file,filecount) 0
+
+ while {1} {
+ # process Content-Disposition:
+ if {-1 == [gets $fin buf]} break
+ if {[info exists dbg_fout]} {puts $dbg_fout $buf; flush $dbg_fout}
+ catch {unset filename}
+ regexp {name="([^"]*)"} $buf dummy varname
+ if {0==[info exists varname]} {
+ # lynx violates spec and doesn't use quotes, so try again but
+ # assume space is delimiter
+ regexp {name=([^ ]*)} $buf dummy varname
+ if {0==[info exists varname]} {
+ set _cgi(client_error) 1
+ 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."
+ }
+ }
+ # Lame-o encoding (on Netscape at least) doesn't escape field
+ # delimiters (like quotes)!! Since all we've ever seen is filename=
+ # at end of line, assuming nothing follows. Sigh.
+ regexp {filename="(.*)"} $buf dummy filename
+
+ # Skip remaining headers until blank line.
+ # Content-Type: can appear here.
+ set conttype ""
+ while {1} {
+ if {-1 == [gets $fin buf]} break
+ if {[info exists dbg_fout]} {puts $dbg_fout $buf; flush $dbg_fout}
+ if {0==[string compare $buf "\r"]} break
+ regexp -nocase "^Content-Type:\[ \t]+(.*)\r" $buf x conttype
+ }
+
+ if {[info exists filename]} {
+ if {$_cgi(file,filecount) > $_cgi(file,filelimit)} {
+ error "Too many files submitted. Max files allowed: $_cgi(file,filelimit)"
+ }
+
+ # read the part into a file
+ set foutname [file join $_cgi(tmpdir) CGI[pid].[incr _cgi(file,filecount)]]
+ set fout [open $foutname w $_cgi(tmpperms)]
+ # "catch" permits this to work with Tcl 7.4
+ catch {fconfigure $fout -translation binary}
+ _cgi_set_uservar $varname [list $foutname $filename $conttype]
+ set _cgi_userfile($varname) [list $foutname $filename $conttype]
+
+ #
+ # Look for a boundary line preceded by \r\n.
+ #
+ # To do this, we buffer line terminators that might
+ # be the start of the special \r\n$boundary sequence.
+ # The buffer is called "leftover" and is just inserted
+ # into the front of the next output (assuming it's
+ # not a boundary line).
+
+ set leftover ""
+ while {1} {
+ if {-1 == [gets $fin buf]} break
+ if {[info exists dbg_fout]} {puts $dbg_fout $buf; flush $dbg_fout}
+
+ if {0 == [string compare "\r\n" $leftover]} {
+ if {[regexp ^[set boundary](--)?\r?$ $buf dummy dashdash]} {
+ if {$dashdash == "--"} {set eof 1}
+ break
+ }
+ }
+ if {[regexp (.*)\r$ $buf x data]} {
+ puts -nonewline $fout $leftover$data
+ set leftover "\r\n"
+ } else {
+ puts -nonewline $fout $leftover$buf
+ set leftover "\n"
+ }
+ if {[file size $foutname] > $_cgi(file,charlimit)} {
+ error "File size exceeded. Max file size allowed: $_cgi(file,charlimit)"
+ }
+ }
+
+ close $fout
+ unset fout
+ } else {
+ # read the part into a variable
+ set val ""
+ set blanks 0
+ while {1} {
+ if {-1 == [gets $fin buf]} break
+ if {[info exists dbg_fout]} {puts $dbg_fout $buf; flush $dbg_fout}
+ if {[regexp ^[set boundary](--)?\r?$ $buf dummy dashdash]} {
+ if {$dashdash == "--"} {set eof 1}
+ break
+ }
+ if {0!=[string compare $val ""]} {
+ append val \n
+ }
+ regexp (.*)\r$ $buf dummy buf
+ if {[info exists blanks]} {
+ if {0!=[string compare $buf ""]} {
+ if {$blanks} {
+ append val [string repeat \n [incr blanks]]
+ }
+ unset blanks
+ } else {
+ incr blanks
+ }
+ }
+ append val $buf
+ }
+ _cgi_set_uservar $varname $val
+ }
+ if {[info exists eof]} break
+ }
+ if {[info exists dbg_fout]} {close $dbg_fout}
+}
+
+proc _cgi_input_multipart_binary {fin} {
+ global env _cgi _cgi_uservar _cgi_userfile
+
+ log_user 0
+ set timeout -1
+
+ cgi_debug -noprint {
+ # save file for debugging purposes
+ set dbg_filename [file join $_cgi(tmpdir) CGIdbg.[pid]]
+ set _cgi(input) $dbg_filename
+ spawn -open [open $dbg_filename w $_cgi(tmpperms)]
+ set dbg_sid $spawn_id
+ }
+ spawn -open $fin
+ set fin_sid $spawn_id
+ remove_nulls 0
+
+ if {0} {
+ # dump input to screen
+ cgi_debug {
+ puts "<xmp>"
+ expect {
+ -i $fin_sid
+ -re ^\r {puts -nonewline "CR"; exp_continue}
+ -re ^\n {puts "NL"; exp_continue}
+ -re . {puts -nonewline $expect_out(buffer); exp_continue}
+ }
+ puts "</xmp>"
+ exit
+ }
+ }
+
+ # figure out boundary
+ if {0==[regexp boundary=(.*) $env(CONTENT_TYPE) dummy boundary]} {
+ set _cgi(client_error) 1
+ error "Your browser failed to generate a \"boundary=\" definition in a multipart response (CONTENT_TYPE: $env(CONTENT_TYPE)). Please upgrade (or fix) your browser."
+ }
+
+ # make boundary into a legal regsub pattern by protecting #
+ # legal boundary characters include ()+.? (among others)
+ regsub -all "\\(" $boundary "\\(" boundary
+ regsub -all "\\)" $boundary "\\)" boundary
+ regsub -all "\\+" $boundary "\\+" boundary
+ regsub -all "\\." $boundary "\\." boundary
+ regsub -all "\\?" $boundary "\\?" boundary
+
+ set boundary --$boundary
+ set linepat "(\[^\r]*)\r\n"
+
+ # get first boundary line
+ expect {
+ -i $fin_sid
+ -re $linepat {
+ set buf $expect_out(1,string)
+ if {[info exists dbg_sid]} {send -i $dbg_sid -- $buf\n}
+ }
+ eof {
+ set _cgi(client_error) 1
+ error "Your browser failed to provide an initial boundary ($boundary) in a multipart response. Please upgrade (or fix) your browser."
+ }
+ }
+
+ set _cgi(file,filecount) 0
+
+ while {1} {
+ # process Content-Disposition:
+ expect {
+ -i $fin_sid
+ -re $linepat {
+ set buf $expect_out(1,string)
+ if {[info exists dbg_sid]} {send -i $dbg_sid -- $buf\n}
+ }
+ eof break
+ }
+ catch {unset filename}
+ regexp {name="([^"]*)"} $buf dummy varname
+ if {0==[info exists varname]} {
+ set _cgi(client_error) 1
+ 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."
+ }
+
+ # Lame-o encoding (on Netscape at least) doesn't escape field
+ # delimiters (like quotes)!! Since all we've ever seen is filename=
+ # at end of line, assuming nothing follows. Sigh.
+ regexp {filename="(.*)"} $buf dummy filename
+
+ # Skip remaining headers until blank line.
+ # Content-Type: can appear here.
+ set conttype ""
+ expect {
+ -i $fin_sid
+ -re $linepat {
+ set buf $expect_out(1,string)
+ if {[info exists dbg_sid]} {send -i $dbg_sid -- $buf\n}
+ if {0!=[string compare $buf ""]} exp_continue
+ regexp -nocase "^Content-Type:\[ \t]+(.*)\r" $buf x conttype
+ }
+ eof break
+ }
+
+ if {[info exists filename]} {
+ if {$_cgi(file,filecount) > $_cgi(file,filelimit)} {
+ error "Too many files submitted. Max files allowed: $_cgi(file,filelimit)"
+ }
+
+ # read the part into a file
+ set foutname [file join $_cgi(tmpdir) CGI[pid].[incr _cgi(file,filecount)]]
+ spawn -open [open $foutname w $_cgi(tmpperms)]
+ set fout_sid $spawn_id
+
+ _cgi_set_uservar $varname [list $foutname $filename $conttype]
+ set _cgi_userfile($varname) [list $foutname $filename $conttype]
+
+ # This is tricky stuff - be very careful changing anything here!
+ # In theory, all we have to is record everything up to
+ # \r\n$boundary\r\n. Unfortunately, we can't simply wait on
+ # such a pattern because the input can overflow any possible
+ # buffer we might choose. We can't simply catch buffer_full
+ # because the boundary might straddle a buffer. I doubt that
+ # doing my own buffering would be any faster than taking the
+ # approach I've done here.
+ #
+ # The code below basically implements a simple scanner that
+ # keeps track of whether it's seen crlfs or pieces of them.
+ # The idea is that we look for crlf pairs, separated by
+ # things that aren't crlfs (or pieces of them). As we encounter
+ # things that aren't crlfs (or pieces of them), or when we decide
+ # they can't be, we mark them for output and resume scanning for
+ # new pairs.
+ #
+ # The scanner runs tolerably fast because the [...]+ pattern picks
+ # up most things. The \r and \n are ^-anchored so the pattern
+ # match is pretty fast and these don't happen that often so the
+ # huge \n action is executed rarely (once per line on text files).
+ # The null pattern is, of course, only used when everything
+ # else fails.
+
+ # crlf == "\r\n" if we've seen one, else == ""
+ # cr == "\r" if we JUST saw one, else == ""
+ # Yes, strange, but so much more efficient
+ # that I'm willing to sacrifice readability, sigh.
+ # buf accumulated data between crlf pairs
+
+ set buf ""
+ set cr ""
+ set crlf ""
+
+ expect {
+ -i $fin_sid
+ -re "^\r" {
+ if {$cr == "\r"} {
+ append buf "\r"
+ }
+ set cr \r
+ exp_continue
+ } -re "^\n" {
+ if {$cr == "\r"} {
+ if {$crlf == "\r\n"} {
+ # do boundary test
+ if {[regexp ^[set boundary](--)?$ $buf dummy dashdash]} {
+ if {$dashdash == "--"} {
+ set eof 1
+ }
+ } else {
+ # boundary test failed
+ if {[info exists dbg_sid]} {send -i $dbg_sid -- \r\n$buf}
+ send -i $fout_sid \r\n$buf ; set buf ""
+ set cr ""
+ exp_continue
+ }
+ } else {
+ set crlf "\r\n"
+ set cr ""
+ if {[info exists dbg_sid]} {send -i $dbg_sid -- $buf}
+ send -i $fout_sid -- $buf ; set buf ""
+ exp_continue
+ }
+ } else {
+ if {[info exists dbg_sid]} {send -i $dbg_sid -- $crlf$buf\n}
+ send -i $fout_sid -- $crlf$buf\n ; set buf ""
+ set crlf ""
+ exp_continue
+ }
+ } -re "\[^\r\n]+" {
+ if {$cr == "\r"} {
+ set buf $crlf$buf\r$expect_out(buffer)
+ set crlf ""
+ set cr ""
+ } else {
+ append buf $expect_out(buffer)
+ }
+ exp_continue
+ } null {
+ if {[info exists dbg_sid]} {
+ send -i $dbg_sid -- $crlf$buf$cr
+ send -i $dbg_sid -null
+ }
+ send -i $fout_sid -- $crlf$buf$cr ; set buf ""
+ send -i $fout_sid -null
+ set cr ""
+ set crlf ""
+ exp_continue
+ } eof {
+ set _cgi(client_error) 1
+ error "Your browser failed to provide an ending boundary ($boundary) in a multipart response. Please upgrade (or fix) your browser."
+ }
+ }
+ exp_close -i $fout_sid ;# implicitly closes fout
+ exp_wait -i $fout_sid
+ unset fout_sid
+ } else {
+ # read the part into a variable
+ set val ""
+ expect {
+ -i $fin_sid
+ -re $linepat {
+ set buf $expect_out(1,string)
+ if {[info exists dbg_sid]} {send -i $dbg_sid -- $buf\n}
+ if {[regexp ^[set boundary](--)?$ $buf dummy dashdash]} {
+ if {$dashdash == "--"} {set eof 1}
+ } else {
+ regexp (.*)\r$ $buf dummy buf
+ if {0!=[string compare $val ""]} {
+ append val \n
+ }
+ append val $buf
+ exp_continue
+ }
+ }
+ }
+ _cgi_set_uservar $varname $val
+ }
+ if {[info exists eof]} break
+ }
+ if {[info exists fout]} {
+ exp_close -i $dbg_sid
+ exp_wait -i $dbg_sid
+ }
+
+ # no need to close fin, fin_sid, or dbg_sid
+}
+
+# internal routine for defining user variables
+proc _cgi_set_uservar {varname val} {
+ global _cgi _cgi_uservar
+
+ set exists [info exists _cgi_uservar($varname)]
+ set isList $exists
+ # anything we've seen before and is being set yet again necessarily
+ # has to be (or become a list)
+
+ if {!$exists} {
+ lappend _cgi(uservars) $varname
+ }
+
+ if {[regexp List$ $varname]} {
+ set isList 1
+ } elseif {$exists} {
+ # vars that we've seen before but aren't marked as lists
+ # need to be "listified" so we can do appends later
+ if {-1 == [lsearch $_cgi(uservars,autolist) $varname]} {
+ # remember that we've listified it
+ lappend _cgi(uservars,autolist) $varname
+ set _cgi_uservar($varname) [list $_cgi_uservar($varname)]
+ }
+ }
+ if {$isList} {
+ lappend _cgi_uservar($varname) $val
+ } else {
+ set _cgi_uservar($varname) $val
+ }
+}
+
+# export named variable
+proc cgi_export {nameval} {
+ regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value
+
+ if {$q != "="} {
+ set value [uplevel 1 set [list $name]]
+ }
+
+ cgi_put "<input type=hidden name=\"$name\" value=[cgi_dquote_html $value]/>"
+}
+
+proc cgi_export_cookie {name args} {
+ upvar 1 $name x
+ eval cgi_cookie_set [list $name=$x] $args
+}
+
+# return list of variables available for import
+# Explicit list is used to keep items in order originally found in form.
+proc cgi_import_list {} {
+ global _cgi
+
+ return $_cgi(uservars)
+}
+
+# import named variable
+proc cgi_import {name} {
+ global _cgi_uservar
+ upvar 1 $name var
+
+ set var $_cgi_uservar($name)
+}
+
+proc cgi_import_as {name tclvar} {
+ global _cgi_uservar
+ upvar 1 $tclvar var
+
+ set var $_cgi_uservar($name)
+}
+
+# like cgi_import but if not available, try cookie
+proc cgi_import_cookie {name} {
+ global _cgi_uservar
+ upvar 1 $name var
+
+ if {0==[catch {set var $_cgi_uservar($name)}]} return
+ set var [cgi_cookie_get $name]
+}
+
+# like cgi_import but if not available, try cookie
+proc cgi_import_cookie_as {name tclvar} {
+ global _cgi_uservar
+ upvar 1 $tclvar var
+
+ if {0==[catch {set var $_cgi_uservar($name)}]} return
+ set var [cgi_cookie_get $name]
+}
+
+proc cgi_import_file {type name} {
+ global _cgi_userfile
+ upvar 1 $name var
+
+ set var $_cgi_userfile($name)
+ switch -- $type {
+ "-server" {
+ lindex $var 0
+ } "-client" {
+ lindex $var 1
+ } "-type" {
+ lindex $var 2
+ }
+ }
+}
+
+# deprecated, use cgi_import_file
+proc cgi_import_filename {type name} {
+ global _cgi_userfile
+ upvar 1 $name var
+
+ set var $_cgi_userfile($name)
+ if {$type == "-server" || $type == "-local"} {
+ # -local is deprecated
+ lindex $var 0
+ } else {
+ lindex $var 1
+ }
+}
+
+# set the urlencoding
+proc cgi_urlencoding {{encoding ""}} {
+ global _cgi
+
+ set result [expr {[info exists _cgi(queryencoding)]
+ ? $_cgi(queryencoding)
+ : ""}]
+
+ # check if the encoding is available
+ if {[info tclversion] >= 8.1
+ && [lsearch -exact [encoding names] $encoding] != -1 } {
+ set _cgi(queryencoding) $encoding
+ }
+
+ return $result
+}
+
+##################################################
+# button support
+##################################################
+
+# not sure about arg handling, do we need to support "name="?
+proc cgi_button {value args} {
+ cgi_put "<input type=button value=[cgi_dquote_html $value]"
+ foreach a $args {
+ if {[regexp "^onClick=(.*)" $a dummy str]} {
+ cgi_put " onClick=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_put "/>"
+}
+
+# Derive a button from a link predefined by cgi_link
+proc cgi_button_link {args} {
+ global _cgi_link
+
+ set tag [lindex $args 0]
+ if {[llength $args] == 2} {
+ set label [lindex $args end]
+ } else {
+ set label $_cgi_link($tag,label)
+ }
+
+ cgi_button $label onClick=$_cgi_link($tag,url)
+}
+
+proc cgi_submit_button {{nameval {=Submit Query}} args} {
+ regexp "(\[^=]*)=(.*)" $nameval dummy name value
+ cgi_put "<input type=submit"
+ if {0!=[string compare "" $name]} {
+ cgi_put " name=\"$name\""
+ }
+ cgi_put " value=[cgi_dquote_html $value]"
+ foreach a $args {
+ if {[regexp "^onClick=(.*)" $a dummy str]} {
+ cgi_put " onClick=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_put "/>"
+}
+
+
+proc cgi_reset_button {{value Reset} args} {
+ cgi_put "<input type=reset value=[cgi_dquote_html $value]"
+
+ foreach a $args {
+ if {[regexp "^onClick=(.*)" $a dummy str]} {
+ cgi_put " onClick=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_put "/>"
+}
+
+proc cgi_radio_button {nameval args} {
+ regexp "(\[^=]*)=(.*)" $nameval dummy name value
+
+ cgi_put "<input type=radio name=\"$name\" value=[cgi_dquote_html $value]"
+
+ foreach a $args {
+ if {[regexp "^checked_if_equal=(.*)" $a dummy default]} {
+ if {0==[string compare $default $value]} {
+ cgi_put " checked"
+ }
+ } elseif {[regexp "^checked=(.*)" $a dummy checked]} {
+ # test explicitly to avoid forcing user eval
+ if {$checked} {
+ cgi_put " checked"
+ }
+ } elseif {[regexp "^onClick=(.*)" $a dummy str]} {
+ cgi_put " onClick=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_put "/>"
+}
+
+proc cgi_image_button {nameval args} {
+ regexp "(\[^=]*)=(.*)" $nameval dummy name value
+ cgi_put "<input type=image"
+ if {0!=[string compare "" $name]} {
+ cgi_put " name=\"$name\""
+ }
+ cgi_put " src=\"$value\""
+ foreach a $args {
+ if {[regexp "^onClick=(.*)" $a dummy str]} {
+ cgi_put " onClick=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_put "/>"
+}
+
+# map/area implement client-side image maps
+proc cgi_map {name cmd} {
+ cgi_put "<map name=\"$name\">"
+ _cgi_close_proc_push "cgi_put </map>"
+
+ uplevel 1 $cmd
+ _cgi_close_proc
+}
+
+proc cgi_area {args} {
+ cgi_put "<area"
+ foreach a $args {
+ if {[regexp "^(coords|shape|href|target|onMouseOut|alt)=(.*)" $a dummy attr str]} {
+ cgi_put " $attr=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_put "/>"
+}
+
+##################################################
+# checkbox support
+##################################################
+
+proc cgi_checkbox {nameval args} {
+ regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value
+ cgi_put "<input type=checkbox name=\"$name\""
+
+ if {0!=[string compare "" $value]} {
+ cgi_put " value=[cgi_dquote_html $value]"
+ }
+
+ foreach a $args {
+ if {[regexp "^checked_if_equal=(.*)" $a dummy default]} {
+ if {0==[string compare $default $value]} {
+ cgi_put " checked"
+ }
+ } elseif {[regexp "^checked=(.*)" $a dummy checked]} {
+ # test explicitly to avoid forcing user eval
+ if {$checked} {
+ cgi_put " checked"
+ }
+ } elseif {[regexp "^onClick=(.*)" $a dummy str]} {
+ cgi_put " onClick=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_put "/>"
+}
+
+##################################################
+# textentry support
+##################################################
+
+proc cgi_text {nameval args} {
+ regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value
+
+ cgi_put "<input name=\"$name\""
+
+ if {$q != "="} {
+ set value [uplevel 1 set [list $name]]
+ }
+ cgi_put " value=[cgi_dquote_html $value]"
+
+ foreach a $args {
+ if {[regexp "^on(Select|Focus|Blur|Change)=(.*)" $a dummy event str]} {
+ cgi_put " on$event=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_put "/>"
+}
+
+##################################################
+# textarea support
+##################################################
+
+proc cgi_textarea {nameval args} {
+ regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value
+
+ cgi_put "<textarea name=\"$name\""
+ foreach a $args {
+ if {[regexp "^on(Select|Focus|Blur|Change)=(.*)" $a dummy event str]} {
+ cgi_put " on$event=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_put ">"
+
+ if {$q != "="} {
+ set value [uplevel 1 set [list $name]]
+ }
+ cgi_put "[cgi_quote_html $value]</textarea>"
+}
+
+##################################################
+# file upload support
+##################################################
+
+# for this to work, pass enctype=multipart/form-data to cgi_form
+proc cgi_file_button {name args} {
+ global _cgi
+ if {[info exists _cgi(formtype)] && ("multipart/form-data" != $_cgi(form,enctype))} {
+ error "cgi_file_button requires that cgi_form have the argument enctype=multipart/form-data"
+ }
+ cgi_put "<input type=file name=\"$name\"[_cgi_list_to_string $args]/>"
+}
+
+# establish a per-file limit for uploads
+
+proc cgi_file_limit {files chars} {
+ global _cgi
+
+ set _cgi(file,filelimit) $files
+ set _cgi(file,charlimit) $chars
+}
+
+##################################################
+# select support
+##################################################
+
+proc cgi_select {name args} {
+ cgi_put "<select name=\"$name\""
+ _cgi_close_proc_push "cgi_put </select>"
+ foreach a [lrange $args 0 [expr [llength $args]-2]] {
+ if {[regexp "^on(Focus|Blur|Change)=(.*)" $a dummy event str]} {
+ cgi_put " on$event=\"$str\""
+ } else {
+ if {0==[string compare multiple $a]} {
+ ;# sanity check
+ if {![regexp "List$" $name]} {
+ cgi_puts ">" ;# prevent error from being absorbed
+ error "When selecting multiple options, select variable \
+ must end in \"List\" to allow the value to be \
+ recognized as a list when it is processed later."
+ }
+ }
+ cgi_put " $a"
+ }
+ }
+ cgi_put ">"
+ uplevel 1 [lindex $args end]
+ _cgi_close_proc
+}
+
+proc cgi_option {o args} {
+ cgi_put "<option"
+ set value $o
+ set selected 0
+ foreach a $args {
+ if {[regexp "^selected_if_equal=(.*)" $a dummy selected_if_equal]} {
+ } elseif {[regexp "^value=(.*)" $a dummy value]} {
+ cgi_put " value=[cgi_dquote_html $value]"
+ } else {
+ cgi_put " $a"
+ }
+ }
+ if {[info exists selected_if_equal]} {
+ if {0 == [string compare $selected_if_equal $value]} {
+ cgi_put " selected"
+ }
+ }
+ cgi_puts ">[cgi_quote_html $o]</option>"
+}
+
+##################################################
+# plug-in support
+##################################################
+
+proc cgi_embed {src wh args} {
+ regexp (.*)x(.*) $wh dummy width height
+ cgi_put "<embed src=[cgi_dquote_html $src] width=\"$width\" height=\"$height\""
+ foreach a $args {
+ if {[regexp "^palette=(.*)" $a dummy str]} {
+ cgi_put " palette=\"$str\""
+ } elseif {[regexp -- "-quote" $a]} {
+ set quote 1
+ } else {
+ if {[info exists quote]} {
+ regexp "(\[^=]*)=(.*)" $a dummy var val
+ cgi_put " var=[cgi_dquote_html $var]"
+ } else {
+ cgi_put " $a"
+ }
+ }
+ }
+ cgi_put "/>"
+}
+
+##################################################
+# mail support
+##################################################
+
+# mail to/from the service itself
+proc cgi_mail_addr {args} {
+ global _cgi
+
+ if {[llength $args]} {
+ set _cgi(email) [lindex $args 0]
+ }
+ return $_cgi(email)
+}
+
+proc cgi_mail_start {to} {
+ global _cgi
+
+ set _cgi(mailfile) [file join $_cgi(tmpdir) cgimail.[pid]]
+ set _cgi(mailfid) [open $_cgi(mailfile) w+]
+ set _cgi(mailto) $to
+
+ # mail is actually sent by "nobody". To force bounce messages
+ # back to us, override the default return-path.
+ cgi_mail_add "Return-Path: <$_cgi(email)>"
+ cgi_mail_add "From: [cgi_name] <$_cgi(email)>"
+ cgi_mail_add "To: $to"
+}
+
+# add another line to outgoing mail
+# if no arg, add a blank line
+proc cgi_mail_add {{arg {}}} {
+ global _cgi
+
+ puts $_cgi(mailfid) $arg
+}
+
+# end the outgoing mail and send it
+proc cgi_mail_end {} {
+ global _cgi
+
+ flush $_cgi(mailfid)
+
+ foreach sendmail in $_cgi(sendmail) {
+ if {[file executable $sendmail]} {
+ exec $sendmail -t -odb < $_cgi(mailfile)
+ # Explanation:
+ # -t means: pick up recipient from body
+ # -odb means: deliver in background
+ # note: bogus local address cause sendmail to fail immediately
+ set sent 1
+ }
+ }
+
+ if {0==[info exists sent]} {
+ # fallback for sites without sendmail
+
+ if {0==[info exists _cgi(mail_relay)]} {
+ regexp "@(.*)" $_cgi(mailto) dummy _cgi(mail_relay)
+ }
+
+ set s [socket $_cgi(mail_relay) 25]
+ gets $s answer
+ if {[lindex $answer 0] != 220} {error $answer}
+
+ puts $s "HELO [info host]";flush $s
+ gets $s answer
+ if {[lindex $answer 0] != 250} {error $answer}
+
+ puts $s "MAIL FROM:<$_cgi(email)>";flush $s
+ gets $s answer
+ if {[lindex $answer 0] != 250} {error $answer}
+
+ puts $s "RCPT TO:<$_cgi(mailto)>";flush $s
+ gets $s answer
+ if {[lindex $answer 0] != 250} {error $answer}
+
+ puts $s DATA;flush $s
+ gets $s answer
+ if {[lindex $answer 0] != 354} {error $answer}
+
+ seek $_cgi(mailfid) 0 start
+ puts $s [read $_cgi(mailfid)];flush $s
+ puts $s .;flush $s
+ gets $s answer
+ if {[lindex $answer 0] != 250} {error $answer}
+
+ close $s
+ }
+ close $_cgi(mailfid)
+ file delete -force $_cgi(mailfile)
+}
+
+proc cgi_mail_relay {host} {
+ global _cgi
+
+ set _cgi(mail_relay) $host
+}
+
+proc cgi_sendmail {path} {
+ global _cgi
+
+ set _cgi(sendmail) $path
+}
+
+##################################################
+# cookie support
+##################################################
+
+# calls to cookie_set look like this:
+# cgi_cookie_set user=don domain=nist.gov expires=never
+# cgi_cookie_set user=don domain=nist.gov expires=now
+# cgi_cookie_set user=don domain=nist.gov expires=...actual date...
+
+proc cgi_cookie_set {nameval args} {
+ global _cgi
+
+ if {![info exists _cgi(http_head_in_progress)]} {
+ error "Cookies must be set from within cgi_http_head."
+ }
+ cgi_puts -nonewline "Set-Cookie: [cgi_cookie_encode $nameval];"
+
+ foreach a $args {
+ if {[regexp "^expires=(.*)" $a dummy expiration]} {
+ if {0==[string compare $expiration "never"]} {
+ set expiration "Friday, 11-Jan-2038 23:59:59 GMT"
+ } elseif {0==[string compare $expiration "now"]} {
+ set expiration "Friday, 31-Dec-1990 23:59:59 GMT"
+ }
+ cgi_puts -nonewline " expires=$expiration;"
+ } elseif {[regexp "^(domain|path)=(.*)" $a dummy attr str]} {
+ cgi_puts -nonewline " $attr=[cgi_cookie_encode $str];"
+ } elseif {[regexp "^secure$" $a]} {
+ cgi_puts -nonewline " secure;"
+ }
+ }
+ cgi_puts ""
+}
+
+# return list of cookies available for import
+proc cgi_cookie_list {} {
+ global _cgi_cookie
+
+ array names _cgi_cookie
+}
+
+proc cgi_cookie_get {args} {
+ global _cgi_cookie
+
+ set all 0
+
+ set flag [lindex $args 0]
+ if {$flag == "-all"} {
+ set args [lrange $args 1 end]
+ set all 1
+ }
+ set name [lindex $args 0]
+
+ if {$all} {
+ global _cgi_cookie_shadowed
+
+ if {[info exists _cgi_cookie_shadowed($name)]} {
+ return [concat $_cgi_cookie($name) $_cgi_cookie_shadowed($name)]
+ } else {
+ return [concat $_cgi_cookie($name)]
+ }
+ }
+ return $_cgi_cookie($name)
+}
+
+proc cgi_cookie_encode {in} {
+ regsub -all " " $in "+" in
+ regsub -all "%" $in "%25" in ;# must preceed other subs that produce %
+ regsub -all ";" $in "%3B" in
+ regsub -all "," $in "%2C" in
+ regsub -all "\n" $in "%0D%0A" in
+ return $in
+}
+
+##################################################
+# table support
+##################################################
+
+proc cgi_table {args} {
+ cgi_put "<table"
+ _cgi_close_proc_push "cgi_put </table>"
+
+ if {[llength $args]} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ }
+ cgi_put ">"
+ uplevel 1 [lindex $args end]
+ _cgi_close_proc
+}
+
+proc cgi_caption {args} {
+ cgi_put "<caption"
+ _cgi_close_proc_push "cgi_put </caption>"
+
+ if {[llength $args]} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ }
+ cgi_put ">"
+ uplevel 1 [lindex $args end]
+ _cgi_close_proc
+}
+
+proc cgi_table_row {args} {
+ cgi_put "<tr"
+ _cgi_close_proc_push "cgi_put </tr>"
+ if {[llength $args]} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ }
+ cgi_put ">"
+ uplevel 1 [lindex $args end]
+ _cgi_close_proc
+}
+
+# like table_row but without eval
+proc cgi_tr {args} {
+ cgi_put <tr
+ if {[llength $args] > 1} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ }
+ cgi_put ">"
+ foreach i [lindex $args end] {
+ cgi_td $i
+ }
+ cgi_put </tr>
+}
+
+proc cgi_table_head {args} {
+ cgi_put "<th"
+ _cgi_close_proc_push "cgi_put </th>"
+
+ if {[llength $args]} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ }
+ cgi_put ">"
+ uplevel 1 [lindex $args end]
+ _cgi_close_proc
+}
+
+# like table_head but without eval
+proc cgi_th {args} {
+ cgi_put "<th"
+
+ if {[llength $args] > 1} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ }
+ cgi_put ">[lindex $args end]</th>"
+}
+
+proc cgi_table_data {args} {
+ cgi_put "<td"
+ _cgi_close_proc_push "cgi_put </td>"
+
+ if {[llength $args]} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ }
+ cgi_put ">"
+ uplevel 1 [lindex $args end]
+ _cgi_close_proc
+}
+
+# like table_data but without eval
+proc cgi_td {args} {
+ cgi_put "<td"
+
+ if {[llength $args] > 1} {
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ }
+ cgi_put ">[lindex $args end]</td>"
+}
+
+##################################################
+# stylesheets - not yet documented
+##################################################
+
+proc cgi_stylesheet {href} {
+ cgi_puts "<link rel=stylesheet href=\"$href\" type=\"text/css\"/>"
+}
+
+proc cgi_span {args} {
+ set buf "<span"
+ foreach a [lrange $args 0 [expr [llength $args]-2]] {
+ if {[regexp "style=(.*)" $a dummy str]} {
+ append buf " style=\"$str\""
+ } elseif {[regexp "class=(.*)" $a dummy str]} {
+ append buf " class=\"$str\""
+ } else {
+ append buf " $a"
+ }
+ }
+ return "$buf>[lindex $args end]</span>"
+}
+
+##################################################
+# frames
+##################################################
+
+proc cgi_frameset {args} {
+ cgi_head ;# force it out, just in case none
+
+ cgi_put "<frameset"
+ _cgi_close_proc_push "cgi_puts </frameset>"
+
+ foreach a [lrange $args 0 [expr [llength $args]-2]] {
+ if {[regexp "^(rows|cols|onUnload|onLoad|onBlur)=(.*)" $a dummy attr str]} {
+ cgi_put " $attr=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_puts ">"
+ uplevel 1 [lindex $args end]
+ _cgi_close_proc
+}
+
+proc cgi_frame {namesrc args} {
+ cgi_put "<frame"
+
+ regexp "(\[^=]*)(=?)(.*)" $namesrc dummy name q src
+
+ if {$name != ""} {
+ cgi_put " name=\"$name\""
+ }
+
+ if {$src != ""} {
+ cgi_put " src=\"$src\""
+ }
+
+ foreach a $args {
+ if {[regexp "^(marginwidth|marginheight|scrolling|onFocus)=(.*)" $a dummy attr str]} {
+ cgi_put " $attr=\"$str\""
+ } else {
+ cgi_put " $a"
+ }
+ }
+ cgi_puts "/>"
+}
+
+proc cgi_noframes {args} {
+ cgi_puts "<noframes>"
+ _cgi_close_proc_push "cgi_puts </noframes>"
+ uplevel 1 [lindex $args end]
+ _cgi_close_proc
+}
+
+##################################################
+# admin support
+##################################################
+
+# mail address of the administrator
+proc cgi_admin_mail_addr {args} {
+ global _cgi
+
+ if {[llength $args]} {
+ set _cgi(admin_email) [lindex $args 0]
+ }
+ return $_cgi(admin_email)
+}
+
+##################################################
+# if possible, make each cmd available without cgi_ prefix
+##################################################
+
+if {[info tclversion] >= 7.5} {
+ foreach _cgi(old) [info procs cgi_*] {
+ regexp "^cgi_(.*)" $_cgi(old) _cgi(dummy) _cgi(new)
+ if {[llength [info commands $_cgi(new)]]} continue
+ interp alias {} $_cgi(new) {} $_cgi(old)
+ }
+} else {
+ foreach _cgi(old) [info procs cgi_*] {
+ regexp "^cgi_(.*)" $_cgi(old) _cgi(dummy) _cgi(new)
+ if {[llength [info commands $_cgi(new)]]} continue
+ proc $_cgi(new) {args} "uplevel 1 $_cgi(old) \$args"
+ }
+}
+
+##################################################
+# internal utilities
+##################################################
+
+# undo Tcl's quoting due to list protection
+# This leaves a space at the beginning if the string is non-null
+# but this is always desirable in the HTML context in which it is called
+# and the resulting HTML looks more readable.
+# (It makes the Tcl callers a little less readable - however, there aren't
+# more than a handful and they're all right here, so we'll live with it.)
+proc _cgi_list_to_string {list} {
+ set string ""
+ foreach l $list {
+ append string " $l"
+ }
+ # remove first space if possible
+ # regexp "^ ?(.*)" $string dummy string
+ return $string
+}
+
+# do lrange but return as string
+# needed for stuff like: cgi_puts "[_cgi_lrange $args ...]
+# Like _cgi_list_to_string, also returns string with initial blank if non-null
+proc _cgi_lrange {list i1 i2} {
+ _cgi_list_to_string [lrange $list $i1 $i2]
+}
+
+##################################################
+# temporary file procedures
+##################################################
+
+# set appropriate temporary file modes
+proc cgi_tmpfile_permissions {{mode ""}} {
+ global _cgi
+
+ if {[string length $mode]} {
+ set _cgi(tmpperms) $mode
+ }
+
+ return $_cgi(tmpperms)
+}
+
+##################################################
+# user-defined procedures
+##################################################
+
+# User-defined procedure called immediately after <body>
+# Good mechanism for controlling things such as if all of your pages
+# start with the same graphic or other boilerplate.
+proc app_body_start {} {}
+
+# User-defined procedure called just before </body>
+# Good place to generate signature lines, last-updated-by, etc.
+proc app_body_end {} {}
+
+proc cgi_puts {args} {
+ eval puts $args
+}
+
+# User-defined procedure to generate DOCTYPE declaration
+proc cgi_doctype {} {}
+
+##################################################
+# do some initialization
+##################################################
+
+# cgi_init initializes to a known state.
+
+proc cgi_init {} {
+ global _cgi
+ unset _cgi
+
+ # set explicitly for speed
+ set _cgi(debug) -off
+ set _cgi(buffer_nl) "\n"
+
+ cgi_name ""
+ cgi_root ""
+ cgi_body_args ""
+ cgi_file_limit 10 100000000
+
+ if {[info tclversion] >= 8.1} {
+ # set initial urlencoding
+ if { [lsearch -exact [encoding names] "utf-8"] != -1} {
+ cgi_urlencoding "utf-8"
+ } else {
+ cgi_urlencoding [encoding system]
+ }
+ }
+
+ # email addr of person responsible for this service
+ cgi_admin_mail_addr "root" ;# you should override this!
+
+ # most services won't have an actual email addr
+ cgi_mail_addr "CGI script - do not reply"
+}
+cgi_init
+
+# deduce tmp directory
+switch $tcl_platform(platform) {
+ unix {
+ set _cgi(tmpdir) /tmp
+ set _cgi(tmpperms) 0644
+ set _cgi(sendmail) [list /usr/lib/sendmail /usr/sbin/sendmail]
+ } macintosh {
+ set _cgi(tmpdir) [pwd]
+ set _cgi(tmpperms) {}
+ set _cgi(sendmail) {}
+ } default {
+ set _cgi(tmpdir) [pwd]
+ catch {set _cgi(tmpdir) $env(TMP)}
+ catch {set _cgi(tmpdir) $env(TEMP)}
+ set _cgi(tmpperms) {}
+ set _cgi(sendmail) {}
+ }
+}
+
+# regexp for matching attr=val
+set _cgi(attr,regexp) "^(\[^=]*)=(\[^\"].*)"
+
+package provide cgi 1.10.0
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-15 01:33:23 +0000