##################################################
# dtcl.tcl - this is mainly a subset of:
# 
#   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://www.cme.nist.gov/msid/pubs/libes96c.ps
#
# Modified to be usable with mod_dtcl by Rolf Ade <rolf@storz.de>
# DON'T USE THIS IN PRODUCTION ENVIROMMENTS!!
#
##################################################

# $Id: dtcl.tcl,v 1.2 1999/06/09 07:09:05 davidw Exp $

##################################################
# support for debugging or other crucial things we need immediately
##################################################

proc cgi_comment	{args}	{}	;# need this asap

proc cgi_html_comment	{args}	{
    regsub -all {>} $args {\&gt;} args
    cgi_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
	    # 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 who am i} whoami]} {
	# skip over "host!"
	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\"."
	}
    }
} 

# 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 #0 {
	if 1==[catch $_cgi(body) errMsg] {
	    # error occurred, handle it
	    set _cgi(errorInfo) $errorInfo

	    # 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 {
			    # to make sure, that they are there
			    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)"
			    # this next few things probably don't need
			    # a catch but I'm not positive
			    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
			}
		    }
		} ;# end cgi_body
	    } ;# end cgi_html
	} ;# end catch
    } ;# end uplevel
    cgi_cleanup
}

# 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
    return $variable=$value
}

##################################################
# URL dictionary support
##################################################

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)
}

# 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)
}

##################################################
# 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} {
    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>"
}

# fetch a url via http
# only supported under Tcl 7.5 or higher
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
}

# generate an image reference (<img ...>)
# first arg is image url
# other args are passed through into <img> tag
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>"
}

# names an anchor so that it can be linked to
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 ">"
}

##################################################
# quoting support
##################################################

# return string but with html-special characters escaped,
# necessary if you want to send unknown text to an html-formatted page.
proc cgi_quote_html {s} {
    regsub -all {&}	$s {\&amp;}	s	;# must be first!
    regsub -all {"}	$s {\&quot;}	s
    regsub -all {<}	$s {\&lt;}	s
    regsub -all {>}	$s {\&gt;}	s
    return $s
}

proc cgi_dquote_html {s} {
    return \"[cgi_quote_html $s]\"
}

# return string quoted appropriately to appear in a url
proc cgi_quote_url {in} {
    regsub -all {%}  $in "%25" in
    regsub -all { }  $in "%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_puts ">"
}

# 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_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>}

##################################################
# 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 "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
}

##################################################
# list support
##################################################

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
}

# Following two are normally used from within definition lists
# but are actually paragraph types on their own.
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
}

##################################################
# text support
##################################################

proc cgi_put	    {s} {cgi_puts -nonewline $s}

# some common special characters
proc cgi_lt	     {}  {return "&lt;"}
proc cgi_gt	     {}  {return "&gt;"}
proc cgi_amp	     {}  {return "&amp;"}
proc cgi_quote	     {}  {return "&quot;"}
proc cgi_enspace     {}  {return "&ensp;"}
proc cgi_emspace     {}  {return "&emsp;"}
proc cgi_nbspace     {}  {return "&#160;"} ;# nonbreaking space
proc cgi_tm	     {}  {return "&#174;"} ;# registered trademark
proc cgi_copyright   {}  {return "&#169;"}
proc cgi_isochar     {n} {return "&#$n;"}
proc cgi_breakable   {}  {return "<wbr>"}

proc cgi_unbreakable_string {s} {return "<nobr>$s</nobr>"}
proc cgi_unbreakable {cmd} {
    cgi_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>"
}

# 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 $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 {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
    }
}

# internal used proc to avoid global var pollution for succesive
# .ttml pages requests
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
}

##################################################
# 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)]} {
	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]} {

	# 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_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 _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
	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_uid_check nobody
    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]>"
}

# 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_puts ">"
	unset _cgi(tag_in_progress)
    }
}

##################################################
# hr support
##################################################

proc cgi_hr {args} {
    global _cgi

    cgi_put "<hr"
    if [llength $args] {
	cgi_put "[cgi_list_to_string $args]"
    }
    cgi_puts ">"
}

##################################################
# 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|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 ">"
}

##################################################
# argument handling
##################################################

proc cgi_input {} {
    global _cgi

    hgetvars
    set _cgi(input_done) 1
    return
}

# export named variable
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]>"
}

# return list of variables available for import
# NOTICE:  this _doesn't_ keep items in order originally found in form
#          (as original cgi.tcl cgi_import_list does).
proc cgi_import_list {} {
    return [array names ::request::VARS]
}

# import named variable
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)
}


##################################################
# 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_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\">"
}

# map/area implement client-side image maps
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 ">"
}

##################################################
# 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 "^onClick=(.*)" $a dummy str]} {
	    cgi_put " onClick=\"$str\""
	} else {
	    cgi_put " $a"
	}
    }
    cgi_puts ">"
}

##################################################
# 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_puts ">"
}

##################################################
# 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_puts ">"

    if {$q != "="} {
	set value [uplevel 1 set [list $name]]
    }
    cgi_puts [cgi_quote_html $value]

    cgi_puts "</textarea>"
}

##################################################
# file upload support
##################################################

# for this to work, pass enctype=multipart/form-data to cgi_form
proc cgi_file_button {name args} {
    cgi_puts "<input type=file name=\"$name\"[cgi_list_to_string $args]>"
}

##################################################
# select support
##################################################

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] {
		;# 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_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]"
}

##################################################
# 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_url $var]"
	    } else {
		cgi_put " $a"
	    }
	}
    }
    cgi_puts ">"
}

##################################################
# 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)

    if {[file executable /usr/lib/sendmail]} {
	exec /usr/lib/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
    } else {
	# 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 "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
}

##################################################
# table support
##################################################

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
}

# like table_row but without eval
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
}

# 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_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
}

# 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_puts ">[lindex $args end]</td>"
}

##################################################
# 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"
	#proc $cgi(new) {args} "upvar 1 _cgi_local x; set x \$args; uplevel 1 \"$cgi(old) \$x\""
    }
}

##################################################
# 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]
}

##################################################
# 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} {
    if {[llength $args] == "1"} {
	hputs "[lindex $args 0]\n"
	return 0
    }
    if {[llength $args] == "2" && [lindex $args 0] == "-nonewline" } {
	hputs "[lindex $args 1]"
    } else {

    }
}

# User-defined procedure to generate DOCTYPE declaration
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)}
	}
    }
}


##################################################
# do some initialization
##################################################

cgi_name ""
cgi_root ""
cgi_body_args ""

# email addr of person responsible for this service
cgi_admin_mail_addr "root"	;# you should override this!
cgi_permanent_admin_mail_addr [cgi_admin_mail_addr]

# most services won't have an actual email addr
cgi_mail_addr "CGI script - do not reply"
cgi_permanent_mail_addr [cgi_mail_addr]

# deduce tmp directory
cgi_init_tmpdir

package provide cgi 0.7.5