home *** CD-ROM | disk | FTP | other *** search
/ Practical Programming in Tcl & Tk (4th Edition) / TCLBOOK4.BIN / pc / exsource / cgilib.tcl < prev    next >
Text File  |  2003-04-15  |  5KB  |  219 lines
  1. # cgilib.tcl
  2.  
  3. # This is the cgilib.tcl that I actually use for CGI scripts,
  4. # although I end up using a fair amount more code than this,
  5. # especially inside TclHttpd
  6.  
  7. # Note that Cgi_Parse has some funky semantics where if there is
  8. # only one instance of a form value it doesn't add list structure.
  9. # You have to know what to expect to use this properly.  If you
  10. # need to be fully general, I suggest you use
  11. # foreach {name value} [Cgi_List] { ... }
  12. # instead of Cgi_Par
  13.  
  14. proc Cgi_Parse {} {
  15.     global cgi query
  16.     set query [Cgi_Query]
  17.     regsub -all {\+} $query { } query
  18.     foreach {name value} [split $query &=] {
  19.     set name [CgiDecode $name]
  20.     if [info exists list($name)] {
  21.         set cgi($name) [list $cgi($name) [CgiDecode $value]]
  22.         unset list($name)
  23.     } elseif [info exists cgi($name)] {
  24.         lappend cgi($name) [CgiDecode $value]
  25.     } else {
  26.         set cgi($name) [CgiDecode $value]
  27.         set list($name) 1    ;# Need to listify if more values are added
  28.     }
  29.     }
  30.     return [array names cgi]
  31. } 
  32. proc Cgi_List {} {
  33.     set query [Cgi_Query]
  34.     regsub -all {\+} $query { } query
  35.     set result {}
  36.     foreach {x} [split $query &=] {
  37.     lappend result [CgiDecode $x]
  38.     }
  39.     return $result
  40. }
  41. proc Cgi_Query {} {
  42.     global env
  43.     if {![info exists env(QUERY_STRING)] ||
  44.         [string length $env(QUERY_STRING)] == 0} {
  45.     if {[info exists env(CONTENT_LENGTH)] &&
  46.         [string length $env(CONTENT_LENGTH)] != 0} {
  47.         set query [read stdin $env(CONTENT_LENGTH)]
  48.     } else {
  49.         fconfigure stdin -blocking 0
  50.         if {[gets stdin query] < 0} {
  51.         set query ""
  52.         }
  53.     }
  54.     } else {
  55.     set query $env(QUERY_STRING)
  56.     }
  57.     set env(ALT_QUERY_STRING) $query
  58.     return $query
  59. }
  60. proc CgiDecode {str} {
  61.     # Protect Tcl special chars
  62.     regsub -all {[][\\\$]} $str {\\&} str
  63.     # Replace %xx sequences with a format command
  64.     regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $str {[format %c 0x\1]} str
  65.     # Replace the format commands with their result
  66.     return [subst $str]
  67. }
  68. # do x-www-urlencoded character mapping
  69. # The spec says: "non-alphanumeric characters are replaced by '%HH'"
  70.  
  71. for {set i 1} {$i <= 256} {incr i} {
  72.     set c [format %c $i]
  73.     if {![string match \[a-zA-Z0-9\] $c]} {
  74.         set UrlEncodeMap($c) %[format %.2x $i]
  75.     }
  76. }
  77.  
  78. # These are handled specially
  79. array set UrlEncodeMap {
  80.     " " +   \n %0d%0a
  81. }
  82.  
  83. # 1 leave alphanumerics characters alone
  84. # 2 Convert every other character to an array lookup
  85. # 3 Escape constructs that are "special" to the tcl parser
  86. # 4 "subst" the result, doing all the array substitutions
  87.  
  88. proc CgiEncode {string} {
  89.     global UrlEncodeMap 
  90.     regsub -all \[^a-zA-Z0-9\] $string {$UrlEncodeMap(&)} string
  91.     regsub -all \n $string {\\n} string
  92.     regsub -all \t $string {\\t} string
  93.     regsub -all {[][{})\\]\)} $string {\\&} string
  94.     return [subst $string]
  95. }
  96. proc Url_Encode {string} {
  97.     CgiEncode $string
  98. }
  99.  
  100. proc Cgi_Value {key} {
  101.     global cgi
  102.     if [info exists cgi($key)] {
  103.     return $cgi($key)
  104.     } else {
  105.     return {}
  106.     }
  107. }
  108. proc Cgi_Header {title {bodyparams {}}} {
  109.     puts stdout \
  110. "Content-Type: text/html
  111.  
  112. <HTML>
  113. <Head>
  114. <title>$title</title>
  115. </Head>
  116. <Body $bodyparams>"
  117. }
  118. proc Cgi_Tail {} {
  119.     puts </Body>
  120. }
  121. proc Cgi_Redirect {url} {
  122.     puts stdout "\
  123. Content-type: text/html
  124. Location: $url
  125.  
  126. Please go to $url
  127. "
  128. }
  129. proc Cgi_CopyBits {file} {
  130.     if {![file exists $file] ||
  131.     [catch {open $file} in]} {
  132.     puts "Content-Type: text/html"
  133.     puts ""
  134.     puts "Cannot find file [file tail $file]"
  135.     exit 0
  136.     }
  137.     switch -- [file extension $file] {
  138.     ".hqx" {set type application/mac-binhex40}
  139.     default {set type application/octet-stream}
  140.     }
  141.     puts stdout "Content-Type: $type\nContent-Length: [file size $file]"
  142.     puts ""
  143.     fconfigure stdout -translation binary -buffering full -buffersize 8192
  144.     fconfigure $in -translation binary
  145.     copychannel $in stdout
  146.     close $in
  147. }
  148. proc H1 {str} {
  149.     Html_Tag H1 {} $str
  150. }
  151. proc H2 {str} {
  152.     Html_Tag H2 {} $str
  153. }
  154. proc H3 {str} {
  155.     Html_Tag H3 {} $str
  156. }
  157. proc H4 {str} {
  158.     Html_Tag H4 {} $str
  159. }
  160. proc H5 {str} {
  161.     Html_Tag H5 {} $str
  162. }
  163. proc H6 {str} {
  164.     Html_Tag H6 {} $str
  165. }
  166. proc P {} {
  167.     puts stdout <p>
  168. }
  169. proc Link {text href} {
  170.     puts "<a href=\"$href\">$text</a>"
  171. }
  172. proc Html_Tag {tag params str} {
  173.     puts stdout "<[string trim "$tag $params"]>$str</$tag>"
  174. }
  175. proc Form {url {method POST}} {
  176.     puts stdout "<form action=\"$url\" method=$method>"
  177. }
  178. proc Counter {filename} {
  179.     if [catch {open $filename} in] {
  180.     set number 0
  181.     } else {
  182.     set info [read $in]
  183.     close $in
  184.     if ![regexp {[0-9]+} $info number] {
  185.         return [clock seconds]    ;# Bail - race with file access
  186.     }
  187.     }
  188.     incr number
  189.     # Cannot open $filename.new because we likely won't
  190.     # have permission to create the temp file.
  191.     set out [open $filename w]
  192.     puts $out $number
  193.     close $out
  194.     return $number
  195. }
  196.  
  197. # Empty --
  198. #
  199. #    Return true if the variable doesn't exist or is an empty string
  200.  
  201. proc Empty {varname} {
  202.     upvar 1 $varname var
  203.     return [expr {![info exist var] || [string length $var] == 0}]
  204. }
  205.  
  206. # Cgi_SubstFile --
  207. # Use a file as a template
  208.  
  209. proc Cgi_SubstFile {path} {
  210.     if {[catch {open $path} in]} {
  211.     puts "<pre>Cgi_SubstFile: $path: $in</pre>"
  212.     } else {
  213.     set X [read $in]
  214.     close $in
  215.     puts [uplevel 1 [list subst $X]]
  216.     }
  217.     flush stdout
  218. }
  219.