George Peter Staplin 07.28.2006 - I wanted to display a changing PNG image over a web interface to several clients at once. At first I did this with CGI and Apache, but the performance was terrible. Then I talked with Colin McCormack about the problem and came to the following solution with a Direct_Url/Direct Domain.
To use this code you will first need to save it as megaimage.tcl in the lib directory of tclhttpd. Then in tclhttpd/bin/httpdthread.tcl add some code to source the megaimage.tcl (possibly via a package require).
For example:
source or package require httpd::megaimage Megaimage_Url /megaimage
Then you can start tclhttpd like so:
tclkit8.5 /path/to/tclhttpd/bin/httpd.tcl -port 8000
Now in your web browser load:
http://localhost:8000/megaimage/data
package provide httpd::megaimage 1.0
package require httpd
package provide httpd::megaimage 1.0
package require httpd::direct
package require httpd::redirect
set dir [file dirname [info script]]
load [file join $dir megaimage.so]
load [file join $dir pngext2.so] Pngext2
set megaimage(dir) $dir
proc Megaimage_blue {} {
global megaimage
set obj $megaimage(baseobj)
set newrow [list]
if {$megaimage(incr) > 0} {
foreach {r g b a} [$obj getrow $megaimage(y)] {
lappend newrow $r $g 255 255
}
} else {
foreach {r g b a} [$obj getrow $megaimage(y)] {
lappend newrow $r $g $b 100
}
}
$obj putrow $megaimage(y) $newrow
incr megaimage(y) $megaimage(incr)
if {$megaimage(y) >= $megaimage(height)} {
set megaimage(y) [expr {$megaimage(height) - 5}]
set megaimage(incr) -5
} elseif {$megaimage(y) <= 0} {
set megaimage(y) 0
set megaimage(incr) 5
}
after 1000 [list Megaimage_blue]
}
proc Megaimage_Url dir {
global megaimage
set png [pngext2:decode file [file join $megaimage(dir) Duck.png]]
set megaimage(baseobj) [create.megaimageobj $png]
set megaimage(y) 0
set megaimage(incr) 5
foreach {megaimage(width) megaimage(height)} [$megaimage(baseobj) getsize] break
Direct_Url $dir Megaimage
Megaimage_blue
}
set Megaimage/data image/png
proc Megaimage/data {{time 2} args} {
global megaimage
Httpd_NoCache [Httpd_CurrentSocket]
if {[string is integer -strict $time] && $time > 0} {
Httpd_Refresh [Httpd_CurrentSocket] $time /megaimage/data
}
pngext2:encode [$megaimage(baseobj) getdata]
}
proc Megaimage/ args {
Httpd_NoCache [Httpd_CurrentSocket]
return {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
<html>
<head>
<title>Megaimage Power</title>
</head>
<body>
This is a duck from Wikimedia.org:<br>
<img src="/megaimage/data">
</body>
</html>
}
}
proc Megaimage args {
eval Megaimage/ $args
}