1: # Tcl versions of Rivet commands. 2: 3: # Copyright 2003-2004 The Apache Software Foundation 4: 5: # Licensed under the Apache License, Version 2.0 (the "License"); 6: # you may not use this file except in compliance with the License. 7: # You may obtain a copy of the License at 8: 9: # http://www.apache.org/licenses/LICENSE-2.0 10: 11: # Unless required by applicable law or agreed to in writing, software 12: # distributed under the License is distributed on an "AS IS" BASIS, 13: # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14: # See the License for the specific language governing permissions and 15: # limitations under the License. 16: 17: # $Id: tclrivet.tcl,v 1.2 2004/02/24 10:24:34 davidw Exp $ 18: 19: 20: package provide tclrivet 0.1 21: 22: if {[catch { 23: load [file join [file dirname [info script]] .. .. lib [string tolower $::tcl_platform(os)] [string tolower $::tcl_platform(machine)] librivetparser[info sharedlibextension]] 24: set ::librivetparser_loaded 1 25: } tclRivetLoadError]} { 26: if {![info exists ::tclrivetparser_loaded]} { 27: set ::tclrivetparser_loaded 1 28: source [file join [file dirname [info script]] tclrivetparser.tcl] 29: } 30: } 31: 32: lappend auto_path [file join [file dirname [info script]] .. .. rivet-tcl] 33: 34: proc include { filename } { 35: set fl [ open $filename ] 36: fconfigure $fl -translation binary 37: puts -nonewline [ read $fl ] 38: close $fl 39: } 40: 41: namespace eval rivet { 42: array set header_pairs {} 43: set header_type "text/html" 44: set header_sent 0 45: set output_buffer "" 46: set send_no_content 0 47: } 48: 49: proc rivet_flush {} { 50: if {!$::rivet::header_sent} { 51: set ::rivet::header_sent 1 52: if {![info exists ::rivet::header_redirect]} { 53: tcl_puts "Content-type: $::rivet::header_type" 54: foreach {var val} [array get ::rivet::header_pairs] { 55: tcl_puts "$var: $val" 56: } 57: } else { 58: tcl_puts "Location: $::rivet::header_redirect" 59: tcl_puts "" 60: abort_page 61: } 62: tcl_puts "" 63: } 64: 65: if {!$::rivet::send_no_content} { 66: tcl_puts -nonewline $::rivet::output_buffer 67: } 68: set ::rivet::output_buffer "" 69: } 70: 71: proc rivet_error {} { 72: global errorInfo 73: if {!$::rivet::header_sent} { 74: set ::rivet::header_sent 1 75: tcl_puts "Content-type: text/html" 76: tcl_puts "" 77: } 78: 79: set uidprefix "" 80: catch { 81: package require Tclx 82: set uidprefix "[id userid]-" 83: } 84: 85: set caseid {ERROR} 86: catch { 87: set caseid $uidprefix[clock seconds]-[pid][expr abs([clock clicks])] 88: } 89: 90: if {![info exists ::env(SERVER_ADMIN)]} { 91: set ::env(SERVER_ADMIN) "" 92: } 93: 94: tcl_puts stderr "BEGIN_CASENUMBER=$caseid" 95: tcl_puts stderr "GLOBALS: [info globals]" 96: tcl_puts stderr "***********************" 97: tcl_puts stderr "$errorInfo" 98: tcl_puts stderr "END_CASENUMBER=$caseid" 99: 100: tcl_puts {<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">} 101: tcl_puts {<html><head>} 102: tcl_puts {<title>Application Error</title>} 103: tcl_puts {</head><body>} 104: tcl_puts {<h1>Application Error</h1>} 105: tcl_puts {<p>An error has occured while processing your request.</p>} 106: tcl_puts "<p>This error has been assigned the case number <tt>$caseid</tt>.</p>" 107: tcl_puts "<p>Please reference this case number if you chose to contact the <a href=\"mailto:$::env(SERVER_ADMIN)?subject=case $caseid\">webmaster</a>" 108: tcl_puts {</body></html>} 109: 110: } 111: 112: proc rivet_puts args { 113: if {[lindex $args 0] == "-nonewline"} { 114: set appendchar "" 115: set args [lrange $args 1 end] 116: } else { 117: set appendchar "\n" 118: } 119: 120: if {[llength $args] == 2} { 121: set fd [lindex $args 0] 122: set args [lrange $args 1 end] 123: } else { 124: set fd stdout 125: } 126: 127: if {!$::rivet::header_sent && $fd == "stdout"} { 128: append ::rivet::output_buffer [lindex $args 0]$appendchar 129: 130: if {[string length $::rivet::output_buffer] >= 1024} { 131: rivet_flush 132: } 133: } else { 134: if {$fd == "stdout"} { 135: if {!$::rivet::send_no_content} { 136: tcl_puts -nonewline $fd [lindex $args 0]$appendchar 137: } 138: } else { 139: tcl_puts -nonewline $fd [lindex $args 0]$appendchar 140: } 141: } 142: } 143: 144: rename puts tcl_puts 145: rename rivet_puts puts 146: 147: proc dehexcode {val} { 148: set val [string map [list "+" " "] $val] 149: foreach pt [split $val %] { 150: if {![info exists rval]} { set rval $pt; continue } 151: set char [ctype char 0x[string range $pt 0 1]] 152: append rval "$char[string range $pt 2 end]" 153: } 154: if {![info exists rval]} { set rval "" } 155: return $rval 156: } 157: 158: proc var_qs args { 159: set cmd [lindex $args 0] 160: set var [lindex $args 1] 161: set defval [lindex $args 2] 162: 163: return [_var get $cmd $var $defval] 164: } 165: 166: proc var_post args { 167: set cmd [lindex $args 0] 168: set var [lindex $args 1] 169: set defval [lindex $args 2] 170: 171: return [_var post $cmd $var $defval] 172: } 173: 174: proc var args { 175: set cmd [lindex $args 0] 176: set var [lindex $args 1] 177: set defval [lindex $args 2] 178: 179: return [_var all $cmd $var $defval] 180: } 181: 182: proc _var args { 183: if {![info exists ::rivet::cache_vars]} { 184: global env 185: array set ::rivet::cache_vars {} 186: array set ::rivet::cache_vars_qs {} 187: array set ::rivet::cache_vars_post {} 188: 189: if {[info exists env(QUERY_STRING)]} { 190: set vars_qs $env(QUERY_STRING) 191: } else { 192: set vars_qs "" 193: } 194: 195: set use_post 0 196: if {[info exists env(REQUEST_METHOD)]} { 197: if {$env(REQUEST_METHOD) == "POST"} { 198: set use_post 1 199: } 200: } 201: 202: if {$use_post} { 203: set vars_post [read stdin] 204: } else { 205: set vars_post "" 206: } 207: 208: foreach varpair [split $vars_qs &] { 209: set varpair [split $varpair =] 210: set var [lindex $varpair 0] 211: set value [dehexcode [lindex $varpair 1]] 212: lappend ::rivet::cache_vars_qs($var) $value 213: lappend ::rivet::cache_vars($var) $value 214: } 215: foreach varpair [split $vars_post &] { 216: set varpair [split $varpair =] 217: set var [lindex $varpair 0] 218: set value [dehexcode [lindex $varpair 1]] 219: lappend ::rivet::cache_vars_post($var) $value 220: lappend ::rivet::cache_vars($var) $value 221: } 222: } 223: 224: set type [lindex $args 0] 225: set cmd [lindex $args 1] 226: 227: switch -- $type { 228: "get" { 229: upvar #0 ::rivet::cache_vars_qs cachevar 230: } 231: "post" { 232: upvar #0 ::rivet::cache_vars_post cachevar 233: } 234: default { 235: upvar #0 ::rivet::cache_vars cachevar 236: } 237: } 238: 239: switch -- $cmd { 240: "get" { 241: set var [lindex $args 2] 242: set defval [lindex $args 3] 243: if {[info exists cachevar($var)]} { 244: set retval [join $cachevar($var)] 245: } else { 246: set retval $defval 247: } 248: } 249: "list" { 250: set var [lindex $args 2] 251: if {[info exists cachevar($var)]} { 252: set retval $cachevar($var) 253: } else { 254: set retval [list] 255: } 256: } 257: "number" { 258: set retval [llength [array names cachevar]] 259: } 260: "exists" { 261: set var [lindex $args 2] 262: set retval [info exists cachevar($var)] 263: } 264: "all" { 265: foreach var [array names cachevar] { 266: lappend retval $var [join $cachevar($var)] 267: } 268: } 269: default { 270: return -code error "bad option \"$cmd\": must be get, list, number, exists, or all" 271: } 272: } 273: 274: if {![info exists retval]} { 275: return "" 276: } 277: 278: return $retval 279: } 280: 281: proc parse {file} { 282: return [eval [rivet::parserivet $file]] 283: } 284: 285: proc headers args { 286: set cmd [lindex $args 0] 287: switch -- $cmd { 288: "set" { 289: set var [lindex $args 1] 290: set val [lindex $args 2] 291: set ::rivet::header_pairs($var) $val 292: } 293: "add" { 294: set var [lindex $args 1] 295: set val [lindex $args 2] 296: append ::rivet::header_pairs($var) $val 297: } 298: "type" { 299: set val [lindex $args 1] 300: set ::rivet::header_type $val 301: } 302: "redirect" { 303: set val [lindex $args 1] 304: set ::rivet::header_redirect $val 305: rivet_flush 306: } 307: "numeric" { 308: } 309: default { 310: return -code error "bad option \"$cmd\": must be set, add, type, redirect, or numeric" 311: } 312: } 313: } 314: 315: proc abort_page {} { 316: exit 0 317: } 318: 319: proc no_body {} { 320: set ::rivet::send_no_content 1 321: } 322: 323: proc load_env {{var ::request::env}} { 324: upvar 1 $var envArray 325: 326: array set envArray [array get ::env] 327: } 328: 329: proc env {var} { 330: if {![info exists ::env($var)]} { 331: return "" 332: } 333: 334: return $::env($var) 335: } 336: 337: proc load_headers args { } 338: 339: # Maybe this should go somewhere else ? 340: namespace eval request { 341: proc global args { 342: foreach var $args { 343: namespace eval request "upvar #0 ::request::$var $var" 344: } 345: } 346: } 347: 348: 349: # We need to fill these in, of course. 350: 351: proc makeurl args { return -code error "makeurl not implemented yet"} 352: proc upload args { return -code error "upload not implemented yet" } 353: proc virtual_filename args { return -code error "virtual_filename not implemented yet" } |