#!/bin/bash
 
 SRC="$1"
 
 if [ -z "${SRC}" ]; then
     echo "Usage: ttml2cgi <file>" >&2
     exit 1
 fi
 DEST=`echo "${SRC}" | sed s/'.ttml$'/'.cgi'/`
 if [ "${DEST}" = "${SRC}" ]; then
     DEST="${DEST}.cgi"
 fi
 
 if [ -L "${SRC}" ]; then
     SRC="`ls -l "${SRC}" | awk '{ print $11 }' | sed s/'.ttml$'/'.cgi'/`"
     echo "Symlinking ${SRC} to ${DEST} ... done." >&2
     ln -fs ${SRC} ${DEST}
     exit 0
 fi
 
 echo -n "Converting ${SRC} to ${DEST} ... " >&2
 
 cat <<EOF >"${DEST}"
 #!/usr/bin/tcl
 
 if {![info exists ::GLOBALS]} {
   set VARS(tmp) ""
   unset VARS(tmp)
   set ::GLOBALS "[info globals] GLOBALS"
 }
 
 proc hputs {text} {
   global TTML
   set TTML(exists) 1
   if {![info exists TTML(header_sent)]} { set need_header 1 } else { set need_header 0 }
   if {\$text=="" || \$text=="\n"} {
     set need_header 0
   }
   if {\$need_header} {
     if {![info exists TTML(header_type)]} { set TTML(header_type) "text/html" }
     set TTML(header_sent) 1
     puts "Content-type: \$TTML(header_type)\n"
   }
   puts -nonewline \$text
 }
 
 proc parse {file} {
     regsub {\.ttml\$} \$file {.cgi} file
     if {![file exists \$file]} { error "No such file" }
     
     uplevel #0 "source \$file"
 }
 
 proc hsavevars {{method "form"}} {
     global GLOBALS VARS
     set joinchars(form) "\n"
     set joinchars(get) "&"
 
     if {![info exists joinchars(\$method)]} { return "" }
     set newGLOBALS [lindex [intersect3 \$GLOBALS [info globals]] 2]
 
     set ret ""
 #   set vars [union \$newGLOBALS [array names VARS]]
     set vars [union [array names VARS] ""]
     foreach var \$vars {
         if {[string tolower \$var]=="submit"} { continue }
         if {[string tolower \$var]=="cancel"} { continue }
         global \$var
         if {[info exists VARS(\$var)]} {
             set val \$VARS(\$var)
         } else {
             set val [subst \\\$\$var]
         }
 
         switch -- \$method {
             "form" {
                 lappend ret "<input type=\"hidden\" name=\"\$var\" value=\"[string map {\" \\\"} \$val]\">"
             }
             "get" {
                 lappend ret "\$var=[hexcode \$val]"
             }
         }
     }
     return [join \$ret \$joinchars(\$method)]
 }
 
 proc hexcode {text} {
     set ret ""
     set is [string length \$text]
     for {set i 0} {\$i<\$is} {incr i} {
         set char [string index \$text \$i]
         if {![ctype alnum \$char]} {
             set char [format "%%%02x" [ctype ord \$char]]
         }
         append ret \$char
     }
     return \$ret
 }
 
 proc dehexcode {val} {
     set val [string map {+ \ } \$val]
     foreach pt [split \$val %] {
         if {![info exists rval]} { set rval \$pt; continue }
         set char [ctype char 0x[string range \$pt 0 1]]
         append rval "\$char[string range \$pt 2 end]"
     }
     if {![info exists rval]} { set rval "" }
     return \$rval
 }
 
 proc hgetvars {} {
     global VARS env
     if {![info exists env(QUERY_STRING)]} { return }
     foreach {var val} [split \$env(QUERY_STRING) &=] { set VARS(\$var) [dehexcode \$val] }
     foreach {var val} [split [gets stdin] &=] { set VARS(\$var) [dehexcode \$val] }
 }
 
 catch {
 EOF
 
 echo -n "  hputs {" >> "${DEST}"
 sed -e s/'<?'/'};'/g -e s/'?>'/';hputs {'/g -e s/'ENVS'/'env'/g "${SRC}" >> "${DEST}"
 
 echo "  }" >> "${DEST}"
 cat <<EOF >>"${DEST}"
 } errmsg
 
 if {\$errmsg!=""} {
   hputs "[replicate </td></tr></table> 10]"
   if {[info procs bgerror]!=""} {
     bgerror \$errmsg
   } else {
     hputs "An internal error has occured."
   }
   hputs "</body></html>"
 }
 EOF
 
 chmod +x "${DEST}"
 
 echo "done." >&2