kiwi/0040755000076400001440000000000007357667746010566 5ustar jcwuserskiwi/server.tcl0100644000076400001440000001317207357331420012552 0ustar jcwusers# Tequila server - September 2001, by Jean-Claude Wippler package require Tcl 8.4 set auto_index(bgerror) { proc bgerror {msg} { puts stderr "[clock format [clock seconds] -format {%Y/%m/%d %T}] $msg" } } namespace eval tequila::server { variable clients ;# clients(port) -> list of owned tequila keys variable notify ;# notify(view) -> list of sockets to notify # determine the path name of an array proc path {view} { variable root # convert colons to slashes, just in case set view [string map {: /} $view] # the following prevents nasty tricks with ".." and slashes return "$root[file normalize /$view]" } # this starts the server running, do a vwait on return value to keep it busy proc start {{r files} {p 20458} {m 127.0.0.1}} { variable root $r port $p mask $m quit [clock seconds] file delete -force [path tequila] socket -server [namespace current]::connected $port return [namespace current]::quit } # called whenever a connection is opened proc connected {sock addr port} { variable mask if {[string match $mask $addr]} { fconfigure $sock -translation binary -buffering none -blocking 0 fileevent $sock readable [list [namespace current]::request $sock] } else { close $sock } } # called whenever a request comes in proc request {fd} { variable sock $fd if {[gets $sock line] > 0} { # careful to avoid trouble with semicolons and such set err [catch {eval [eval list cmd_$line]} msg] if {[string is upper [string index $line 0]]} { if {$err} { bgerror "err $sock: $msg ($line)" } set reply [list r $err $msg] puts -nonewline $sock "[string length $reply]\n$reply" } } elseif {![fblocked $sock]} { close $sock unsubscribe $sock } } # called to set up notification for a client proc subscribe {view} { variable notify variable sock lappend notify($view) $sock } # called to unset all notifications for a client proc unsubscribe {port} { variable clients variable notify variable sock set sock $port foreach v [array names notify] { cmd_F $v } # remove entries from the "tequila" array on connection loss if {[info exists clients($port)]} { foreach k $clients($port) { cmd_U tequila $k } unset clients($port) } } # handles tracing of all view changes (there's no read tracing) # this is also the place where delayed commits are scheduled proc tracer {view key operation} { variable clients variable notify variable sock # a change to "tequila" will be cleared on connection loss if {$view == "tequila" && $operation != "u"} { if {![info exists clients($sock)] || [lsearch -exact $clients($sock) $key] < 0} { lappend clients($sock) $key } } # special handling for server proc changes if {$view == ".proc" && [string match *.tcl $key]} { set k [namespace current]::[file root $key] switch $operation { w { foreach {a b c d} [cmd_G $view $key] break if {$a == "proc"} { proc $k $c $d } } u { rename $k "" } } } if {[info exists notify($view)]} { switch $operation { w { set req [list s $view $key [cmd_G $view $key]] } u { set req [list u $view $key] } } # this is the data that gets sent out set msg "[string length $req]\n$req" foreach p $notify($view) { if {$p != $sock} { if {[catch { puts -nonewline $p $msg }]} { catch {close $p} unsubscribe $p } } } } return } # boot id -> bootstrap logic proc cmd_B {id} { variable sock puts $sock {eval [lindex [read $tequila::conn [gets $tequila::conn]] 2]} #return [cmd_G .boot "client_$id"] set fd [open client_[file tail $id]] set data [read $fd] close $fd return $data } # define view -> normalized view name proc cmd_D {view} { file mkdir [path $view] subscribe $view return $view } # forget view -> nothing proc cmd_F {view} { variable notify variable sock if {[info exists notify($view)]} { set n [lsearch -exact $notify($view) $sock] set notify($view) [lreplace $notify($view) $n $n] if {[llength $notify($view)] == 0} { unset notify($view) } } return } # get view key -> value proc cmd_G {view key} { set k [string map {% %25 / %2F : %3A} $key] set fd [open [path $view]/$k] set v [read $fd] close $fd return $v } # names view mask type -> list proc cmd_N {view {mask *} {type f}} { set result {} foreach x [glob -nocomplain -types $type -dir [path $view] -tails $mask] { lappend result [string map {%25 % %2F / %3A :} $x] } return $result } # set view key data -> nothing proc cmd_S {view key data} { set k [string map {% %25 / %2F : %3A} $key] set fd [open [path $view]/$k w] puts -nonewline $fd $data close $fd tracer $view $key w } # unset view key -> nothing proc cmd_U {view key} { set k [string map {% %25 / %2F : %3A} $key] file delete [path $view]/$k tracer $view $key u } # extended argcounts cmdargs -> indirect call when args need to be quoted proc cmd_X {counts args} { variable sock foreach bytes [split $counts +] { set data [read $sock $bytes] if {[string length $data] < $bytes} { if {[eof $sock]} return fconfigure $sock -blocking 1 append data [read $sock [expr {$bytes-[string length $data]}]] fconfigure $sock -blocking 0 } lappend args $data } return [eval [eval list cmd_$args]] } # get url protocol -> html page # proc cmd_GET {url args} { # variable sock # puts $sock "HTTP/1.0 200 OK\nContext-Type: text/text\n\n$url" # close $sock # } } kiwi/files/0040755000076400001440000000000007357565723011660 5ustar jcwuserskiwi/files/packages/0040755000076400001440000000000007357436446013435 5ustar jcwuserskiwi/files/packages/cgi-1.5.0.tcl0100644000076400001440000020000407354423524015321 0ustar jcwusers################################################## # # 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 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 "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_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.5.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 [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 "%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 {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) {} 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." } } # 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] 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 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} foreach b $buf { regexp {^name="(.*)"} $b 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]} { # read the part into a file set foutname /tmp/CGI[pid].[incr filecount] set foutname [file join $_cgi(tmpdir) CGI[pid].[incr filecount]] set fout [open $foutname w] # "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" } } close $fout unset fout } else { # read the part into a variable set val "" 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 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] 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 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} foreach b $buf { regexp {^name="(.*)"} $b 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]} { # read the part into a file set foutname [file join $_cgi(tmpdir) CGI[pid].[incr filecount]] spawn -open [open $foutname w] 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)] if {0==$exists} { lappend _cgi(uservars) $varname } # handle lists of values correctly if {[regexp List$ $varname]} { lappend _cgi_uservar($varname) $val } else { if {$exists} { error "Multiple definitions of $varname encountered in input. If you're trying to do this intentionally (such as with select), the variable must have a \"List\" suffix." } 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 } } ################################################## # 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 "" } ################################################## # select support ################################################## proc cgi_select {name args} { cgi_put "