Posted to tcl by egavilan at Wed Oct 22 17:37:02 GMT 2008view raw

  1. package require Tk
  2. catch {package require Img}
  3. package require img::jpeg
  4.  
  5. image create photo foo -width 800 -height 600
  6. image create photo bar -width 400 -height 300
  7.  
  8. radiobutton .x1 -text 1X -command SetNormal \
  9. -variable VideoSize -value N
  10. radiobutton .x2 -text 1/2X -command SetSmall \
  11. -variable VideoSize -value S
  12.  
  13. grid .x1 .x2 -sticky news
  14.  
  15. grid [label .l1 -image foo] - -sticky news
  16. grid [label .l2 -image bar] - -sticky news
  17.  
  18. grid remove .l1
  19. set VideoSize S
  20.  
  21. proc SetSmall {} {
  22. grid remove .l1
  23. grid .l2
  24. }
  25.  
  26. proc SetNormal {} {
  27. grid remove .l2
  28. grid .l1
  29. }
  30.  
  31. proc READ {fd} {
  32. global state toread frame
  33.  
  34. if {[eof $fd]} {
  35. puts "stream closed by peer"
  36. close $fd
  37. set state ""
  38. after 9000 start
  39. }
  40.  
  41. switch -- $state {
  42. response {
  43. gets $fd line
  44. puts "RESPONSE: $line"
  45. if {$line ne "HTTP/1.0 200 OK"} {
  46. close $fd
  47. after 10000 start
  48. return
  49. }
  50. set state header
  51. }
  52. header {
  53. gets $fd line
  54. puts "HEADER: $line"
  55. if {$line eq ""} {
  56. set state boundary
  57. }
  58. }
  59. boundary {
  60. gets $fd line
  61. if {$line eq "--myboundary"} {
  62. set state mime
  63. }
  64. }
  65. mime {
  66. gets $fd line
  67. puts "MIME: $line"
  68. regexp {Content-Length: ([[:digit:]]+)} $line -> toread
  69. if {$line eq ""} {
  70. fconfigure $fd -translation binary
  71. set state data
  72. }
  73. }
  74. data {
  75. set n [expr { $toread > 1000 ? 1000 : $toread }]
  76. set data [read $fd $n]
  77. incr toread -[string length $data]
  78. append frame $data
  79. if {$toread == 0} {
  80. foo configure -data $frame
  81. bar copy foo -subsample 2 2
  82. set frame ""
  83. set state boundary
  84. fconfigure $fd -translation crlf
  85. }
  86. }
  87. }
  88. }
  89.  
  90. proc start {} {
  91. puts "opening stream"
  92. global state frame toread
  93. set toread 1000
  94. set state response
  95. set frame ""
  96.  
  97. set fd [socket us.tclers.tk 81]
  98. # set fd [socket us.tclers.tk 80]
  99. fconfigure $fd -buffering full -translation crlf
  100. puts $fd "GET /video.mjpg HTTP/1.0"
  101. puts $fd ""
  102. flush $fd
  103. fileevent $fd readable [list READ $fd]
  104. }
  105.  
  106. bind .l1 <Destroy> exit
  107.  
  108. start
  109. vwait forever