proc cgi_comment {args} {} ;
proc cgi_html_comment {args} {
regsub -all {>} $args {\>} args
cgi_puts "<!--[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
catch {
if [info exists noprint] {
uplevel 1 [lindex $args 0]
} else {
cgi_html {
cgi_head {
cgi_title "debugging before complete HTML head"
}
cgi_body_start
uplevel 1 [lindex $args 0]
error "ignore"
}
}
}
}
}
if [info exists temp] {
set _cgi(debug) $old
}
return $old
}
proc cgi_uid_check {user} {
global env
if [regexp "^-off$" $user] return
if [info exists env(USER)] {
set whoami $env(USER)
} elseif {0==[catch {exec who am i} whoami]} {
regexp "(.*!)?(\[^ \t]*)" $whoami dummy dummy whoami
if {$whoami != "$user"} {
error \
"Warning: This CGI script expects to run with uid \"$user\". However,
this script is running as \"$whoami\"."
}
}
}
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
set _cgi(body) $cmd
uplevel if 1==[catch $_cgi(body) errMsg] {
set _cgi(errorInfo) $errorInfo
cgi_close_procs
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:"
cgi_preformatted {
cgi_puts [cgi_quote_html $_cgi(errorInfo)]
}
} else {
hgetvars
cgi_mail_start $_cgi(admin_email)
cgi_mail_add "Subject: [cgi_name] CGI problem"
cgi_mail_add
cgi_mail_add "ttml environment:"
cgi_mail_add "REQUEST_METHOD: $::request::ENVS(REQUEST_METHOD)"
cgi_mail_add "SCRIPT_NAME: $::request::ENVS(SCRIPT_FILENAME)"
catch {cgi_mail_add "REMOTE_HOST: $::request::ENVS(REMOTE_HOST)"}
catch {cgi_mail_add "REMOTE_ADDR: $::request::ENVS(REMOTE_ADDR)"}
cgi_mail_add "mod_dtcl.tcl version: 0.7.5"
cgi_mail_add "input:"
catch {cgi_mail_add $_cgi(input)}
cgi_mail_add "errorInfo:"
cgi_mail_add "$_cgi(errorInfo)"
cgi_mail_end
}
}
} ; } ; } ; } ; cgi_cleanup
}
proc cgi_error_occurred {} {
global _cgi
return [info exists _cgi(errorInfo)]
}
proc cgi_root {args} {
global _cgi
if {[llength $args]} {
set _cgi(root) [lindex $args 0]
} else {
set _cgi(root)
}
}
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
return $variable=$value
}
proc cgi_link {args} {
global _cgi_link _cgi_link_url
set tag [lindex $args 0]
if {[llength $args] >= 3} {
set _cgi_link_url($tag) [lrange $args 2 end]
set _cgi_link($tag) [eval cgi_url [lrange $args 1 end]]
} elseif {[llength $args] == 2} {
return [eval cgi_url [lindex $args end] $_cgi_link_url($tag)]
}
return $_cgi_link($tag)
}
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_url {display args} {
set buf "<a href=\"[lindex $args 0]\""
foreach a [lrange $args 1 end] {
if {[regexp "^(target|onClick|onMouseOver|onMouseOut)=(.*)" $a dummy attr str]} {
append buf " $attr=\"$str\""
} else {
append buf " $a"
}
}
return "$buf>$display</a>"
}
proc cgi_http_get {url} {
regexp {^(http://)?([^:/]+)(:([0-9]*))?/?(.*)} $url dummy \
http host : port file
if ![string length $port] {
set port 80
}
set socket [socket $host $port]
fconfigure $socket -buffering line
puts $socket "GET /$file\n\r"
set data [read $socket]
close $socket
return $data
}
proc cgi_img {args} {
set buf "<img src=\"[lindex $args 0]\""
foreach a [lrange $args 1 end] {
if {[regexp "^(alt|width|height|lowsrc|usemap)=(.*)" $a dummy attr str]} {
append buf " $attr=[cgi_dquote_html $str]"
} elseif {[regexp "^onError" $a dummy str]} {
append buf " onError=\"$str\""
} else {
append buf " $a"
}
}
return "$buf>"
}
proc cgi_anchor_name {name} {
return "<a name=\"$name\">"
}
proc cgi_base {args} {
cgi_put "<base"
foreach a $args {
if {[regexp "^href=(.*)" $a dummy str]} {
cgi_put " href=[cgi_dquote_html $str]"
} elseif {[regexp "^target=(.*)" $a dummy str]} {
cgi_put " target=\"$str\""
} else {
cgi_put " $a"
}
}
cgi_puts ">"
}
proc cgi_quote_html {s} {
regsub -all {&} $s {\&} s ; 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
}
proc cgi_br {args} {
cgi_put "<br"
if [llength $args] {
cgi_put "[cgi_list_to_string $args]"
}
cgi_puts ">"
}
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_puts ">[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_puts ">[lindex $args 0]</p>"
}
proc cgi_address {s} {cgi_puts <address>$s</address>}
proc cgi_blockquote {s} {cgi_puts <blockquote>$s</blockquote>}
proc cgi_center {cmd} {
uplevel "cgi_division align=center [list $cmd]"
}
proc cgi_division {args} {
cgi_put "<div"
cgi_close_proc_push "cgi_puts </div>"
if {[llength $args]} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">"
uplevel 1 [lindex $args end]
cgi_close_proc
}
proc cgi_preformatted {args} {
cgi_put "<pre"
cgi_close_proc_push "cgi_puts </pre>"
if {[llength $args]} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">"
uplevel 1 [lindex $args end]
cgi_close_proc
}
proc cgi_li {args} {
cgi_put <li
if {[llength $args] > 1} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">[lindex $args end]"
}
proc cgi_number_list {args} {
cgi_put "<ol"
cgi_close_proc_push "cgi_puts </ol>"
if {[llength $args] > 1} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">"
uplevel 1 [lindex $args end]
cgi_close_proc
}
proc cgi_bullet_list {args} {
cgi_put "<ul"
cgi_close_proc_push "cgi_puts </ul>"
if {[llength $args] > 1} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">"
uplevel 1 [lindex $args end]
cgi_close_proc
}
proc cgi_term {s} {cgi_puts <dt>$s}
proc cgi_term_definition {s} {cgi_puts <dd>$s}
proc cgi_definition_list {cmd} {
cgi_puts "<dl>"
cgi_close_proc_push "cgi_puts </dl>"
uplevel 1 $cmd
cgi_close_proc
}
proc cgi_menu_list {cmd} {
cgi_puts "<menu>"
cgi_close_proc_push "cgi_puts </menu>"
uplevel 1 $cmd
cgi_close_proc
}
proc cgi_directory_list {cmd} {
cgi_puts "<dir>"
cgi_close_proc_push "cgi_puts </dir>"
uplevel 1 $cmd
cgi_close_proc
}
proc cgi_put {s} {cgi_puts -nonewline $s}
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 " "} ;proc cgi_tm {} {return "®"} ;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_puts "<nobr>"
cgi_close_proc_push "cgi_puts </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_puts "<basefont size=$size>"}
proc cgi_font {args} {
set buf "<font"
foreach a [lrange $args 0 [expr [llength $args]-2]] {
if {[regexp "^color=(.*)" $a dummy str]} {
append buf " color=\"$str\""
} else {
append buf " $a"
}
}
return "$buf>[lindex $args end]</font>"
}
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
append buffer [lindex $args end]
if {[llength $args] == 1} {
append buffer $_cgi(buffer_nl)
}
}
if [catch {uplevel $cmd} errMsg] {
global errorInfo
set savedInfo $errorInfo
}
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
}
proc cgi_html {html} {
cgi_html_start
uplevel 1 $html
cgi_html_end
}
proc cgi_html_start {} {
global _cgi
if [info exists _cgi(html_in_progress)] return
set _cgi(html_in_progress) 1
cgi_doctype
cgi_puts "<html>"
}
proc cgi_html_end {} {
global _cgi
unset _cgi(html_in_progress)
if {![info exists _cgi(skeleton_outside_tcl)]} {
cgi_puts "</html>"
cgi_cleanup
}
}
proc cgi_cleanup {} {
global _cgi
unset _cgi
set _cgi(debug) -off
cgi_name ""
cgi_root ""
cgi_body_args ""
cgi_admin_mail_addr [cgi_permanent_admin_mail_addr]
cgi_mail_addr [cgi_permanent_mail_addr]
cgi_init_tmpdir
}
proc cgi_head {{head {}}} {
global _cgi
if [info exists _cgi(head_done)] {
return
}
if {0 == [info exists _cgi(head_in_progress)]} {
set _cgi(head_in_progress) 1
cgi_puts "<head>"
}
set _cgi(html_in_progress) 1
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
catch {unset _cgi(head_in_progress)}
}
proc cgi_title {args} {
global _cgi
set title [lindex $args 0]
if {[llength $args]} {
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)
}
proc cgi_http_equiv {type contents} {
cgi_puts "<meta http-equiv=\"$type\" content=[cgi_dquote_html $contents]>"
}
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)
}
proc cgi_body {args} {
global errorInfo _cgi
if 1==[catch {
eval cgi_body_start [lrange $args 0 [expr [llength $args]-2]]
uplevel 1 [lindex $args end]
} errMsg] {
set savedInfo $errorInfo
error $errMsg $savedInfo
}
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(skeleton_outside_tcl)]} {
return
}
if ![info exists _cgi(errorInfo)] {
uplevel 2 app_body_end
}
unset _cgi(body_in_progress)
cgi_puts "</body>"
}
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 {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]>"
}
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
}
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 }
}
proc cgi_close_tag {} {
global _cgi
if [info exists _cgi(tag_in_progress)] {
cgi_puts ">"
unset _cgi(tag_in_progress)
}
}
proc cgi_hr {args} {
global _cgi
cgi_put "<hr"
if [llength $args] {
cgi_put "[cgi_list_to_string $args]"
}
cgi_puts ">"
}
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|enctype|onReset|onSubmit)=(.*)" $a dummy attr str]} {
cgi_put " $attr=\"$str\""
} else {
cgi_put " $a"
}
}
cgi_puts " $method>"
uplevel 1 [lindex $args end]
cgi_close_proc
catch {unset _cgi(form_in_progress)}
}
proc cgi_form_end {} {
global _cgi
catch {unset _cgi(form_in_progress)}
cgi_puts "</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_puts ">"
}
proc cgi_input {} {
global _cgi
hgetvars
set _cgi(input_done) 1
return
}
proc cgi_export {nameval} {
regexp "(\[^=]*)(=?)(.*)" $nameval dummy name q value
if {$q != "="} {
set value [uplevel 1 set [list $name]]
}
cgi_puts "<input type=hidden name=\"$name\" value=[cgi_dquote_html $value]>"
}
proc cgi_import_list {} {
return [array names ::request::VARS]
}
proc cgi_import {name} {
upvar 1 $name var
set var $::request::VARS($name)
}
proc cgi_import_as {name tclvar} {
upvar 1 $tclvar var
set var $::request::VARS($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_puts ">"
}
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_puts ">"
}
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_puts ">"
}
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 "^onClick=(.*)" $a dummy str]} {
cgi_put " onClick=\"$str\""
} else {
cgi_put " $a"
}
}
cgi_puts ">"
}
proc cgi_image_button {nameval} {
regexp "(\[^=]*)=(.*)" $nameval dummy name value
cgi_put "<input type=image"
if {0!=[string compare "" $name]} {
cgi_put " name=\"$name\""
}
cgi_puts " src=\"$value\">"
}
proc cgi_map {name cmd} {
cgi_put "<map name=\"$name\">"
cgi_close_proc_push "cgi_puts </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_puts ">"
}
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 "^onClick=(.*)" $a dummy str]} {
cgi_put " onClick=\"$str\""
} else {
cgi_put " $a"
}
}
cgi_puts ">"
}
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_puts ">"
}
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_puts ">"
if {$q != "="} {
set value [uplevel 1 set [list $name]]
}
cgi_puts [cgi_quote_html $value]
cgi_puts "</textarea>"
}
proc cgi_file_button {name args} {
cgi_puts "<input type=file name=\"$name\"[cgi_list_to_string $args]>"
}
proc cgi_select {name args} {
cgi_put "<select name=\"$name\""
cgi_close_proc_push "cgi_puts </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] {
; if ![regexp "List$" $name] {
cgi_puts ">" ; 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_puts ">"
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]"
}
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_url $var]"
} else {
cgi_put " $a"
}
}
}
cgi_puts ">"
}
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
cgi_mail_add "Return-Path: <$_cgi(email)>"
cgi_mail_add "From: [cgi_name] <$_cgi(email)>"
cgi_mail_add "To: $to"
}
proc cgi_mail_add {{arg {}}} {
global _cgi
puts $_cgi(mailfid) $arg
}
proc cgi_mail_end {} {
global _cgi
flush $_cgi(mailfid)
if {[file executable /usr/lib/sendmail]} {
exec /usr/lib/sendmail -t -odb < $_cgi(mailfile)
} else {
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 "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_table {args} {
cgi_put "<table"
cgi_close_proc_push "cgi_puts </table>"
if {[llength $args]} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">"
uplevel 1 [lindex $args end]
cgi_close_proc
}
proc cgi_caption {args} {
cgi_put "<caption"
cgi_close_proc_push "cgi_puts </caption>"
if {[llength $args]} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">"
uplevel 1 [lindex $args end]
cgi_close_proc
}
proc cgi_table_row {args} {
cgi_put "<tr"
cgi_close_proc_push "cgi_puts </tr>"
if {[llength $args]} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">"
uplevel 1 [lindex $args end]
cgi_close_proc
}
proc cgi_tr {args} {
cgi_puts <tr
if {[llength $args] > 1} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">"
foreach i [lindex $args end] {
cgi_td $i
}
cgi_puts </tr>
}
proc cgi_table_head args {
cgi_put "<th"
cgi_close_proc_push "cgi_puts </th>"
if {[llength $args]} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">"
uplevel 1 [lindex $args end]
cgi_close_proc
}
proc cgi_th args {
cgi_put "<th"
if {[llength $args] > 1} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">[lindex $args end]</th>"
}
proc cgi_table_data args {
cgi_put "<td"
cgi_close_proc_push "cgi_puts </td>"
if {[llength $args]} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">"
uplevel 1 [lindex $args end]
cgi_close_proc
}
proc cgi_td {args} {
cgi_put "<td"
if {[llength $args] > 1} {
cgi_put "[cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_puts ">[lindex $args end]</td>"
}
proc cgi_frameset {args} {
cgi_head ;
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
}
proc cgi_admin_mail_addr {args} {
global _cgi
if [llength $args] {
set _cgi(admin_email) [lindex $args 0]
}
return $_cgi(admin_email)
}
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"
}
}
proc cgi_list_to_string {list} {
set string ""
foreach l $list {
append string " $l"
}
return $string
}
proc cgi_lrange {list i1 i2} {
cgi_list_to_string [lrange $list $i1 $i2]
}
proc app_body_start {} {}
proc app_body_end {} {}
proc cgi_puts {args} {
if {[llength $args] == "1"} {
hputs "[lindex $args 0]\n"
return 0
}
if {[llength $args] == "2" && [lindex $args 0] == "-nonewline" } {
hputs "[lindex $args 1]"
} else {
}
}
proc cgi_doctype {} {}
proc cgi_permanent_admin_mail_addr {args} {
global _cgiPermanent
if [llength $args] {
set _cgiPermanent(admin_email) [lindex $args 0]
}
return $_cgiPermanent(admin_email)
}
proc cgi_permanent_mail_addr {args} {
global _cgiPermanent
if [llength $args] {
set _cgiPermanent(email) [lindex $args 0]
}
return $_cgiPermanent(email)
}
proc cgi_skeleton_outside_tcl {} {
global _cgi
set _cgi(html_in_progress) 1
set _cgi(head_done) 1
set _cgi(body_in_progress) 1
set _cgi(skeleton_outside_tcl) 1
}
proc cgi_init_tmpdir {} {
global _cgi tcl_platform
switch $tcl_platform(platform) {
unix {
set _cgi(tmpdir) /tmp
} macintosh {
set _cgi(tmpdir) [pwd]
} default {
set _cgi(tmpdir) [pwd]
catch {set _cgi(tmpdir) $env(TMP)}
catch {set _cgi(tmpdir) $env(TEMP)}
}
}
}
cgi_name ""
cgi_root ""
cgi_body_args ""
cgi_admin_mail_addr "root" ;cgi_permanent_admin_mail_addr [cgi_admin_mail_addr]
cgi_mail_addr "CGI script - do not reply"
cgi_permanent_mail_addr [cgi_mail_addr]
cgi_init_tmpdir
package provide cgi 0.7.5