Diff

Differences From Artifact [4a9165155e]:

To Artifact [734aa55ae1]:


     1      1   # Removed provision of the backward compatible name. Moved to separate
     2      2   # file/package.
     3         -package provide vfs::zip 1.0.1
     4      3   
     5      4   package require vfs
     6      5   
     7      6   # Using the vfs, memchan and Trf extensions, we ought to be able
     8      7   # to write a Tcl-only zip virtual filesystem.  What we have below
     9      8   # is basically that.
    10      9   
................................................................................
   233    232   	128	{normal}
   234    233       }
   235    234   
   236    235       proc u_short {n}  { return [expr { ($n+0x10000)%0x10000 }] }
   237    236   }
   238    237   
   239    238   proc zip::DosTime {date time} {
          239  +    # The pre-VFS environment will not have access to "clock", so don't even
          240  +    # bother
          241  +    return 0
          242  +
   240    243       set time [u_short $time]
   241    244       set date [u_short $date]
   242    245   
   243    246       # time = fedcba9876543210
   244    247       #        HHHHHmmmmmmSSSSS (sec/2 actually)
   245    248   
   246    249       # data = fedcba9876543210
................................................................................
   251    254       set hour [expr { ($time >> 11) & 0x1F }]
   252    255   
   253    256       set mday [expr { $date & 0x1F }]
   254    257       set mon  [expr { (($date >> 5) & 0xF) }]
   255    258       set year [expr { (($date >> 9) & 0xFF) + 1980 }]
   256    259   
   257    260       # Fix up bad date/time data, no need to fail
   258         -    while {$sec  > 59} {incr sec  -60}
   259         -    while {$min  > 59} {incr sec  -60}
   260         -    while {$hour > 23} {incr hour -24}
   261         -    if {$mday < 1}  {incr mday}
   262         -    if {$mon  < 1}  {incr mon}
   263         -    while {$mon > 12} {incr hour -12}
          261  +    if {$sec  > 59} {set sec  59}
          262  +    if {$min  > 59} {set sec  59}
          263  +    if {$hour > 23} {set hour 23}
          264  +    if {$mday < 1}  {set mday 1}
          265  +    if {$mday > 35} {set mday 35}
          266  +    if {$mon  < 1}  {set mon  1}
          267  +    if {$mon > 12}  {set mon  12}
   264    268   
   265         -    while {[catch {
          269  +    set res 0
          270  +    while {$mday > 1 && [catch {
   266    271   	set dt [format {%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d} \
   267    272   		    $year $mon $mday $hour $min $sec]
   268    273   	set res [clock scan $dt -gmt 1]
   269    274       }]} {
   270    275   	# Only mday can be wrong, at end of month
   271    276   	incr mday -1
   272    277       }
          278  +
   273    279       return $res
   274    280   }
   275    281   
   276    282   
   277    283   proc zip::Data {fd arr {varPtr ""} {verify 0}} {
   278    284       upvar 1 $arr sb
   279    285   
................................................................................
   396    402   
   397    403       # Compute base for situations where ZIP file
   398    404       # has been appended to another media (e.g. EXE)
   399    405       set cb(base)	[expr { $pos - $cb(csize) - $cb(coff) }]
   400    406   }
   401    407   
   402    408   proc zip::TOC {fd arr} {
          409  +    upvar #0 zip::$fd cb
   403    410       upvar 1 $arr sb
   404    411   
   405    412       set buf [read $fd 46]
   406    413   
   407    414       binary scan $buf A4ssssssiiisssssii hdr \
   408    415         sb(vem) sb(ver) sb(flags) sb(method) time date \
   409    416         sb(crc) sb(csize) sb(size) \
   410    417         flen elen clen sb(disk) sb(attr) \
   411    418         sb(atx) sb(ino)
          419  +
          420  +    set sb(ino) [expr {$cb(base) + $sb(ino)}]
   412    421   
   413    422       if { ![string equal "PK\01\02" $hdr] } {
   414    423   	binary scan $hdr H* x
   415    424   	error "bad central header: $x"
   416    425       }
   417    426   
   418    427       foreach v {vem ver flags method disk attr} {
................................................................................
   438    447   	upvar #0 zip::$fd cb
   439    448   	upvar #0 zip::$fd.toc toc
   440    449   
   441    450   	fconfigure $fd -translation binary ;#-buffering none
   442    451   	
   443    452   	zip::EndOfArchive $fd cb
   444    453   
   445         -	seek $fd $cb(coff) start
          454  +	seek $fd [expr {$cb(base) + $cb(coff)}] start
   446    455   
   447    456   	set toc(_) 0; unset toc(_); #MakeArray
   448    457   	
   449    458   	for { set i 0 } { $i < $cb(nitems) } { incr i } {
   450    459   	    zip::TOC $fd sb
   451    460   	    
   452    461   	    set sb(depth) [llength [file split $sb(name)]]
................................................................................
   560    569   proc zip::_close {fd} {
   561    570       variable $fd
   562    571       variable $fd.toc
   563    572       unset $fd
   564    573       unset $fd.toc
   565    574       ::close $fd
   566    575   }
          576  +
          577  +# use zlib to define zip and crc if available
          578  +if {[llength [info command vfs::zip]] == 0 && [llength [info command zlib]] || ![catch {load "" zlib}]} {
          579  +	proc vfs::zip {flag value args} {
          580  +		switch -glob -- "$flag $value" {
          581  +			{-mode d*} { set mode decompress }
          582  +			{-mode c*} { set mode compress }
          583  +			default { error "usage: zip -mode {compress|decompress} data" }
          584  +		}
          585  +
          586  +		# kludge to allow "-nowrap 1" as second option, 5-9-2002
          587  +		if {[llength $args] > 2 && [lrange $args 0 1] eq "-nowrap 1"} {
          588  +			if {$mode eq "compress"} {
          589  +				set mode deflate
          590  +			} else {
          591  +				set mode inflate
          592  +			}
          593  +		}
          594  +
          595  +		return [zlib $mode [lindex $args end]]
          596  +	}
          597  +}