3422191 [rkeene@sledge /home/rkeene/projects/tkweb]$ cat -n tkweb-2.tcl
   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 {< &lt; > &gt; \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 {< &lt; > &gt;} [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&nbsp;<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 "&nbsp;"
 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.
3422192 [rkeene@sledge /home/rkeene/projects/tkweb]$

Click here to go back to the directory listing.
Click here to download this file.
last modified: 2006-09-08 00:14:40