Posted to tcl by makr at Fri Nov 09 11:55:32 GMT 2007view raw

  1. proc ::uncompress::channelFilter {op ichan args} {
  2. variable cfMap
  3.  
  4. # cfMap keys:
  5. # iposition = amount of data read from underlying input channel
  6. # ichan = the underlying input channel
  7. # header = decoded gzip header
  8. # command = zlib stream command to inflate input
  9. # bsize = buffer size used in zlib stream command
  10. # idata = last chunk of data read from input stream (always at least 8 byte)
  11. # position = amount of data transfered already
  12. # ocrc32 = CRC32 of (so far) inflated data
  13. # eoi = end of input reached?
  14. # buffer = already inflated, but not yet transfered data
  15. # isize = size of original data, only available after eoi
  16. # icrc32 = CRC32 of original data, only available after eoi
  17.  
  18. set result ""
  19.  
  20. if {$op eq "Attach"} {
  21. # not supported by [rechan]
  22. # Create a new stacked channel using this command's provided filter
  23. # functionality and initiallize all data structures.
  24. package require zlib
  25.  
  26. # be sure the input channel is readable!
  27.  
  28. set bsize [lindex $args 0]
  29. # sanitize buffer size
  30. if {![string is integer -strict $bsize]} {
  31. set bsize 4096
  32. } elseif {$bsize < 1024} {
  33. set bsize 1024
  34. } elseif {$bsize > 1048576} {
  35. set bsize 1048576
  36. }
  37.  
  38. fconfigure $ichan -translation binary -buffering full -buffersize $bsize
  39. set header [GzipHeader $ichan pos]
  40. set cmd gunzip[incr cfMap(sequence)]
  41. zlib sinflate $cmd $bsize
  42. set ochan [rechan [namespace code channelFilter] 2]
  43. set cfMap($ochan,iposition) $pos
  44. set cfMap($ochan,ichan) $ichan
  45. set cfMap($ochan,header) $header
  46. set cfMap($ochan,command) $cmd
  47. set cfMap($ochan,bsize) $bsize
  48. set cfMap($ochan,idata) ""
  49. set cfMap($ochan,position) 0
  50. set cfMap($ochan,ocrc32) 0
  51. set cfMap($ochan,eoi) 0
  52. set cfMap($ochan,buffer) ""
  53. set result $ochan
  54.  
  55. } elseif {$op eq "Cget"} {
  56. # not supported by [rechan]
  57. # Return the value of the requested data structure item.
  58. set item [lindex $args 0]
  59. set result $cfMap($ichan,$item)
  60.  
  61. } elseif {$op eq "Cgetall"} {
  62. # not supported by [rechan]
  63. # Return the channel filter's data structure as list suitable for
  64. # [array set].
  65. foreach k [lsort [array names cfMap $ichan,*]] {
  66. lappend result [string map [list $ichan, ""] $k] $cfMap($k)
  67. }
  68.  
  69. } elseif {$op eq "read"} {
  70. # supported by [rechan]
  71. # $count is the channel's configured buffersize
  72. # If the buffer can fulfill the request, get from buffer without
  73. # refilling. Otherwise fill with data from input channel, and drain
  74. # into buffer first.
  75. set count [lindex $args 0]
  76. while {$count > [string length $cfMap($ichan,buffer)]} {
  77. if {([$cfMap($ichan,command) fill] == 0) &&
  78. !$cfMap($ichan,eoi)} {
  79. # always preserve the last 8 byte (gzip footer)
  80. set cfMap($ichan,idata) \
  81. [string range $cfMap($ichan,idata) end-8 end]
  82. set idata [read $cfMap($ichan,ichan) $cfMap($ichan,bsize)]
  83. append cfMap($ichan,idata) $idata
  84. incr cfMap($ichan,iposition) [string length $idata]
  85. if {[eof $cfMap($ichan,ichan)]} {
  86. GzipFooter $cfMap($ichan,idata) \
  87. cfMap($ichan,icrc32) cfMap($ichan,isize)
  88. set cfMap($ichan,eoi) 1
  89. }
  90. $cfMap($ichan,command) fill $idata
  91. }
  92. set odata [$cfMap($ichan,command) drain $cfMap($ichan,bsize)]
  93. if {[string length $odata]} {
  94. set cfMap($ichan,ocrc32) \
  95. [zlib crc32 $odata $cfMap($ichan,ocrc32)]
  96. append cfMap($ichan,buffer) $odata
  97. } else {
  98. break
  99. }
  100. }
  101.  
  102. set result [string range $cfMap($ichan,buffer) 0 [expr {$count - 1}]]
  103. incr cfMap($ichan,position) [string length $result]
  104. set cfMap($ichan,buffer) \
  105. [string range $cfMap($ichan,buffer) $count end]
  106.  
  107. } elseif {$op eq "close"} {
  108. # supported by [rechan]
  109. # delete gunzip command, close input channel,
  110. # and dissolve channel filter information
  111. rename $cfMap($ichan,command) {}
  112. close $cfMap($ichan,ichan)
  113. array unset cfMap $ichan,*
  114.  
  115. } else {
  116. return -code error \
  117. "unknown operation, must be Attach, Cget, Cgetall, read, or close"
  118. }
  119.  
  120. return $result
  121. }
  122.  
  123. proc ::uncompress::GzipHeader {ichan tellvar} {
  124. upvar 1 $tellvar iread
  125.  
  126. array set len {
  127. head 10
  128. fextra 2
  129. fhcrc 2
  130. }
  131. set iread 0
  132.  
  133. set blocked [fconfigure $ichan -blocking]
  134. fconfigure $ichan -blocking 1
  135.  
  136. set head [read $ichan $len(head)]
  137. incr iread $len(head)
  138. binary scan $head H4cb8icc magic cm flg mtime xfl os
  139.  
  140. if {$magic ne "1f8b"} {
  141. return -code error "input is not gzipped"
  142. }
  143.  
  144. if {$cm != 8} {
  145. return -code error "unsupported compression: input is not deflated"
  146. }
  147.  
  148. set result [list head $head magic $magic cm $cm flg $flg mtime $mtime xflg $xfl os $os]
  149.  
  150. # RFC1952: xfl = 2: slowest; xfl = 4: fastest - but unused in the wild
  151. # for table of os, see RFC1952 - uninteressting here
  152.  
  153. foreach {FTEXT FHCRC FEXTRA FNAME FCOMMENT R1 R2 R3} [split $flg ""] {break}
  154.  
  155. # if one of these is set, it may indicate additional extra fields,
  156. # we don't know how to handle
  157. if {$R1 || $R2 || $R3} {
  158. return -code error "unsupported flags: reserved flags are set and may\
  159. indicate an unsupported gzip data format"
  160. }
  161.  
  162. if {$FEXTRA} {
  163. binary scan [read $ichan $len(fextra)] S xlen
  164. incr iread $len(fextra)
  165. set extra [read $ichan $xlen]
  166. incr iread $xlen
  167. # extra now contains some subfields, which may specify additional data,
  168. # see RFC1952 and http://www.gzip.org/format.txt
  169. } else {
  170. set extra ""
  171. }
  172.  
  173. lappend result extra $extra
  174.  
  175. if {$FNAME} {
  176. set c [read $ichan 1]
  177. incr iread
  178. while {$c != "\x0"} {
  179. append name $c
  180. set c [read $ichan 1]
  181. incr iread
  182. }
  183. # the name is stored with iso8859-1 encoding
  184. set name [encoding convertfrom iso8859-1 $name]
  185. } else {
  186. set name ""
  187. }
  188.  
  189. lappend result name $name
  190.  
  191. if {$FCOMMENT} {
  192. set c [read $ichan 1]
  193. incr iread
  194. while {$c != "\x0"} {
  195. append comment $c
  196. set c [read $ichan 1]
  197. incr iread
  198. }
  199. # the comment is stored with iso8859-1 encoding
  200. # [FIXME] do a conversion if this information should be used somewhere
  201. } else {
  202. set comment ""
  203. }
  204.  
  205. lappend result comment $comment
  206.  
  207. if {$FHCRC} {
  208. set crc16 [read $ichan $len(fhcrc)]
  209. incr iread $len(fhcrc)
  210. } else {
  211. set crc16 ""
  212. }
  213.  
  214. lappend result crc16 $crc16 tell $iread
  215.  
  216. fconfigure $ichan -blocking $blocked
  217.  
  218. return $result
  219. }
  220.  
  221. proc ::uncompress::GzipFooter {idata icrc32var isizevar} {
  222. upvar 1 $icrc32var icrc32 $isizevar isize
  223.  
  224. # calculate and read gzip footer
  225. set ifoot [expr {[string length $idata] - 8}]
  226. binary scan $idata x${ifoot}ii icrc32 isize
  227. # This is needed for systems where int is 64bit wide. From binary scan man
  228. # page: Note that the integers returned are signed, but they can be
  229. # converted to unsigned 32-bit quantities using an expression like:
  230. if {[expr {$icrc32 >> 32}] == -1} {
  231. set icrc32 [expr {$icrc32 & 0xffffffff}]
  232. }
  233. return [list crc32 $icrc32 size $isize]
  234. }
  235.  
  236. # here is how to use it ...
  237.  
  238. proc ::uncompress::gunZip {args} {
  239. arguments {
  240. {input -any "" "Name of gzipped file"}
  241. {?output? -string "" "Name of destination file"}
  242. {-progress -string "" "var to store inflation progress into"}
  243. {-buffer -int 65536 "read buffer size"}
  244. }
  245.  
  246. # open and configure input
  247. set ifd [channelFilter gzip Attach [open $input r]]
  248. fconfigure $ifd -translation binary -blocking 1 -buffering full -buffersize $buffer
  249.  
  250. # init progress reporting
  251. if {$progress ne ""} {
  252. set withProgress 1
  253. upvar 1 $progress Progress
  254. set Progress 0
  255. set inlen [file size $input] ;# uncatched
  256. } else {
  257. set withProgress 0
  258. }
  259.  
  260. # sanitize buffer size
  261. if {$buffer < 1024} {
  262. set buffer 1024
  263. } elseif {$buffer > 1048576} {
  264. set buffer 1048576
  265. }
  266.  
  267. array set header [channelFilter gzip Cget $ifd header]
  268. set mtime $header(mtime)
  269. set name $header(name)
  270.  
  271. # generate output filename if necessary
  272. if {($output eq "") && ([set output $name] eq "") &&
  273. ![regsub -- {\.[gG][zZ]$} $input {} output]} {
  274. return -code error "input filename does not end with \"gz\" and there\
  275. was no original name stored in the file"
  276. }
  277.  
  278. # ensure $output is not the same file as $input, fail if so
  279. if {[file exists $output] &&
  280. ([file normalize $input] eq [file normalize $output])} {
  281. return -code error "refusing to overwrite input file"
  282. }
  283.  
  284. set ofd [open $output w]
  285. fconfigure $ofd -translation binary -buffering full
  286.  
  287. if {$withProgress} {
  288. set Progress [expr {100.0 / $inlen * [channelFilter gzip Cget $ifd iposition]}]
  289. }
  290.  
  291. while {![eof $ifd]} {
  292. puts -nonewline $ofd [read $ifd $buffer]
  293. if {$withProgress} {
  294. set Progress [expr {100.0 / $inlen * [channelFilter gzip Cget $ifd iposition]}]
  295. }
  296. }
  297.  
  298. close $ofd
  299.  
  300. set icrc32 [channelFilter gzip Cget $ifd icrc32]
  301. set ocrc32 [channelFilter gzip Cget $ifd ocrc32]
  302. if {$icrc32 != $ocrc32} {
  303. # huh? checksum mismatch
  304. return -code error "CRC32 mismatch on output data"
  305. }
  306. close $ifd
  307.  
  308. if {$mtime} {
  309. file mtime $output $mtime
  310. }
  311.  
  312. if {$withProgress} {
  313. set Progress 100
  314. }
  315. }
  316.  

Comments

Posted by dgroth at Thu Dec 13 14:27:59 GMT 2007 [text] [code]

where is the proc arguments defined ?