From c5bb25b1320af6cda4cc62ea9e15fbb03ee92026 Mon Sep 17 00:00:00 2001 From: Eduardo Chappa Date: Sat, 21 Sep 2013 18:45:27 -0600 Subject: * Version 2.11.6 * Add /tls1, /tls1_1, /tls1_2 and /dtls1 to the definition of a server to use different ways to connect using ssl, for example {server.com/tls1} will attempt to connect to server.com at the ssl imap port (port 993) and establish a connection using TLSv1. These flags can be used in conjunction with the /ssl flag, the ssl flag is redundant. Conversely, however, the /ssl flag does not imply any of these flags; the /ssl flag means SSLv3 or, if not available, SSLv2 in the SSL port. * WebAlpine: add _GNU_SOURCE to make pubcookie build. * On my way to make 'make dist' and 'make distcheck' actually work. --- web/src/cgi.tcl-1.10/cgi.tcl | 2659 ++++++++++++++++++++++++++++++++++++++++++ web/src/cgi.tcl-1.10/version | 2 + 2 files changed, 2661 insertions(+) create mode 100644 web/src/cgi.tcl-1.10/cgi.tcl create mode 100644 web/src/cgi.tcl-1.10/version (limited to 'web/src/cgi.tcl-1.10') 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 , 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 {\>} args + cgi_put "" +} + +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 display +proc cgi_url {display args} { + global _cgi + + set buf "$display" +} + +# generate an image reference () +# first arg is image url +# other args are passed through into tag +proc cgi_img {args} { + global _cgi + + set buf "" +} + +# names an anchor so that it can be linked to +proc cgi_anchor_name {name} { + return "" +} + +proc cgi_base {args} { + global _cgi + + cgi_put "" +} + +################################################## +# 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 {\&} s ;# must be first! + regsub -all {"} $s {\"} s + regsub -all {<} $s {\<} s + regsub -all {>} $s {\>} 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 "" +} + +# 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 " 1} { + cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]" + set args [lrange $args end end] + } + cgi_put ">[lindex $args 0]" +} + +proc cgi_p {args} { + cgi_put " 1} { + cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]" + set args [lrange $args end end] + } + cgi_put ">[lindex $args 0]

" +} + +proc cgi_address {s} {cgi_put
$s
} +proc cgi_blockquote {s} {cgi_puts
$s
} + +################################################## +# long or multiple paragraph support +################################################## + +# Shorthand for
. We used to use
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 "" + + 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 "" + + 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
  • 1} { + cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]" + } + cgi_put ">[lindex $args end]
    • " +} + +proc cgi_number_list {args} { + cgi_put "" + + 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 "" + + 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
    $s
    } +proc cgi_term_definition {s} {cgi_put
    $s
    } + +proc cgi_definition_list {cmd} { + cgi_put "
    " + _cgi_close_proc_push "cgi_put
    " + + uplevel 1 $cmd + _cgi_close_proc +} + +proc cgi_menu_list {cmd} { + cgi_put "" + _cgi_close_proc_push "cgi_put " + + uplevel 1 $cmd + _cgi_close_proc +} +proc cgi_directory_list {cmd} { + cgi_put "" + _cgi_close_proc_push "cgi_put " + + uplevel 1 $cmd + _cgi_close_proc +} + +################################################## +# text support +################################################## + +proc cgi_put {s} {cgi_puts -nonewline $s} + +# some common special characters +proc cgi_lt {} {return "<"} +proc cgi_gt {} {return ">"} +proc cgi_amp {} {return "&"} +proc cgi_quote {} {return """} +proc cgi_enspace {} {return " "} +proc cgi_emspace {} {return " "} +proc cgi_nbspace {} {return " "} ;# nonbreaking space +proc cgi_tm {} {return "®"} ;# registered trademark +proc cgi_copyright {} {return "©"} +proc cgi_isochar {n} {return "&#$n;"} +proc cgi_breakable {} {return ""} + +proc cgi_unbreakable_string {s} {return "$s"} +proc cgi_unbreakable {cmd} { + cgi_put "" + _cgi_close_proc_push "cgi_put " + uplevel 1 $cmd + _cgi_close_proc +} + +proc cgi_nl {args} { + set buf "" +} + +proc cgi_bold {s} {return "$s"} +proc cgi_italic {s} {return "$s"} +proc cgi_underline {s} {return "$s"} +proc cgi_strikeout {s} {return "$s"} +proc cgi_subscript {s} {return "$s"} +proc cgi_superscript {s} {return "$s"} +proc cgi_typewriter {s} {return "$s"} +proc cgi_blink {s} {return "$s"} +proc cgi_emphasis {s} {return "$s"} +proc cgi_strong {s} {return "$s"} +proc cgi_cite {s} {return "$s"} +proc cgi_sample {s} {return "$s"} +proc cgi_keyboard {s} {return "$s"} +proc cgi_variable {s} {return "$s"} +proc cgi_definition {s} {return "$s"} +proc cgi_big {s} {return "$s"} +proc cgi_small {s} {return "$s"} + +proc cgi_basefont {size} {cgi_put ""} + +proc cgi_font {args} { + global _cgi + + set buf "[lindex $args end]" +} + +# 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 "" +} + +proc _cgi_html_end {} { + global _cgi + unset _cgi(html_in_progress) + set _cgi(html_done) 1 + cgi_puts "" +} + +# 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 "" + } + + # 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 "" + } 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 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" + } + 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 "" +} + +# Do whatever you want with meta tags. +# Example: +proc cgi_meta {args} { + cgi_put "" +} + +proc cgi_relationship {rel href args} { + 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 "" + + cgi_debug { + global env + catch {cgi_puts "Input: 
    $_cgi(input)
    "} + catch {cgi_puts "Cookie: 
    $env(HTTP_COOKIE)
    "} + } + + 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 "" + + 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 "" + _cgi_close_proc_push "cgi_puts " + + uplevel 1 [lindex $args end] + + _cgi_close_proc +} + +proc cgi_javascript {args} { + cgi_puts "" + cgi_puts "\n"} + + uplevel 1 [lindex $args end] + + _cgi_close_proc +} + +proc cgi_noscript {args} { + cgi_puts "" + _cgi_close_proc_push {cgi_puts ""} + + uplevel 1 [lindex $args end] + + _cgi_close_proc +} + +proc cgi_applet {args} { + cgi_puts "" + _cgi_close_proc_push "cgi_puts " + + uplevel 1 [lindex $args end] + _cgi_close_proc +} + +proc cgi_param {nameval} { + regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value + + if {$q != "="} { + set value "" + } + cgi_puts "" +} + +# 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 "" +} + +################################################## +# 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 "
    " + 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 "
    " +} + +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 "" +} + +################################################## +# 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 -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 "" + 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 "" + 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 "" +} + +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 "" +} + +# 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 "" +} + + +proc cgi_reset_button {{value Reset} args} { + cgi_put "" +} + +proc cgi_radio_button {nameval args} { + regexp "(\[^=]*)=(.*)" $nameval dummy name value + + cgi_put "" +} + +proc cgi_image_button {nameval args} { + regexp "(\[^=]*)=(.*)" $nameval dummy name value + cgi_put "" +} + +# map/area implement client-side image maps +proc cgi_map {name cmd} { + cgi_put "" + _cgi_close_proc_push "cgi_put " + + uplevel 1 $cmd + _cgi_close_proc +} + +proc cgi_area {args} { + cgi_put "" +} + +################################################## +# checkbox support +################################################## + +proc cgi_checkbox {nameval args} { + regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value + cgi_put "" +} + +################################################## +# textentry support +################################################## + +proc cgi_text {nameval args} { + regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value + + cgi_put "" +} + +################################################## +# textarea support +################################################## + +proc cgi_textarea {nameval args} { + regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value + + cgi_put "" +} + +################################################## +# 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 "" +} + +# 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 "