Posted to tcl by patthoyts at Tue Jan 19 20:44:50 GMT 2010view raw

  1. # Removed provision of the backward compatible name. Moved to separate
  2. # file/package.
  3. package provide vfs::zip 1.0.3
  4.  
  5. package require vfs
  6.  
  7. # Using the vfs, memchan and Trf extensions, we ought to be able
  8. # to write a Tcl-only zip virtual filesystem. What we have below
  9. # is basically that.
  10.  
  11. namespace eval vfs::zip {}
  12.  
  13. # Used to execute a zip archive. This is rather like a jar file
  14. # but simpler. We simply mount it and then source a toplevel
  15. # file called 'main.tcl'.
  16. proc vfs::zip::Execute {zipfile} {
  17. Mount $zipfile $zipfile
  18. source [file join $zipfile main.tcl]
  19. }
  20.  
  21. proc vfs::zip::Mount {zipfile local args} {
  22. set fd [eval [linsert $args 0 ::zip::open [::file normalize $zipfile]]]
  23. vfs::filesystem mount $local [list ::vfs::zip::handler $fd]
  24. # Register command to unmount
  25. vfs::RegisterMount $local [list ::vfs::zip::Unmount $fd]
  26. return $fd
  27. }
  28.  
  29. proc vfs::zip::Unmount {fd local} {
  30. vfs::filesystem unmount $local
  31. ::zip::_close $fd
  32. }
  33.  
  34. proc vfs::zip::handler {zipfd cmd root relative actualpath args} {
  35. #::vfs::log [list $zipfd $cmd $root $relative $actualpath $args]
  36. if {$cmd == "matchindirectory"} {
  37. eval [list $cmd $zipfd $relative $actualpath] $args
  38. } else {
  39. eval [list $cmd $zipfd $relative] $args
  40. }
  41. }
  42.  
  43. proc vfs::zip::attributes {zipfd} { return [list "state"] }
  44. proc vfs::zip::state {zipfd args} {
  45. vfs::attributeCantConfigure "state" "readonly" $args
  46. }
  47.  
  48. # If we implement the commands below, we will have a perfect
  49. # virtual file system for zip files.
  50.  
  51. proc vfs::zip::matchindirectory {zipfd path actualpath pattern type} {
  52. #::vfs::log [list matchindirectory $path $actualpath $pattern $type]
  53.  
  54. # This call to zip::getdir handles empty patterns properly as asking
  55. # for the existence of a single file $path only
  56. set res [::zip::getdir $zipfd $path $pattern]
  57. #::vfs::log "got $res"
  58. if {![string length $pattern]} {
  59. if {![::zip::exists $zipfd $path]} { return {} }
  60. set res [list $actualpath]
  61. set actualpath ""
  62. }
  63.  
  64. set newres [list]
  65. foreach p [::vfs::matchCorrectTypes $type $res $actualpath] {
  66. lappend newres [file join $actualpath $p]
  67. }
  68. #::vfs::log "got $newres"
  69. return $newres
  70. }
  71.  
  72. proc vfs::zip::stat {zipfd name} {
  73. #::vfs::log "stat $name"
  74. ::zip::stat $zipfd $name sb
  75. #::vfs::log [array get sb]
  76. array get sb
  77. }
  78.  
  79. proc vfs::zip::access {zipfd name mode} {
  80. #::vfs::log "zip-access $name $mode"
  81. if {$mode & 2} {
  82. vfs::filesystem posixerror $::vfs::posix(EROFS)
  83. }
  84. # Readable, Exists and Executable are treated as 'exists'
  85. # Could we get more information from the archive?
  86. if {[::zip::exists $zipfd $name]} {
  87. return 1
  88. } else {
  89. error "No such file"
  90. }
  91.  
  92. }
  93.  
  94. proc vfs::zip::open {zipfd name mode permissions} {
  95. #::vfs::log "open $name $mode $permissions"
  96. # return a list of two elements:
  97. # 1. first element is the Tcl channel name which has been opened
  98. # 2. second element (optional) is a command to evaluate when
  99. # the channel is closed.
  100.  
  101. switch -- $mode {
  102. "" -
  103. "r" {
  104. if {![::zip::exists $zipfd $name]} {
  105. vfs::filesystem posixerror $::vfs::posix(ENOENT)
  106. }
  107.  
  108. ::zip::stat $zipfd $name sb
  109.  
  110. set nfd [vfs::memchan]
  111. fconfigure $nfd -translation binary
  112.  
  113. seek $zipfd $sb(ino) start
  114. set data [zip::Data $zipfd sb 0]
  115.  
  116. puts -nonewline $nfd $data
  117.  
  118. fconfigure $nfd -translation auto
  119. seek $nfd 0
  120. return [list $nfd]
  121. }
  122. default {
  123. vfs::filesystem posixerror $::vfs::posix(EROFS)
  124. }
  125. }
  126. }
  127.  
  128. proc vfs::zip::createdirectory {zipfd name} {
  129. #::vfs::log "createdirectory $name"
  130. vfs::filesystem posixerror $::vfs::posix(EROFS)
  131. }
  132.  
  133. proc vfs::zip::removedirectory {zipfd name recursive} {
  134. #::vfs::log "removedirectory $name"
  135. vfs::filesystem posixerror $::vfs::posix(EROFS)
  136. }
  137.  
  138. proc vfs::zip::deletefile {zipfd name} {
  139. #::vfs::log "deletefile $name"
  140. vfs::filesystem posixerror $::vfs::posix(EROFS)
  141. }
  142.  
  143. proc vfs::zip::fileattributes {zipfd name args} {
  144. #::vfs::log "fileattributes $args"
  145. switch -- [llength $args] {
  146. 0 {
  147. # list strings
  148. return [list]
  149. }
  150. 1 {
  151. # get value
  152. set index [lindex $args 0]
  153. return ""
  154. }
  155. 2 {
  156. # set value
  157. set index [lindex $args 0]
  158. set val [lindex $args 1]
  159. vfs::filesystem posixerror $::vfs::posix(EROFS)
  160. }
  161. }
  162. }
  163.  
  164. proc vfs::zip::utime {fd path actime mtime} {
  165. vfs::filesystem posixerror $::vfs::posix(EROFS)
  166. }
  167.  
  168. # Below copied from TclKit distribution
  169.  
  170. #
  171. # ZIP decoder:
  172. #
  173. # See the ZIP file format specification:
  174. # http://www.pkware.com/documents/casestudies/APPNOTE.TXT
  175. #
  176. # Format of zip file:
  177. # [ Data ]* [ TOC ]* EndOfArchive
  178. #
  179. # Note: TOC is refered to in ZIP doc as "Central Archive"
  180. #
  181. # This means there are two ways of accessing:
  182. #
  183. # 1) from the begining as a stream - until the header
  184. # is not "PK\03\04" - ideal for unzipping.
  185. #
  186. # 2) for table of contents without reading entire
  187. # archive by first fetching EndOfArchive, then
  188. # just loading the TOC
  189. #
  190.  
  191. namespace eval zip {
  192. array set methods {
  193. 0 {stored - The file is stored (no compression)}
  194. 1 {shrunk - The file is Shrunk}
  195. 2 {reduce1 - The file is Reduced with compression factor 1}
  196. 3 {reduce2 - The file is Reduced with compression factor 2}
  197. 4 {reduce3 - The file is Reduced with compression factor 3}
  198. 5 {reduce4 - The file is Reduced with compression factor 4}
  199. 6 {implode - The file is Imploded}
  200. 7 {reserved - Reserved for Tokenizing compression algorithm}
  201. 8 {deflate - The file is Deflated}
  202. 9 {reserved - Reserved for enhanced Deflating}
  203. 10 {pkimplode - PKWARE Date Compression Library Imploding}
  204. 11 {reserved - Reserved by PKWARE}
  205. 12 {bzip2 - The file is compressed using BZIP2 algorithm}
  206. 13 {reserved - Reserved by PKWARE}
  207. 14 {lzma - LZMA (EFS)}
  208. 15 {reserved - Reserved by PKWARE}
  209. }
  210. # Version types (high-order byte)
  211. array set systems {
  212. 0 {dos}
  213. 1 {amiga}
  214. 2 {vms}
  215. 3 {unix}
  216. 4 {vm cms}
  217. 5 {atari}
  218. 6 {os/2}
  219. 7 {macos}
  220. 8 {z system 8}
  221. 9 {cp/m}
  222. 10 {tops20}
  223. 11 {windows}
  224. 12 {qdos}
  225. 13 {riscos}
  226. 14 {vfat}
  227. 15 {mvs}
  228. 16 {beos}
  229. 17 {tandem}
  230. 18 {theos}
  231. }
  232. # DOS File Attrs
  233. array set dosattrs {
  234. 1 {readonly}
  235. 2 {hidden}
  236. 4 {system}
  237. 8 {unknown8}
  238. 16 {directory}
  239. 32 {archive}
  240. 64 {unknown64}
  241. 128 {normal}
  242. }
  243.  
  244. proc u_short {n} { return [expr { ($n+0x10000)%0x10000 }] }
  245. }
  246.  
  247. # zip::DosTime --
  248. #
  249. # Convert a DOS timestamp into unix time_t format
  250. #
  251. proc zip::DosTime {date time} {
  252. set time [u_short $time]
  253. set date [u_short $date]
  254.  
  255. # time = fedcba9876543210
  256. # HHHHHmmmmmmSSSSS (sec/2 actually)
  257.  
  258. # data = fedcba9876543210
  259. # yyyyyyyMMMMddddd
  260.  
  261. set sec [expr { ($time & 0x1F) * 2 }]
  262. set min [expr { ($time >> 5) & 0x3F }]
  263. set hour [expr { ($time >> 11) & 0x1F }]
  264.  
  265. set mday [expr { $date & 0x1F }]
  266. set mon [expr { (($date >> 5) & 0xF) }]
  267. set year [expr { (($date >> 9) & 0xFF) + 1980 }]
  268.  
  269. # Fix up bad date/time data, no need to fail
  270. while {$sec > 59} {incr sec -60}
  271. while {$min > 59} {incr sec -60}
  272. while {$hour > 23} {incr hour -24}
  273. if {$mday < 1} {incr mday}
  274. if {$mon < 1} {incr mon}
  275. while {$mon > 12} {incr hour -12}
  276.  
  277. while {[catch {
  278. set dt [format {%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d} \
  279. $year $mon $mday $hour $min $sec]
  280. set res [clock scan $dt -gmt 1]
  281. }]} {
  282. # Only mday can be wrong, at end of month
  283. incr mday -1
  284. }
  285. return $res
  286. }
  287.  
  288.  
  289. proc zip::Data {fd arr verify} {
  290. upvar 1 $arr sb
  291.  
  292. # APPNOTE A: Local file header
  293. set buf [read $fd 30]
  294. set n [binary scan $buf A4sssssiiiss \
  295. hdr sb(ver) sb(flags) sb(method) time date \
  296. crc csize size namelen xtralen]
  297.  
  298. if { ![string equal "PK\03\04" $hdr] } {
  299. binary scan $hdr H* x
  300. return -code error "bad header: $x"
  301. }
  302. set sb(ver) [expr {$sb(ver) & 0xffff}]
  303. set sb(flags) [expr {$sb(flags) & 0xffff}]
  304. set sb(method) [expr {$sb(method) & 0xffff}]
  305. set sb(mtime) [DosTime $date $time]
  306. if {!($sb(flags) & (1<<3))} {
  307. set sb(crc) [expr {$crc & 0xffffffff}]
  308. set sb(csize) [expr {$csize & 0xffffffff}]
  309. set sb(size) [expr {$size & 0xffffffff}]
  310. }
  311.  
  312. set sb(name) [read $fd [expr {$namelen & 0xffff}]]
  313. set sb(extra) [read $fd [expr {$xtralen & 0xffff}]]
  314. if {$sb(flags) & (1 << 11)} {
  315. set sb(name) [encoding convertfrom utf-8 $sb(name)]
  316. }
  317. set sb(name) [string trimleft $sb(name) "./"]
  318.  
  319. # APPNOTE B: File data
  320. # if bit 3 of flags is set the csize comes from the central directory
  321. set data [read $fd $sb(csize)]
  322.  
  323. # APPNOTE C: Data descriptor
  324. if { $sb(flags) & (1<<3) } {
  325. binary scan [read $fd 4] i ddhdr
  326. if {($ddhdr & 0xffffffff) == 0x08074b50} {
  327. binary scan [read $fd 12] iii sb(crc) sb(csize) sb(size)
  328. } else {
  329. set sb(crc) $ddhdr
  330. binary scan [read $fd 8] ii sb(csize) sb(size)
  331. }
  332. set sb(crc) [expr {$sb(crc) & 0xffffffff}]
  333. set sb(csize) [expr {$sb(csize) & 0xffffffff}]
  334. set sb(size) [expr {$sb(size) & 0xffffffff}]
  335. }
  336.  
  337. switch -exact -- $sb(method) {
  338. 0 {
  339. # stored; no compression
  340. }
  341. 8 {
  342. # deflated
  343. if {[catch {
  344. set data [vfs::zip -mode decompress -nowrap 1 $data]
  345. } err]} then {
  346. return -code error "error inflating \"$sb(name)\": $err"
  347. }
  348. }
  349. default {
  350. set method $sb(method)
  351. if {[info exists methods($method)]} {
  352. set method $methods($method)
  353. }
  354. return -code error "unsupported compression method
  355. \"$method\" used for \"$sb(name)\""
  356. }
  357. }
  358.  
  359. if { $verify && $sb(method) != 0} {
  360. set ncrc [vfs::crc $data]
  361. if { ($ncrc & 0xffffffff) != $sb(crc) } {
  362. vfs::log [format {%s: crc mismatch: expected 0x%x, got 0x%x} \
  363. $sb(name) $sb(crc) $ncrc]
  364. }
  365. }
  366. return $data
  367. }
  368.  
  369. proc zip::EndOfArchive {fd arr} {
  370. upvar 1 $arr cb
  371.  
  372. # [SF Tclvfs Bug 1003574]. Do not seek over beginning of file.
  373. seek $fd 0 end
  374.  
  375. # Just looking in the last 512 bytes may be enough to handle zip
  376. # archives without comments, however for archives which have
  377. # comments the chunk may start at an arbitrary distance from the
  378. # end of the file. So if we do not find the header immediately
  379. # we have to extend the range of our search, possibly until we
  380. # have a large part of the archive in memory. We can fail only
  381. # after the whole file has been searched.
  382.  
  383. set sz [tell $fd]
  384. set len 512
  385. set at 512
  386. while {1} {
  387. if {$sz < $at} {set n -$sz} else {set n -$at}
  388.  
  389. seek $fd $n end
  390. set hdr [read $fd $len]
  391.  
  392. # We are using 'string last' as we are searching the first
  393. # from the end, which is the last from the beginning. See [SF
  394. # Bug 2256740]. A zip archive stored in a zip archive can
  395. # confuse the unmodified code, triggering on the magic
  396. # sequence for the inner, uncompressed archive.
  397. set pos [string last "PK\05\06" $hdr]
  398. if {$pos == -1} {
  399. if {$at >= $sz} {
  400. return -code error "no header found"
  401. }
  402. set len 540 ; # after 1st iteration we force overlap with last buffer
  403. incr at 512 ; # to ensure that the pattern we look for is not split at
  404. # ; # a buffer boundary, nor the header itself
  405. } else {
  406. break
  407. }
  408. }
  409.  
  410. set hdr [string range $hdr [expr {$pos + 4}] [expr {$pos + 21}]]
  411. set pos [expr {[tell $fd] + $pos - 512}]
  412.  
  413. binary scan $hdr ssssiis \
  414. cb(ndisk) cb(cdisk) \
  415. cb(nitems) cb(ntotal) \
  416. cb(csize) cb(coff) \
  417. cb(comment)
  418.  
  419. set cb(ndisk) [u_short $cb(ndisk)]
  420. set cb(nitems) [u_short $cb(nitems)]
  421. set cb(ntotal) [u_short $cb(ntotal)]
  422. set cb(comment) [u_short $cb(comment)]
  423.  
  424. # Compute base for situations where ZIP file
  425. # has been appended to another media (e.g. EXE)
  426. set cb(base) [expr { $pos - $cb(csize) - $cb(coff) }]
  427. }
  428.  
  429. proc zip::TOC {fd arr} {
  430. upvar 1 $arr sb
  431.  
  432. set buf [read $fd 46]
  433.  
  434. binary scan $buf A4ssssssiiisssssii hdr \
  435. sb(vem) sb(ver) sb(flags) sb(method) time date \
  436. sb(crc) sb(csize) sb(size) \
  437. flen elen clen sb(disk) sb(attr) \
  438. sb(atx) sb(ino)
  439.  
  440. if { ![string equal "PK\01\02" $hdr] } {
  441. binary scan $hdr H* x
  442. return -code error "bad central header: $x"
  443. }
  444.  
  445. foreach v {vem ver flags method disk attr} {
  446. set sb($v) [expr {$sb($v) & 0xffff}]
  447. }
  448. set sb(crc) [expr {$sb(crc) & 0xffffffff}]
  449. set sb(csize) [expr {$sb(csize) & 0xffffffff}]
  450. set sb(size) [expr {$sb(size) & 0xffffffff}]
  451. set sb(mtime) [DosTime $date $time]
  452. set sb(mode) [expr { ($sb(atx) >> 16) & 0xffff }]
  453. if { ( $sb(atx) & 0xff ) & 16 } {
  454. set sb(type) directory
  455. } else {
  456. set sb(type) file
  457. }
  458. set sb(name) [read $fd [u_short $flen]]
  459. set sb(extra) [read $fd [u_short $elen]]
  460. set sb(comment) [read $fd [u_short $clen]]
  461. if {$sb(flags) & (1 << 11)} {
  462. set sb(name) [encoding convertfrom utf-8 $sb(name)]
  463. set sb(comment) [encoding convertfrom utf-8 $sb(comment)]
  464. }
  465. set sb(name) [string trimleft $sb(name) "./"]
  466. }
  467.  
  468. proc zip::open {path args} {
  469. vfs::log [list zip::open $path $args]
  470. set mode "r"
  471. #if {[package vsatisfies [package provide Tcl] 8.6]} { set mode "r+" }
  472.  
  473. while {[string match -* [set option [lindex $args 0]]]} {
  474. switch -exact -- $option {
  475. -readonly { set mode "r" }
  476. default {
  477. return -code error "invalid option \"$option\": must be -readonly"
  478. }
  479. }
  480. Pop args
  481. }
  482.  
  483. set fd [::open $path $mode]
  484.  
  485. if {[catch {
  486. upvar #0 zip::$fd cb
  487. upvar #0 zip::$fd.toc toc
  488.  
  489. fconfigure $fd -translation binary ;#-buffering none
  490.  
  491. zip::EndOfArchive $fd cb
  492.  
  493. seek $fd $cb(coff) start
  494.  
  495. set toc(_) 0; unset toc(_); #MakeArray
  496.  
  497. for {set i 0} {$i < $cb(nitems)} {incr i} {
  498. zip::TOC $fd sb
  499.  
  500. set sb(depth) [llength [file split $sb(name)]]
  501.  
  502. set name [string tolower $sb(name)]
  503. set toc($name) [array get sb]
  504. FAKEDIR toc [file dirname $name]
  505. }
  506. } err]} {
  507. close $fd
  508. return -code error $err
  509. }
  510.  
  511. return $fd
  512. }
  513.  
  514. proc zip::FAKEDIR {arr path} {
  515. upvar 1 $arr toc
  516.  
  517. if { $path == "."} { return }
  518.  
  519.  
  520. if { ![info exists toc($path)] } {
  521. # Implicit directory
  522. lappend toc($path) \
  523. name $path \
  524. type directory mtime 0 size 0 mode 0777 \
  525. ino -1 depth [llength [file split $path]]
  526. }
  527. FAKEDIR toc [file dirname $path]
  528. }
  529.  
  530. proc zip::exists {fd path} {
  531. #::vfs::log "$fd $path"
  532. if {$path == ""} {
  533. return 1
  534. } else {
  535. upvar #0 zip::$fd.toc toc
  536. info exists toc([string tolower $path])
  537. }
  538. }
  539.  
  540. proc zip::stat {fd path arr} {
  541. upvar #0 zip::$fd.toc toc
  542. upvar 1 $arr sb
  543. #vfs::log [list stat $fd $path $arr [info level -1]]
  544.  
  545. set name [string tolower $path]
  546. if { $name == "" || $name == "." } {
  547. array set sb {
  548. type directory mtime 0 size 0 mode 0777
  549. ino -1 depth 0 name ""
  550. }
  551. } elseif {![info exists toc($name)] } {
  552. return -code error "could not read \"$path\": no such file or directory"
  553. } else {
  554. array set sb $toc($name)
  555. }
  556. set sb(dev) -1
  557. set sb(uid) -1
  558. set sb(gid) -1
  559. set sb(nlink) 1
  560. set sb(atime) $sb(mtime)
  561. set sb(ctime) $sb(mtime)
  562. return ""
  563. }
  564.  
  565. # Treats empty pattern as asking for a particular file only
  566. proc zip::getdir {fd path {pat *}} {
  567. #::vfs::log [list getdir $fd $path $pat]
  568. upvar #0 zip::$fd.toc toc
  569.  
  570. if { $path == "." || $path == "" } {
  571. set path [set tmp [string tolower $pat]]
  572. } else {
  573. set globmap [list "\[" "\\\[" "*" "\\*" "?" "\\?"]
  574. set tmp [string tolower $path]
  575. set path [string map $globmap $tmp]
  576. if {$pat != ""} {
  577. append tmp /[string tolower $pat]
  578. append path /[string tolower $pat]
  579. }
  580. }
  581. # file split can be confused by the glob quoting so split tmp string
  582. set depth [llength [file split $tmp]]
  583.  
  584. #vfs::log "getdir $fd $path $depth $pat [array names toc $path]"
  585. if {$depth} {
  586. set ret {}
  587. foreach key [array names toc $path] {
  588. if {[string index $key end] == "/"} {
  589. # Directories are listed twice: both with and without
  590. # the trailing '/', so we ignore the one with
  591. continue
  592. }
  593. array set sb $toc($key)
  594.  
  595. if { $sb(depth) == $depth } {
  596. if {[info exists toc(${key}/)]} {
  597. array set sb $toc(${key}/)
  598. }
  599. lappend ret [file tail $sb(name)]
  600. } else {
  601. #::vfs::log "$sb(depth) vs $depth for $sb(name)"
  602. }
  603. unset sb
  604. }
  605. return $ret
  606. } else {
  607. # just the 'root' of the zip archive. This obviously exists and
  608. # is a directory.
  609. return [list {}]
  610. }
  611. }
  612.  
  613. proc zip::_close {fd} {
  614. variable $fd
  615. variable $fd.toc
  616. unset $fd
  617. unset $fd.toc
  618. ::close $fd
  619. }
  620.  
  621. # zip::timet_to_dos --
  622. #
  623. # Convert a unix timestamp into a DOS timestamp for ZIP times.
  624. #
  625. # DOS timestamps are 32 bits split into bit regions as follows:
  626. # 24 16 8 0
  627. # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+
  628. # |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s|
  629. # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+
  630. #
  631. proc zip::timet_to_dos {time_t} {
  632. set s [clock format $time_t -format {%Y %m %e %k %M %S}]
  633. scan $s {%d %d %d %d %d %d} year month day hour min sec
  634. expr {(($year-1980) << 25) | ($month << 21) | ($day << 16)
  635. | ($hour << 11) | ($min << 5) | ($sec >> 1)}
  636. }
  637.  
  638. # zip::pop --
  639. #
  640. # Pop an element from a list
  641. #
  642. proc zip::pop {varname {nth 0}} {
  643. upvar $varname args
  644. set r [lindex $args $nth]
  645. set args [lreplace $args $nth $nth]
  646. return $r
  647. }
  648.  
  649. # zip::walk --
  650. #
  651. # Walk a directory tree rooted at 'path'. The excludes list can be
  652. # a set of glob expressions to match against files and to avoid.
  653. # The match arg is internal.
  654. # eg: walk library {CVS/* *~ .#*} to exclude CVS and emacs cruft.
  655. #
  656. proc zip::walk {base {excludes ""} {match *} {path {}}} {
  657. set result {}
  658. set imatch [file join $path $match]
  659. set files [glob -nocomplain -tails -types f -directory $base $imatch]
  660. foreach file $files {
  661. set excluded 0
  662. foreach glob $excludes {
  663. if {[string match $glob $file]} {
  664. set excluded 1
  665. break
  666. }
  667. }
  668. if {!$excluded} {lappend result $file}
  669. }
  670. foreach dir [glob -nocomplain -tails -types d -directory $base $imatch] {
  671. set subdir [walk $base $excludes $match $dir]
  672. if {[llength $subdir]>0} {
  673. set result [concat $result $dir $subdir]
  674. }
  675. }
  676. return $result
  677. }
  678.  
  679. # zip::mkzipfile --
  680. #
  681. # Add a single file to a zip archive. The zipchan channel should
  682. # already be open and binary. You may provide a comment for the
  683. # file The return value is the central directory record that
  684. # will need to be used when finalizing the zip archive.
  685. #
  686. # FIX ME: should handle the current offset for non-seekable channels
  687. #
  688. proc zip::mkzipfile {zipchan base path {comment ""}} {
  689. set fullpath [file join $base $path]
  690. set mtime [timet_to_dos [file mtime $fullpath]]
  691. set utfpath [encoding convertto utf-8 $path]
  692. set utfcomment [encoding convertto utf-8 $comment]
  693. set flags [expr {(1<<11)}] ;# utf-8 comment and path
  694. set method 0 ;# store 0, deflate 8
  695. set attr 0 ;# text or binary (default binary)
  696. set version 20 ;# minumum version req'd to extract
  697. set extra ""
  698. set crc 0
  699. set size 0
  700. set csize 0
  701. set data ""
  702. set seekable [expr {[tell $zipchan] != -1}]
  703. if {[file isdirectory $fullpath]} {
  704. set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx)
  705. } elseif {[file executable $fullpath]} {
  706. set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx)
  707. } else {
  708. set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-)
  709. if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} {
  710. set attr 1 ;# text
  711. }
  712. }
  713.  
  714. if {[file isfile $fullpath]} {
  715. set size [file size $fullpath]
  716. if {!$seekable} {set flags [expr {$flags | (1 << 3)}]}
  717. }
  718.  
  719. set offset [tell $zipchan]
  720. set local [binary format a4sssiiiiss PK\03\04 \
  721. $version $flags $method $mtime $crc $csize $size \
  722. [string length $utfpath] [string length $extra]]
  723. append local $utfpath $extra
  724. puts -nonewline $zipchan $local
  725.  
  726. if {[file isfile $fullpath]} {
  727. # If the file is under 2MB then zip in one chunk, otherwize we use
  728. # streaming to avoid requiring excess memory. This helps to prevent
  729. # storing re-compressed data that may be larger than the source when
  730. # handling PNG or JPEG or nested ZIP files.
  731. if {$size < 0x00200000} {
  732. set fin [open $fullpath rb]
  733. set data [read $fin]
  734. set crc [zlib crc32 $data]
  735. set cdata [zlib deflate $data]
  736. if {[string length $cdata] < $size} {
  737. set method 8
  738. set data $cdata
  739. }
  740. close $fin
  741. set csize [string length $data]
  742. puts -nonewline $zipchan $data
  743. } else {
  744. set method 8
  745. set fin [open $fullpath rb]
  746. set zlib [zlib stream deflate]
  747. while {![eof $fin]} {
  748. set data [read $fin 4096]
  749. set crc [zlib crc32 $data $crc]
  750. $zlib put $data
  751. if {[string length [set zdata [$zlib get]]]} {
  752. incr csize [string length $zdata]
  753. puts -nonewline $zipchan $zdata
  754. }
  755. }
  756. close $fin
  757. $zlib finalize
  758. set zdata [$zlib get]
  759. incr csize [string length $zdata]
  760. puts -nonewline $zipchan $zdata
  761. $zlib close
  762. }
  763.  
  764. if {$seekable} {
  765. # update the header if the output is seekable
  766. set local [binary format a4sssiiii PK\03\04 \
  767. $version $flags $method $mtime $crc $csize $size]
  768. set current [tell $zipchan]
  769. seek $zipchan $offset
  770. puts -nonewline $zipchan $local
  771. seek $zipchan $current
  772. } else {
  773. # Write a data descriptor record
  774. set ddesc [binary format a4iii PK\7\8 $crc $csize $size]
  775. puts -nonewline $zipchan $ddesc
  776. }
  777. }
  778.  
  779. set hdr [binary format a4ssssiiiisssssii PK\01\02 0x0317 \
  780. $version $flags $method $mtime $crc $csize $size \
  781. [string length $utfpath] [string length $extra]\
  782. [string length $utfcomment] 0 $attr $attrex $offset]
  783. append hdr $utfpath $extra $utfcomment
  784. return $hdr
  785. }
  786.  
  787. # zip::mkzip --
  788. #
  789. # Create a zip archive in 'filename'. If a file already exists it will be
  790. # overwritten by a new file. If '-directory' is used, the new zip archive
  791. # will be rooted in the provided directory.
  792. # -runtime can be used to specify a prefix file. For instance,
  793. # zip myzip -runtime unzipsfx.exe -directory subdir
  794. # will create a self-extracting zip archive from the subdir/ folder.
  795. # The -comment parameter specifies an optional comment for the archive.
  796. #
  797. # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt
  798. #
  799. proc zip::mkzip {filename args} {
  800. array set opts {
  801. -zipkit 0 -runtime "" -comment "" -directory ""
  802. -exclude {CVS/* */CVS/* *~ ".#*" "*/.#*"}
  803. }
  804.  
  805. while {[string match -* [set option [lindex $args 0]]]} {
  806. switch -exact -- $option {
  807. -zipkit { set opts(-zipkit) 1 }
  808. -comment { set opts(-comment) [encoding convertto utf-8 [pop args 1]] }
  809. -runtime { set opts(-runtime) [pop args 1] }
  810. -directory {set opts(-directory) [file normalize [pop args 1]] }
  811. -exclude {set opts(-exclude) [pop args 1] }
  812. -- { pop args ; break }
  813. default {
  814. break
  815. }
  816. }
  817. pop args
  818. }
  819.  
  820. set zf [open $filename wb]
  821. if {$opts(-runtime) ne ""} {
  822. set rt [open $opts(-runtime) rb]
  823. fcopy $rt $zf
  824. close $rt
  825. } elseif {$opts(-zipkit)} {
  826. set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n"
  827. append zkd "package require vfs::zip\n"
  828. append zkd "vfs::zip::Mount \[info script\] \[info script\]\n"
  829. append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n"
  830. append zkd " source \[file join \[info script\] main.tcl\]\n"
  831. append zkd "}\n"
  832. append zkd \x1A
  833. puts -nonewline $zf $zkd
  834. }
  835.  
  836. set count 0
  837. set cd ""
  838.  
  839. if {$opts(-directory) ne ""} {
  840. set paths [walk $opts(-directory) $opts(-exclude)]
  841. } else {
  842. set paths [glob -nocomplain {*}$args]
  843. }
  844. foreach path $paths {
  845. puts $path
  846. append cd [mkzipfile $zf $opts(-directory) $path]
  847. incr count
  848. }
  849. set cdoffset [tell $zf]
  850. set endrec [binary format a4ssssiis PK\05\06 0 0 \
  851. $count $count [string length $cd] $cdoffset\
  852. [string length $opts(-comment)]]
  853. append endrec $opts(-comment)
  854. puts -nonewline $zf $cd
  855. puts -nonewline $zf $endrec
  856. close $zf
  857.  
  858. return
  859. }