Diff

Differences From Artifact [4a9165155e]:

To Artifact [734aa55ae1]:


1
2
3
4
5
6
7
8
9
10
1
2

3
4
5
6
7
8
9


-







# Removed provision of the backward compatible name. Moved to separate
# file/package.
package provide vfs::zip 1.0.1

package require vfs

# Using the vfs, memchan and Trf extensions, we ought to be able
# to write a Tcl-only zip virtual filesystem.  What we have below
# is basically that.

233
234
235
236
237
238
239




240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263







264

265

266
267
268
269
270
271
272

273
274
275
276
277
278
279
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260






261
262
263
264
265
266
267
268
269

270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285







+
+
+
+


















-
-
-
-
-
-
+
+
+
+
+
+
+

+
-
+







+







	128	{normal}
    }

    proc u_short {n}  { return [expr { ($n+0x10000)%0x10000 }] }
}

proc zip::DosTime {date time} {
    # The pre-VFS environment will not have access to "clock", so don't even
    # bother
    return 0

    set time [u_short $time]
    set date [u_short $date]

    # time = fedcba9876543210
    #        HHHHHmmmmmmSSSSS (sec/2 actually)

    # data = fedcba9876543210
    #        yyyyyyyMMMMddddd

    set sec  [expr { ($time & 0x1F) * 2 }]
    set min  [expr { ($time >> 5) & 0x3F }]
    set hour [expr { ($time >> 11) & 0x1F }]

    set mday [expr { $date & 0x1F }]
    set mon  [expr { (($date >> 5) & 0xF) }]
    set year [expr { (($date >> 9) & 0xFF) + 1980 }]

    # Fix up bad date/time data, no need to fail
    while {$sec  > 59} {incr sec  -60}
    while {$min  > 59} {incr sec  -60}
    while {$hour > 23} {incr hour -24}
    if {$mday < 1}  {incr mday}
    if {$mon  < 1}  {incr mon}
    while {$mon > 12} {incr hour -12}
    if {$sec  > 59} {set sec  59}
    if {$min  > 59} {set sec  59}
    if {$hour > 23} {set hour 23}
    if {$mday < 1}  {set mday 1}
    if {$mday > 35} {set mday 35}
    if {$mon  < 1}  {set mon  1}
    if {$mon > 12}  {set mon  12}

    set res 0
    while {[catch {
    while {$mday > 1 && [catch {
	set dt [format {%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d} \
		    $year $mon $mday $hour $min $sec]
	set res [clock scan $dt -gmt 1]
    }]} {
	# Only mday can be wrong, at end of month
	incr mday -1
    }

    return $res
}


proc zip::Data {fd arr {varPtr ""} {verify 0}} {
    upvar 1 $arr sb

396
397
398
399
400
401
402

403
404
405
406
407
408
409
410
411


412
413
414
415
416
417
418
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427







+









+
+








    # Compute base for situations where ZIP file
    # has been appended to another media (e.g. EXE)
    set cb(base)	[expr { $pos - $cb(csize) - $cb(coff) }]
}

proc zip::TOC {fd arr} {
    upvar #0 zip::$fd cb
    upvar 1 $arr sb

    set buf [read $fd 46]

    binary scan $buf A4ssssssiiisssssii hdr \
      sb(vem) sb(ver) sb(flags) sb(method) time date \
      sb(crc) sb(csize) sb(size) \
      flen elen clen sb(disk) sb(attr) \
      sb(atx) sb(ino)

    set sb(ino) [expr {$cb(base) + $sb(ino)}]

    if { ![string equal "PK\01\02" $hdr] } {
	binary scan $hdr H* x
	error "bad central header: $x"
    }

    foreach v {vem ver flags method disk attr} {
438
439
440
441
442
443
444
445

446
447
448
449
450
451
452
447
448
449
450
451
452
453

454
455
456
457
458
459
460
461







-
+







	upvar #0 zip::$fd cb
	upvar #0 zip::$fd.toc toc

	fconfigure $fd -translation binary ;#-buffering none
	
	zip::EndOfArchive $fd cb

	seek $fd $cb(coff) start
	seek $fd [expr {$cb(base) + $cb(coff)}] start

	set toc(_) 0; unset toc(_); #MakeArray
	
	for { set i 0 } { $i < $cb(nitems) } { incr i } {
	    zip::TOC $fd sb
	    
	    set sb(depth) [llength [file split $sb(name)]]
560
561
562
563
564
565
566






















569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
proc zip::_close {fd} {
    variable $fd
    variable $fd.toc
    unset $fd
    unset $fd.toc
    ::close $fd
}

# use zlib to define zip and crc if available
if {[llength [info command vfs::zip]] == 0 && [llength [info command zlib]] || ![catch {load "" zlib}]} {
	proc vfs::zip {flag value args} {
		switch -glob -- "$flag $value" {
			{-mode d*} { set mode decompress }
			{-mode c*} { set mode compress }
			default { error "usage: zip -mode {compress|decompress} data" }
		}

		# kludge to allow "-nowrap 1" as second option, 5-9-2002
		if {[llength $args] > 2 && [lrange $args 0 1] eq "-nowrap 1"} {
			if {$mode eq "compress"} {
				set mode deflate
			} else {
				set mode inflate
			}
		}

		return [zlib $mode [lindex $args end]]
	}
}