Posted to tcl by GPS at Thu Sep 20 08:15:55 GMT 2007view raw

  1. set dir [file dirname [info script]]
  2.  
  3. load [file join $dir megaimage.so]
  4. load [file join $dir megaimagetk.so]
  5. load [file join $dir bserverext.so]
  6.  
  7. set img [megaimage-blank 800 600]
  8. pack [megaimage.frame .f] -fill both -expand 1
  9.  
  10.  
  11. proc redraw img {
  12. global redraw_pending
  13. .f objsetimage $img
  14. set redraw_pending 0
  15. }
  16.  
  17. set redraw_pending 0
  18. proc redraw-when-idle {} {
  19. global redraw_pending
  20. if {$redraw_pending} return
  21. set redraw_pending 1
  22. after idle [list redraw $::img]
  23. }
  24.  
  25. proc read-from {in out} {
  26. global img
  27. read $in 4
  28. if {[eof $in]} {
  29. puts stderr "EOF $in"
  30. exit 1
  31. }
  32. bserver-root-objgetimage $img
  33.  
  34. redraw-when-idle
  35.  
  36. puts -nonewline $out [binary format i1 {2 0 0 0}]
  37. flush $out
  38. }
  39.  
  40. proc main {argc argv} {
  41. set in [open [lindex $argv 0] [list RDONLY NONBLOCK]]
  42. set out [open [lindex $argv 1] w]
  43.  
  44. fconfigure $in -blocking 0
  45. fconfigure $out -blocking 0
  46. puts "$in $out"
  47. fileevent $in readable [list read-from $in $out]
  48.  
  49. bserver-map-root /tmp/Xvfb_screen0
  50.  
  51. vwait forever
  52. }
  53. main $::argc $::argv