diff options
Diffstat (limited to 'web')
| -rw-r--r-- | web/src/cgi.tcl-1.10/cgi.tcl | 2659 | ||||
| -rw-r--r-- | web/src/cgi.tcl-1.10/version | 2 | ||||
| -rwxr-xr-x | web/src/pubcookie/wp_gssapi_proxy | bin | 0 -> 28756 bytes | |||
| -rwxr-xr-x | web/src/pubcookie/wp_tclsh | bin | 0 -> 22279 bytes | |||
| -rwxr-xr-x | web/src/pubcookie/wp_uidmapper | bin | 0 -> 34929 bytes | |||
| -rw-r--r-- | web/src/pubcookie/wp_uidmapper.c | 5 | ||||
| -rwxr-xr-x | web/src/pubcookie/wp_umc | bin | 0 -> 21337 bytes |
7 files changed, 2665 insertions, 1 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 {\>} 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 {\&} 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 "<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 "<"} +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 "<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 diff --git a/web/src/cgi.tcl-1.10/version b/web/src/cgi.tcl-1.10/version new file mode 100644 index 00000000..14151a9d --- /dev/null +++ b/web/src/cgi.tcl-1.10/version @@ -0,0 +1,2 @@ +set versionFull 1.10.0 +set version 1.10 diff --git a/web/src/pubcookie/wp_gssapi_proxy b/web/src/pubcookie/wp_gssapi_proxy Binary files differnew file mode 100755 index 00000000..c0c2f33f --- /dev/null +++ b/web/src/pubcookie/wp_gssapi_proxy diff --git a/web/src/pubcookie/wp_tclsh b/web/src/pubcookie/wp_tclsh Binary files differnew file mode 100755 index 00000000..99528161 --- /dev/null +++ b/web/src/pubcookie/wp_tclsh diff --git a/web/src/pubcookie/wp_uidmapper b/web/src/pubcookie/wp_uidmapper Binary files differnew file mode 100755 index 00000000..8f806e5b --- /dev/null +++ b/web/src/pubcookie/wp_uidmapper diff --git a/web/src/pubcookie/wp_uidmapper.c b/web/src/pubcookie/wp_uidmapper.c index 662e9b3a..3126507e 100644 --- a/web/src/pubcookie/wp_uidmapper.c +++ b/web/src/pubcookie/wp_uidmapper.c @@ -10,8 +10,11 @@ * ======================================================================== */ +#define _GNU_SOURCE #include <system.h> #include <general.h> +#include <sys/stat.h> +#include <sys/socket.h> #include "id_table.h" #include "wp_uidmapper_lib.h" @@ -137,7 +140,7 @@ int main(int argc, char *argv[]) { exit(1); } atexit(socketname_cleanup); - chmod(ssock,sockmode); + fchmod(ssock,sockmode); #ifndef DGRAM_MODE if(listen(ssock,8)) { diff --git a/web/src/pubcookie/wp_umc b/web/src/pubcookie/wp_umc Binary files differnew file mode 100755 index 00000000..6fe5cd36 --- /dev/null +++ b/web/src/pubcookie/wp_umc |