Megaimage with Tclhttpd

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
 }

Category Tclhttpd