1: #!/usr/bin/wishx 2: 3: ## THE CONTENTS OF THIS FILE ARE PUBLIC DOMAIN 4: 5: rename exit tcl_exit 6: set DEBUG 0 7: 8: if {![info exists tk_version]} { 9: 10: 11: proc button args { 12: set name [lindex $args 0] 13: set props [lrange $args 1 end] 14: set ret [tkCreateObject $name button $props] 15: if {$ret=="OK"} { 16: return $name 17: } else { 18: switch -- $ret { 19: "EXISTS" { error "Object \"$name\" already exists" } 20: "INVALPROP" { error "unknown option" } 21: default { error "Could not create button $name" } 22: } 23: } 24: return "" 25: } 26: 27: ################################################################# 28: # proc: tkCreateObject - Create a virtual widget 29: # args: 30: # name Name of the object to create 31: # type Type of object {button text label entry ...} 32: # properties List of properties to set 33: # location Location hints for the geometry manager 34: # rets: 35: # OK Sucess 36: # EXISTS Object exists 37: # INVALOBJ Invalid object type 38: # INVALPROP Invalid property data 39: ################################################################ 40: proc tkCreateObject {name type {properties ""} {location ""}} { 41: global tkObjects tkObjectDefaults 42: 43: set type [string trim [string tolower $type]] 44: 45: if {![array exists tkObjectDefaults]} { 46: if {[info exists tkObjectDefaults]} { unset tkObjectDefaults } 47: set tkObjectDefaults(button) ... 48: set tkObjectDefaults(toplevel) ... 49: } 50: 51: if {![info exists tkObjectDefaults($type)]} { return INVALOBJ } 52: if {[info exists tkObjects($name)]} { return EXISTS } 53: set tkObjects($name) [list $type $properties $location] 54: return OK 55: } 56: 57: 58: proc grid args { 59: } 60: proc place args { error "Only the GRID geometry manager is supported." } 61: proc pack args { error "Only the GRID geometry manager is supported." } 62: 63: proc wm args { 64: global tkObjects wmInfo 65: 66: set cmd [lindex $args 0] 67: set obj [lindex $args 1] 68: set data [join [lrange $args 2 end]] 69: if {![info exists tkObjects($obj)]} { error "bad window path name \"$obj\"" } 70: if {[lindex $tkObjects($obj) 0]!="toplevel"} { error "window \"$obj\" isn't a top-level window" } 71: if {![info exists wmInfo($obj)]} { set wmInfo($obj) "" } 72: switch -- $cmd { 73: "title" { 74: if {$data==""} { 75: return [lindex $wmInfo($obj) 0] 76: } else { 77: set wmInfo($obj) [lreplace $wmInfo($obj) 0 0 $data] 78: } 79: } 80: } 81: } 82: 83: tkCreateObject . toplevel 84: } 85: 86: proc wwwRender_obj_Button {obj} { 87: return "<INPUT TYPE=SUBMIT NAME=\"$obj\" VALUE=\"[$obj cget -text]\">" 88: } 89: 90: proc wwwRender_obj_Label {obj} { 91: return "[$obj cget -text]" 92: } 93: 94: proc wwwRender_obj_Entry {obj} { 95: set var [$obj cget -textvariable] 96: set state [$obj cget -state] 97: global $var 98: if {[info exists $var]} { 99: set val [subst \$$var] 100: set val [string map {< < > > \n <BR>} $val] 101: } else { 102: set val "" 103: } 104: 105: if {$state=="normal"} { 106: return "<INPUT TYPE=TEXT NAME=\"$obj\" VALUE=\"$val\">" 107: } else { 108: return "\[ $val \]" 109: } 110: } 111: 112: proc wwwRender_obj_Text {obj} { 113: set state [$obj cget -state] 114: set val [string map {< < > >} [string range [$obj get 0.0 end] 0 end-1]] 115: 116: if {$state=="normal"} { 117: return "<TEXTAREA NAME=\"$obj\" ROWS=\"[$obj cget -height]\" COLS=\"[$obj cget -width]\">$val</TEXTAREA>" 118: } else { 119: return "\[ $val \]" 120: } 121: } 122: 123: proc wwwRenderPage {} { 124: global env args DEBUG 125: set output "Content-Type: text/html\n\n" 126: 127: 128: if {[info exists env(REQUEST_URI)]} { set URI $env(REQUEST_URI) } 129: if {[info exists env(DOCUMENT_URI)]} { set URI $env(DOCUMENT_URI) } 130: if {[info exists env(SCRIPT_NAME)]} { set URI $env(SCRIPT_NAME) } 131: if {![info exists URI]} { set URI . } 132: append output "<HTML><HEAD><TITLE>[wm title .]</TITLE></HEAD><BODY BGCOLOR=\"#FFFFFF\" FGCOLOR=\"#000000\" LINK=\"#000000\" ALINK=\"#000000\" VLINK=\"#000000\"><FORM ACTION=\"${URI}\" METHOD=GET><INPUT TYPE=HIDDEN NAME=\"TKWebSessionID\" VALUE=\"$args(TKWebSessionID)\">\n" 133: append output "<TABLE BGCOLOR=\"#FFFFFF\" CELLSPACING=10 CELLPADDING=0><TR>\n" 134: set Toplevels "." 135: foreach obj [winfo children .] { 136: if {[winfo class $obj]=="Toplevel"} { 137: lappend Toplevels $obj 138: } 139: } 140: foreach Root $Toplevels { 141: if {[info exists widInfo]} { unset widInfo } 142: if {[info exists gridLayout]} { unset gridLayout } 143: set endx [lindex [grid size $Root] 0] 144: set endy [lindex [grid size $Root] 1] 145: append output "<TD ALIGN=\"CENTER\" VALIGN=\"TOP\"><TABLE BGCOLOR=\"#000000\" CELLSPACING=\"0\" CELLPADDING=\"1\"><TR><TD><TABLE BGCOLOR=\"[. cget -background]\">" 146: set wwwClose [wwwImage images/control.png {[x]} "<INPUT TYPE=IMAGE SRC=\"\$LINK\" VALUE=\"\$alt\" ALT=\"\$alt\" BORDER=0 ALIGN=MIDDLE NAME=\"destroy-$Root\">"] 147: append output "<TR><TH COLSPAN=\"$endx\" BGCOLOR=\"#0a18aa\" VALIGN=\"MIDDLE\" ALIGN=\"LEFT\">$wwwClose <FONT COLOR=\"\#FFFFFF\">[wm title $Root]</FONT></TH></TR>\n" 148: foreach obj [grid slaves $Root] { 149: # if {![winfo ismapped $obj]} { continue } 150: foreach {var val} [grid info $obj] { 151: set widInfo([string range $var 1 end]) $val 152: } 153: set gridLayout($widInfo(column).$widInfo(row)) [list $obj $widInfo(columnspan) $widInfo(rowspan)] 154: 155: if {[info exists widInfo]} { unset widInfo } 156: } 157: for {set y 0} {$y<$endy} {incr y} { 158: append output "<TR ALIGN=CENTER VALIGN=MIDDLE>" 159: for {set x 0} {$x<$endx} {} { 160: set objCSpan 1 161: if {[info exists gridLayout($x.$y)]} { 162: set obj [lindex $gridLayout($x.$y) 0] 163: set objCSpan [lindex $gridLayout($x.$y) 1] 164: append output "<TD COLSPAN=\"$objCSpan\">" 165: append output "[wwwRender_obj_[winfo class $obj] $obj]" 166: } else { 167: append output "<TD>" 168: append output " " 169: } 170: append output "</TD>" 171: incr x $objCSpan 172: } 173: append output "</TR>\n" 174: } 175: append output "</TABLE></TD></TR></TABLE></TD>" 176: } 177: append output "</TR></TABLE></FORM>\n" 178: if {$DEBUG} { 179: append output "<hr width=\"100%\">\n" 180: foreach ent [array names env] { 181: append output "$ent = $env($ent)<br>\n" 182: } 183: } 184: append output "</BODY></HTML>\n" 185: 186: return $output 187: } 188: 189: # Returns <IMG SRC...> for an image if it can be done, otherwise 190: # A blank or alt inserted 191: proc wwwImage {filename {alt ""} {data "<IMG SRC=\"$LINK\" ALT=\"$alt\" BORDER=0>"}} { 192: if {![file exists $filename]} { return $alt } 193: if {![file isfile $filename]} { return $alt } 194: if {[string index $filename 0]!="/"} { set filename "[pwd]/$filename" } 195: set lFilename [file split $filename] 196: set nFilename "" 197: set skip 0 198: for {set i [expr [llength $lFilename]-1]} {$i>0} {incr i -1} { 199: set pt [lindex $lFilename $i] 200: if {$pt==".."} { incr skip; continue } 201: if {$pt=="."} { continue } 202: if {$skip} { incr skip -1; continue } 203: set nFilename "$pt $nFilename" 204: } 205: set nFilename "/[join $nFilename /]" 206: set Cut 0 207: foreach pt1 [file split $nFilename] pt2 [file split [pwd]] { 208: if {$pt2==""} { set NeedCopy 0; break } 209: if {$pt1!=$pt2} { set NeedCopy 1; break } 210: incr Cut 211: } 212: if {$NeedCopy} { 213: set sname [file tail $nFilename] 214: catch { file mkdir images } 215: catch { file copy "$nFilename" "images/$sname" } 216: set LINK "images/$sname" 217: } else { 218: set LINK [join [lrange [file split $nFilename] $Cut end] /] 219: } 220: if {![file exists $LINK]} { return $alt } 221: return [subst $data] 222: } 223: 224: proc wwwProcessArgs {} { 225: global env argv args 226: 227: set Pre "" 228: if {$argv!=""} { 229: append Pre $argv 230: } 231: if {[info exists env(QUERY_STRING)]} { 232: if {$env(QUERY_STRING)!=""} { 233: if {$Pre!=""} { append Pre "&$env(QUERY_STRING)" } else { append Pre "$env(QUERY_STRING)" } 234: } 235: } 236: if {![info exists Pre]} { return "" } 237: set dotxy "" 238: foreach {var val} [split $Pre &=] { 239: if {[string match "*.x" $var]} { 240: lappend dotxy [string range $var 0 end-2] 241: } 242: set args($var) [wwwDehexcode $val] 243: } 244: foreach var $dotxy { 245: if {[info exists args(${var}.x)] && [info exists args(${var}.y)]} { 246: set args(${var}) "$args(${var}.x),$args(${var}.y)" 247: unset args(${var}.x) 248: unset args(${var}.y) 249: } 250: } 251: return "" 252: } 253: 254: proc wwwDehexcode {var} { 255: set oldstart 0 256: foreach startend [regexp -all -indices -inline {%[0-9A-Fa-f][0-9A-Fa-f]} $var] { 257: set start [expr [lindex $startend 0]-1] 258: set end [expr [lindex $startend 1]+1] 259: append output "[string range $var $oldstart $start]" 260: set val "0x[string range $var [expr $start+2] [expr $end-1]]" 261: append output [ctype char $val] 262: set oldstart $end 263: } 264: append output "[string range $var $oldstart end]" 265: regsub -all {\+} $output { } output 266: set output [string map {\r\n \n \n\r \n} $output] 267: return $output 268: } 269: 270: proc tkWWWLoadSession {sess} { 271: global TkWWWSessionLoaded 272: if {[info exists TkWWWSessionLoaded]} { return "" } else { set TkWWWSessionLoaded 1 } 273: if {![regexp {^[0-9A-Za-z]*$} $sess]} { return "" } 274: set TmpSessionFile "/tmp/tkwww_sess${sess}.tmp" 275: set SessionFile "/tmp/tkwww_sess${sess}.tcl" 276: set Count 0 277: while {[file exists $TmpSessionFile]} { 278: sleep 1 279: incr Count 280: if {$Count==10} { 281: file delete $TmpSessionFile 282: } 283: } 284: catch { 285: uplevel #0 "set tkInitProcs [list [info procs]]; source $SessionFile" 286: } err 287: if {$err!=""} { puts stderr "Error=$err" } 288: } 289: 290: proc tkWWWSaveSession {sess} { 291: global tkInitProcs 292: if {![regexp {^[0-9A-Za-z]*$} $sess]} { return "" } 293: set TmpSessionFile "/tmp/tkwww_sess${sess}.tmp" 294: set SessionFile "/tmp/tkwww_sess${sess}.tcl" 295: catch { set fileId [open $TmpSessionFile w] } 296: if {![info exists fileId]} { return "" } 297: 298: # Save variables and variable traces 299: foreach var [info globals] { 300: if {$var=="args" || $var=="env" || $var=="argv" || $var=="argv0" || $var=="argc" || $var=="sourceFile" || $var=="tkPriv" || $var=="errorInfo" || $var=="errorCode" || $var=="tkInitProcs"} { continue } 301: if {[regexp {^(tcl|tk|tkx|auto|tclx)_} $var]} { continue } 302: global $var 303: if {![info exists $var]} { continue } 304: puts $fileId "global [list $var]" 305: catch { 306: if {[array exists $var]} { 307: foreach ent [array names $var] { 308: set val [subst \$$var\($ent\)] 309: puts $fileId "set [list $var\($ent\)] [list $val]" 310: } 311: } else { 312: set val [subst \$$var] 313: puts $fileId "set [list $var] [list $val]" 314: } 315: } 316: foreach tinfo [trace vinfo $var] { 317: set tOp [lindex $tinfo 0] 318: set tCmd [lindex $tinfo 1] 319: puts $fileId "trace variable [list $var] $tOp [list $tCmd]" 320: } 321: } 322: # Save widgets 323: set Toplevels "." 324: foreach obj [winfo children .] { 325: if {[winfo class $obj]=="Toplevel"} { lappend Toplevels $obj } 326: } 327: foreach Root $Toplevels { 328: foreach obj [winfo children $Root] { 329: set cmd [string tolower [winfo class $obj]] 330: set objprop "" 331: foreach prop [$obj configure] { 332: if {[llength $prop]!=5} { continue } 333: set propcmd [lindex $prop 0] 334: set propval [lindex $prop end] 335: if {$propcmd=="-use" || $propcmd=="-colormap"} { continue } 336: append objprop " [list $propcmd] [list $propval]" 337: } 338: puts $fileId "$cmd [list $obj] $objprop" 339: switch -- [winfo class $obj] { 340: "Text" { 341: puts $fileId "[list $obj] insert 0.0 [list [string range [$obj get 0.0 end] 0 end-1]]" 342: } 343: } 344: } 345: foreach obj [grid slaves $Root] { 346: puts $fileId "grid [list $obj] [grid info $obj]" 347: } 348: # Fix window title 349: puts $fileId "wm title $Root [list [wm title $Root]]" 350: } 351: # Save procs 352: foreach proc [info procs] { 353: if {[lsearch -exact $tkInitProcs $proc]!=-1} { continue } 354: puts $fileId "proc [list $proc] [list [info args $proc]] \{[info body $proc]\}" 355: } 356: 357: close $fileId 358: catch { file delete $SessionFile } 359: catch { file rename $TmpSessionFile $SessionFile } 360: } 361: proc exit {{exitval ""}} { 362: global args 363: if {[info exists args(TKWebSessionID)]} { 364: tkWWWEndSession $args(TKWebSessionID) 365: } 366: puts "Content-type: text/html\n" 367: puts "Session ended." 368: tcl_exit 0 369: } 370: proc tkWWWEndSession {sess} { 371: if {![regexp {^[0-9A-Za-z]*$} $sess]} { return "" } 372: set TmpSessionFile "/tmp/tkwww_sess${sess}.tmp" 373: set SessionFile "/tmp/tkwww_sess${sess}.tcl" 374: catch { file delete $TmpSessionFile } 375: catch { file delete $SessionFile } 376: } 377: proc tkWWWSessionExists {sess} { 378: if {![regexp {^[0-9A-Za-z]*$} $sess]} { return 0 } 379: set TmpSessionFile "/tmp/tkwww_sess${sess}.tmp" 380: set SessionFile "/tmp/tkwww_sess${sess}.tcl" 381: if {[file exists $SessionFile] || [file exists $TmpSessionFile]} { 382: return 1 383: } else { 384: return 0 385: } 386: } 387: proc tkWWWProcessChanges {} { 388: global args 389: set Buttons "" 390: foreach var [array names args] { 391: if {[string match "destroy-*" $var]} { 392: set Root [lindex [split $var -] 1] 393: if {$Root=="."} { exit 0 } 394: destroy $Root 395: } 396: if {[string index $var 0]!="."} { continue } 397: set obj $var 398: if {![winfo exists $obj]} { continue } 399: switch -- [winfo class $obj] { 400: "Label" { } 401: "Button" { lappend Buttons $obj } 402: "Entry" { 403: set etv [$obj cget -textvariable] 404: global $etv 405: set textval [subst \$$etv] 406: if {$textval!=$args($var)} { set $etv $args($var) } 407: } 408: "Text" { 409: $obj delete 0.0 end 410: $obj insert 0.0 $args($var) 411: } 412: } 413: } 414: foreach button $Buttons { 415: set cmd [$button cget -command] 416: uplevel #0 "$cmd" 417: } 418: } 419: 420: proc tkWWWMakeSessionId {} { 421: global env 422: 423: 424: foreach ent "HTTP_HOST REMOTE_ADDR SERVER_NAME HTTP_USER_AGENT HTTP_ACCEPT_ENCODING SCRIPT_FILENAME" { 425: if {![info exists env($ent)]} { continue } 426: regsub -all {[^A-Z0-9a-z]} $env($ent) {} nv 427: append sess [string tolower $nv] 428: } 429: if {[info exists sess]} { return $sess } 430: 431: random seed [clock clicks] 432: if {[info exists env(UNIQUE_ID)]} { 433: regsub {[^0-9A-Za-z]} $env(UNIQUE_ID) {} IDN 434: return "${IDN}[random [clock seconds]][expr abs([clock clicks])]" 435: } else { 436: return "[random 13013013][random [clock seconds]][expr abs([clock clicks])]" 437: } 438: } 439: 440: 441: wm title . "Tk/WWW Application" 442: set sourceFile [lindex $argv 0] 443: set argv [join [lrange [split $argv] 2 end]] 444: wwwProcessArgs 445: 446: if {![info exists args(TKWebSessionID)]} { 447: set args(TKWebSessionID) [tkWWWMakeSessionId] 448: if {[tkWWWSessionExists $args(TKWebSessionID)]} { 449: set NewSession 0 450: } else { 451: set NewSession 1 452: } 453: } else { 454: set NewSession 0 455: } 456: 457: if {$NewSession} { 458: set tkInitProcs [info procs] 459: source $sourceFile 460: } else { 461: tkWWWLoadSession $args(TKWebSessionID) 462: tkWWWProcessChanges 463: } 464: 465: 466: 467: set res [wwwRenderPage] 468: if {$res!=""} { 469: puts $res 470: flush stdout 471: unset res 472: tkWWWSaveSession $args(TKWebSessionID) 473: } else { 474: puts "Content-type: text/html\n" 475: puts "error?" 476: } 477: tcl_exit 0 tkweb-2.tcl is an old version of tkweb.tcl. |