Posted to tcl by patthoyts at Wed Jan 14 15:04:15 GMT 2009view raw

  1. # Convert data into HTTP/1.1 chunked transfer-encoding
  2. package require Tcl 8.6
  3.  
  4. proc make-chunk-generator {data {size 4096}} {
  5. variable _chunk_gen_uid
  6. if {![info exists _chunk_gen_uid]} {set _chunk_gen_uid 0}
  7. set lambda {{data size} {
  8. set pos 0
  9. yield
  10. while {1} {
  11. set payload [string range $data $pos [incr pos $size]]
  12. incr pos
  13. set chunk [format %x [string length $payload]]\r\n$payload\r\n
  14. yield $chunk
  15. if {![string length $payload]} {return}
  16. }
  17. }}
  18. set name chunker[incr _chunk_gen_uid]
  19. coroutine $name ::apply $lambda $data $size
  20. return $name
  21. }
  22.  
  23. proc blow-chunks-test {} {
  24. set data "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
  25. set data [string repeat $data 4]
  26. set chunker [make-chunk-generator $data 60]
  27. while {[string length [set chunk [$chunker]]]} {
  28. puts -nonewline $chunk
  29. }
  30. return
  31. }
  32.  
  33. # Read a file and emit it on stdout using chunked transfer-coding.
  34. #
  35. proc blow-chunks {filename {ochan stdout} {compression gzip}} {
  36. set f [open $filename rb]
  37. set data [read $f]
  38. close $f
  39. switch -exact -- $compression {
  40. gzip { set data [zlib gzip $data] }
  41. deflate { set data [zlib deflate $data] }
  42. }
  43.  
  44. set chunker [make-chunk-generator $data 512]
  45. set orig [list \
  46. -translation [chan configure $ochan -translation] \
  47. -encoding [chan configure $ochan -encoding] \
  48. -eofchar [chan configure $ochan -eofchar]]
  49. chan configure $ochan -translation crlf -buffering line
  50. puts $ochan "HTTP/1.1 200 OK"
  51. puts $ochan "content-type: text/plain"
  52. puts $ochan "content-length: [string length $data]"
  53. puts $ochan "content-encoding: $compression"
  54. puts $ochan "transfer-encoding: chunked"
  55. puts $ochan ""
  56. chan configure $ochan -translation binary -buffering full
  57. while {[string length [set chunk [$chunker]]]} {
  58. puts -nonewline $ochan $chunk
  59. }
  60. flush $ochan
  61. puts "flushed [string length $data]"
  62. chan configure $ochan {*}$orig
  63. return
  64. }