2854340 [rkeene@sledge /home/rkeene/projects/tkweb]$ cat -n tkweb.tcl
   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 {< &lt; > &gt;} $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 {< &lt; > &gt; \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 {< &lt; > &gt;} [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&nbsp;<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 "&nbsp;[wwwRender_Text $obj [wwwRender_obj_[winfo class $obj] $obj] 0]&nbsp;"
 250: 				} else {
 251: 					append output "<TD>"
 252: 					append output "&nbsp;"
 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.
2854341 [rkeene@sledge /home/rkeene/projects/tkweb]$

Click here to go back to the directory listing.
Click here to download this file.
last modified: 2012-08-02 18:16:28