TclVFS

Check-in [3ae33b2b92]
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:2010-12-29 Steve Huntley <[email protected]> * generic/vfs.c: include sys/stat.h so build under MinGW64 will succeed. See bug #3107382. * library/zipvfs.tcl: Fixed issues with clock handling, dealing with trying to [open] a directory, reading a zip file that has been appended to another file. See bugs 3103687, 3107380
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 3ae33b2b92c0b014221d8e38d008aa1e06580152
User & Date: blacksqr 2010-12-29 09:57:43
Context
2010-12-30
07:20
2010-12-30 Steve Huntley <[email protected]> * library/zipvfs.tcl: Applied patch 3005441 to fix issue with UTF-8 detection for filename encoding. Applied patch 3132957 to enable streaming of large files. check-in: 9ba3fde997 user: blacksqr tags: trunk
2010-12-29
09:57
2010-12-29 Steve Huntley <[email protected]> * generic/vfs.c: include sys/stat.h so build under MinGW64 will succeed. See bug #3107382. * library/zipvfs.tcl: Fixed issues with clock handling, dealing with trying to [open] a directory, reading a zip file that has been appended to another file. See bugs 3103687, 3107380 check-in: 3ae33b2b92 user: blacksqr tags: trunk
2010-05-17
04:18
* library/vfslib.tcl: Changed memchan condition from Tcl version 8.6 or greater to presence of chan command (since chan now in later 8.5 builds) check-in: 284a191cfe user: blacksqr tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.









1
2
3
4
5
6
7







2010-05-16  Steve Huntley  <[email protected]>

	* library/vfslib.tcl: Changed memchan condition from Tcl version 8.6 or
	greater to presence of chan command (since chan now in later 8.5 builds)

2010-02-01  Steve Huntley  <[email protected]>

>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
2010-12-29  Steve Huntley  <[email protected]>

	* generic/vfs.c: include sys/stat.h so build under MinGW64 will succeed.
	See bug #3107382.
	* library/zipvfs.tcl: Fixed issues with clock handling, dealing with 
	trying to [open] a directory, reading a zip file that has been appended
	to another file.  See bugs 3103687, 3107380

2010-05-16  Steve Huntley  <[email protected]>

	* library/vfslib.tcl: Changed memchan condition from Tcl version 8.6 or
	greater to presence of chan command (since chan now in later 8.5 builds)

2010-02-01  Steve Huntley  <[email protected]>

Changes to generic/vfs.c.

16
17
18
19
20
21
22



23
24
25
26
27
28
29
 * Copyright (c) 2001-2004 Vince Darley.
 * Copyright (c) 2006 ActiveState Software Inc.
 * 
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */




#include <tcl.h>
/* Required to access the 'stat' structure fields, and TclInExit() */
#include "tclInt.h"
#include "tclPort.h"

/*
 * Windows needs to know which symbols to export.  Unix does not.






>
>
>







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
 * Copyright (c) 2001-2004 Vince Darley.
 * Copyright (c) 2006 ActiveState Software Inc.
 * 
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_SYS_STAT_H
#  include <sys/stat.h>
#endif
#include <tcl.h>
/* Required to access the 'stat' structure fields, and TclInExit() */
#include "tclInt.h"
#include "tclPort.h"

/*
 * Windows needs to know which symbols to export.  Unix does not.

Changes to library/zipvfs.tcl.

102
103
104
105
106
107
108




109
110
111
112
113
114
115
...
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
286
287
...
373
374
375
376
377
378
379





380
381
382
383
384
385
386
...
399
400
401
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
428
429
430
431
432
433
434


435
436
437
438
439
440
441
...
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
	"" -
	"r" {
	    if {![::zip::exists $zipfd $name]} {
		vfs::filesystem posixerror $::vfs::posix(ENOENT)
	    }
	    
	    ::zip::stat $zipfd $name sb





	    set nfd [vfs::memchan]
	    fconfigure $nfd -translation binary

	    seek $zipfd $sb(ino) start
	    set data [zip::Data $zipfd sb 0]

................................................................................
    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}


    while {[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 verify} {
    upvar 1 $arr sb

................................................................................
    # comments the chunk may start at an arbitrary distance from the
    # end of the file. So if we do not find the header immediately
    # we have to extend the range of our search, possibly until we
    # have a large part of the archive in memory. We can fail only
    # after the whole file has been searched.

    set sz  [tell $fd]





    set len 512
    set at  512
    while {1} {
	if {$sz < $at} {set n -$sz} else {set n -$at}

	seek $fd $n end
	set hdr [read $fd $len]
................................................................................
	    incr at 512 ; # to ensure that the pattern we look for is not split at
	    #           ; # a buffer boundary, nor the header itself
	} else {
	    break
	}
    }

    set hdr [string range $hdr [expr {$pos + 4}] [expr {$pos + 21}]]

    set pos [expr {[tell $fd] + $pos - 512}]





    binary scan $hdr ssssiis \
	cb(ndisk) cb(cdisk) \
	cb(nitems) cb(ntotal) \
	cb(csize) cb(coff) \
	cb(comment)

................................................................................
    set cb(ndisk)	[u_short $cb(ndisk)]
    set cb(nitems)	[u_short $cb(nitems)]
    set cb(ntotal)	[u_short $cb(ntotal)]
    set cb(comment)	[u_short $cb(comment)]

    # 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 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)



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

    foreach v {vem ver flags method disk attr} {
................................................................................
	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

	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)]]






>
>
>
>







 







|
|
|
|
>
|
|

>
|



<
<
<

>







 







>
>
>
>
>







 







|
>
|
>
>
>
>







 







|
>
>
>
>



>









>
>







 







|







102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
...
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282



283
284
285
286
287
288
289
290
291
...
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
...
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
...
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
...
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
	"" -
	"r" {
	    if {![::zip::exists $zipfd $name]} {
		vfs::filesystem posixerror $::vfs::posix(ENOENT)
	    }
	    
	    ::zip::stat $zipfd $name sb

            if {$sb(ino) == -1} {
                vfs::filesystem posixerror $::vfs::posix(EISDIR)
            }

	    set nfd [vfs::memchan]
	    fconfigure $nfd -translation binary

	    seek $zipfd $sb(ino) start
	    set data [zip::Data $zipfd sb 0]

................................................................................
    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
    if {$sec  > 59} {set sec  59}
    if {$min  > 59} {set min  59}
    if {$hour > 23} {set hour 23}
    if {$mday < 1}  {set mday 1}
    if {$mday > 31} {set mday 31}
    if {$mon  < 1}  {set mon  1}
    if {$mon > 12}  {set mon  12}

    set res 0
    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]



    }

    return $res
}


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

................................................................................
    # comments the chunk may start at an arbitrary distance from the
    # end of the file. So if we do not find the header immediately
    # we have to extend the range of our search, possibly until we
    # have a large part of the archive in memory. We can fail only
    # after the whole file has been searched.

    set sz  [tell $fd]
    if {[info exists ::zip::max_header_seek]} {
        if {$::zip::max_header_seek < $sz} {
            set sz $::zip::max_header_seek
        }
    }
    set len 512
    set at  512
    while {1} {
	if {$sz < $at} {set n -$sz} else {set n -$at}

	seek $fd $n end
	set hdr [read $fd $len]
................................................................................
	    incr at 512 ; # to ensure that the pattern we look for is not split at
	    #           ; # a buffer boundary, nor the header itself
	} else {
	    break
	}
    }

    set hdr [string range $hdr [expr $pos + 4] [expr $pos + 21]]
 
     set seekstart [expr {[tell $fd] - 512}]
     if {$seekstart < 0} {
         set seekstart 0
     }
     set pos [expr {$seekstart + $pos}]

    binary scan $hdr ssssiis \
	cb(ndisk) cb(cdisk) \
	cb(nitems) cb(ntotal) \
	cb(csize) cb(coff) \
	cb(comment)

................................................................................
    set cb(ndisk)	[u_short $cb(ndisk)]
    set cb(nitems)	[u_short $cb(nitems)]
    set cb(ntotal)	[u_short $cb(ntotal)]
    set cb(comment)	[u_short $cb(comment)]

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

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
	return -code error "bad central header: $x"
    }

    foreach v {vem ver flags method disk attr} {
................................................................................
	upvar #0 zip::$fd cb
	upvar #0 zip::$fd.toc toc

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

	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)]]