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