Posted to tcl by patthoyts at Mon Jun 09 20:06:47 GMT 2008view raw

  1. proc K {a b} {set a}
  2.  
  3. proc identity {cmd args} {
  4. puts stderr "$cmd"
  5. switch -exact -- $cmd {
  6. initialize { return [list initialize finalize read write] }
  7. finalize { return }
  8. write { return [lindex $args 1] }
  9. read { return [lindex $args 1] }
  10. default { return -code error "method \"$cmd\" not impl" }
  11. }
  12. }
  13.  
  14. proc identity-buffered {cmd args} {
  15. if {$cmd ni {read drain}} { puts stderr "$cmd" }
  16. switch -exact -- $cmd {
  17. initialize {
  18. foreach {handle} $args break
  19. variable $handle {}
  20. return [list initialize finalize read write drain clear]
  21. }
  22. finalize {
  23. foreach {handle} $args break
  24. variable $handle
  25. unset $handle
  26. return
  27. }
  28. write { return [lindex $args 1] }
  29. read {
  30. foreach {handle data} $args break
  31. upvar #0 [namespace which -variable $handle] state
  32. set len [string length $data]
  33. append state $data
  34. set res [string range $state 0 1023]
  35. set state [string range $state 1024 end]
  36. incr ::Count [string length $res]
  37. puts stderr "read data:[string length $data]\
  38. result:[string length $res]\
  39. state:[string length $state]"
  40. return $res
  41. }
  42. drain {
  43. foreach {handle} $args break
  44. upvar #0 [namespace which -variable $handle] state
  45. set res $state
  46. #set state ""
  47. puts stderr "drain ($args) result:[string length $res]\
  48. ::Data:[string length $::Data]\
  49. state:[string length $state]"
  50. #K $state [set state ""]
  51. return $res
  52. }
  53. clear { return }
  54. default { return -code error "method \"$cmd\" not impl" }
  55. }
  56. }
  57.  
  58.  
  59. proc Test {filename {chunk 4096} {transform ::identity-buffered}} {
  60. variable Data ""; variable Count 0
  61. set f [open $filename r]
  62. chan push $f $transform
  63. set Data [read $f]
  64. close $f
  65. puts "orig:[file size $filename] read:[string length $Data] count:$Count"
  66. }
  67.  
  68. if {!$tcl_interactive} {
  69. set r [catch [linsert $argv 0 Test] err]
  70. if {$r} {puts $::errorInfo} elseif {[string length $err]>0} {puts $err}
  71. exit $r
  72. }