Tcl Source Code

\fBzipfs mkkey\fI password\fR
\fBzipfs mkzip\fI outfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR?
\fBzipfs mount\fR ?\fIzipfile\fR? ?\fImountpoint\fR? ?\fIpassword\fR?
\fBzipfs root\fR
\fBzipfs unmount\fI mountpoint\fR
.fi
'\" The following subcommand is *UNDOCUMENTED*
'\" \fBzipfs mount_data\fR ?\fIdata\fR ?\fImountpoint\fR??
.BE
.SH DESCRIPTION
.PP
The \fBzipfs\fR command provides Tcl with the ability to mount the
contents of a ZIP archive file as a virtual file system. Tcl's ZIP
archive support is limited to basic features and options.
Supported storage methods include only STORE and DEFLATE with optional

    {"zipfs", "list"},
    {"zipfs", "lmkimg"},
    {"zipfs", "lmkzip"},
    {"zipfs", "mkimg"},
    {"zipfs", "mkkey"},
    {"zipfs", "mkzip"},
    {"zipfs", "mount"},
    {"zipfs", "mount_data"},
    {"zipfs", "root"},
    {"zipfs", "unmount"},
    {NULL, NULL}
};

/*
 * Math functions. All are safe.

}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSMountBufferObjCmd --
 *
 *	This procedure is invoked to process the [zipfs mount_data] command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	A ZIP archive file is mounted, resources are allocated.
 *

#ifdef HAVE_ZLIB
    static const EnsembleImplMap initMap[] = {
	{"mkimg",	ZipFSMkImgObjCmd,	NULL, NULL, NULL, 1},
	{"mkzip",	ZipFSMkZipObjCmd,	NULL, NULL, NULL, 1},
	{"lmkimg",	ZipFSLMkImgObjCmd,	NULL, NULL, NULL, 1},
	{"lmkzip",	ZipFSLMkZipObjCmd,	NULL, NULL, NULL, 1},
	{"mount",	ZipFSMountObjCmd,	NULL, NULL, NULL, 1},
	{"mount_data",	ZipFSMountBufferObjCmd,	NULL, NULL, NULL, 1},
	{"unmount",	ZipFSUnmountObjCmd,	NULL, NULL, NULL, 1},
	{"mkkey",	ZipFSMkKeyObjCmd,	NULL, NULL, NULL, 1},
	{"exists",	ZipFSExistsObjCmd,	NULL, NULL, NULL, 1},
	{"info",	ZipFSInfoObjCmd,	NULL, NULL, NULL, 1},
	{"list",	ZipFSListObjCmd,	NULL, NULL, NULL, 1},
	{"canonical",	ZipFSCanonicalObjCmd,	NULL, NULL, NULL, 1},
	{"root",	ZipFSRootObjCmd,	NULL, NULL, NULL, 1},

}

::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]

testConstraint testinterpdelete [llength [info commands testinterpdelete]]

set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:home tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:tildeexpand tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:canonical tcl:zipfs:exists tcl:zipfs:info tcl:zipfs:list tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:root tcl:zipfs:unmount unload zipfs}

proc _ms_limit_args {ms {t0 {}}} {
    if {$t0 eq {}} { set t0 [clock milliseconds] }
    incr t0 $ms
    list -seconds [expr {$t0 / 1000}] -milliseconds [expr {$t0 % 1000}]
}

test zipfs-2.8 {zipfs mkzip} -constraints zipfs -body {
    cd $tcl_library/encoding
    zipfs mkzip $zipfile .
    set fin [open $zipfile r]
    fconfigure $fin -translation binary
    set dat [read $fin]
    close $fin
    zipfs mount_data $dat def
    zipfs list -glob ${ziproot}def/cp850.*
} -cleanup {
    cd $CWD
} -result "${ziproot}def/cp850.enc"
testConstraint zipfsencbuf [zipfs exists ${ziproot}def/cp850.enc]
test zipfs-2.9 {zipfs info} -constraints {zipfs zipfsencbuf} -body {
    set r [zipfs info ${ziproot}def/cp850.enc]

    set interp [interp create]
} -body {
    interp eval $interp {
	zipfs ?
    }
} -returnCodes error -cleanup {
    interp delete $interp
} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount}
test zipfs-3.2 {zipfs in child interpreters} -constraints zipfs -setup {
    set interp [interp create]
} -body {
    interp eval $interp {
	zipfs mkzip
    }
} -returnCodes error -cleanup {

    zipfs unmount ziptest
    removeFile $baseImage
    removeFile $midImage
    removeFile $targetImage
    removeFile $addFile
} -result [list ${ziproot}/ziptest/test/add.tcl ${ziproot}/ziptest/test/ok.tcl]

test zipfs-5.1 {zipfs mount_data: short data} -constraints zipfs -body {
    zipfs mount_data {} gorp
} -returnCodes error -result {illegal file size}
test zipfs-5.2 {zipfs mount_data: short data} -constraints zipfs -body {
    zipfs mount_data gorpGORPgorp gorp
} -returnCodes error -result {illegal file size}
test zipfs-5.3 {zipfs mount_data: short data} -constraints zipfs -body {
    set data PK\x03\x04.....................................
    append data PK\x01\x02.....................................
    append data PK\x05\x06.....................................
    zipfs mount_data $data gorp
} -returnCodes error -result {archive directory truncated}

test zipfs-6.1 {zipfs mkkey} -constraints zipfs -body {
    binary scan [zipfs mkkey gorp] cu* x
    return $x
} -result {224 226 111 103 4 80 75 90 90}


            cleanup
        } -result {1 1 {}} {*}$args

        if {![file exists $zippath]} {
            return
        }
        set data [readbin $zippath]
        test zipfs-mount_data-$id $id -body {
            list [catch {zipfs mount_data $data $defMountPt} message] \
                [string match $messagePattern $message] \
                [mounttarget $defMountPt]
        } -cleanup {
            # In case mount succeeded when it should not
            cleanup
        } -result {1 1 {}} {*}$args
    }

    # Generates tests for file, file on root, memory buffer cases for an archive
    proc testmount {id zippath checkPath mountpoint args} {
        set zippath [zippath $zippath]
        test zipfs-mount-$id "zipfs mount $id" -body {
            set canon [mount $zippath $mountpoint]
            list [file exists [file join $canon $checkPath]] \
                [zipfs mount $canon] [zipfs mount $mountpoint]
        } -cleanup {
            zipfs unmount $mountpoint
        } -result [list 1 $zippath $zippath] {*}$args

        # Mount memory buffer
        test zipfs-mount_data-$id "zipfs mount_data $id" -body {
            set canon [zipfs mount_data [readbin $zippath] $mountpoint]
            list [file exists [file join $canon $checkPath]] \
                [zipfs mount $canon] [zipfs mount $mountpoint]
        } -cleanup {
            cleanup
        } -result [list 1 {Memory Buffer} {Memory Buffer}] {*}$args

    }

    testnumargs "zipfs mount" "" "?zipfile? ?mountpoint? ?password?"
    testnumargs "zipfs mount_data" "data mountpoint" ""

    # Not supported zip files
    testbadmount non-existent-file    nosuchfile.zip "couldn't open*nosuchfile.zip*no such file or directory"
    testbadmount not-zipfile          [file normalize [info script]]      "archive directory end signature not found"
    testbadmount zip64-unsupported    zip64.zip      "wrong header signature"

    # Inconsistent metadata
    testbadmount bad-directory-offset incons-cdoffset.zip          "archive directory truncated"
    testbadmount bad-directory-magic  incons-central-magic-bad.zip "wrong header signature"
    testbadmount bad-local-magic      incons-local-magic-bad.zip   "Failed to find local header"
    testbadmount bad-file-count-high  incons-file-count-high.zip   "truncated directory"
    testbadmount bad-file-count-low   incons-file-count-low.zip    "short file count"

    test zipfs-mount-on-drive "Mount point include drive" -body {
        zipfs mount [zippath test.zip] C:/foo
    } -result {Invalid mount path "C:/foo"} -returnCodes error -constraints win
    test zipfs-mount_data-on-drive "Mount point include drive" -body {
        zipfs mount_data [readbin [zippath test.zip]] C:/foo
    } -result {Invalid mount path "C:/foo"} -returnCodes error -constraints win
    test zipfs-mount-on-unc "Mount point is unc" -body {
        zipfs mount [zippath test.zip] //unc/share/foo
    } -result {Invalid mount path "//unc/share/foo"} -returnCodes error
    test zipfs-mount_data-on-unc "Mount point include unc" -body {
        zipfs mount_data [readbin [zippath test.zip]] //unc/share/foo
    } -result {Invalid mount path "//unc/share/foo"} -returnCodes error

    # Good mounts
    testmount basic             test.zip           testdir/test2 $defMountPt
    testmount basic-on-default  test.zip           testdir/test2 ""
    testmount basic-on-root     test.zip           testdir/test2 [zipfs root]
    testmount basic-on-slash    test.zip           testdir/test2 /

        } -result $resultpaths {*}$args

        # Mount memory buffer
        test zipfs-list-memory-$id "zipfs list memory $id" -body {
            lsort [zipfs list {*}$cmdargs]
        } -setup {
            foreach {zippath mountpoint} $mounts {
                zipfs mount_data [readbin [zippath $zippath]] [file join [zipfs root] $mountpoint]
            }
        } -cleanup {
            cleanup
        } -result $resultpaths {*}$args
    }
    # Some tests have !zipfslib constraint because otherwise they dump the entire Tcl library which is mounted on root
    testzipfslist no-mounts                 "" {} {} -constraints !zipfslib

        set setup {
            foreach {zippath mountpoint} $mounts {
                zipfs mount [zippath $zippath] [file join [zipfs root] $mountpoint]
            }
        }
        set memory_setup {
            foreach {zippath mountpoint} $mounts {
                zipfs mount_data [readbin [zippath $zippath]] [file join [zipfs root] $mountpoint]
            }
        }
        if {[dict exists $args -setup]} {
            append setup \n[dict get $args -setup]
            append memory_setup \n[dict get $args -setup]
            dict unset args -setup
        }

            set fd [open [file join $defMountPt $filename] {*}$openopts]
            gets $fd
        } -result $result {*}$args

        set data [readbin $zippath]
        test zipfs-read-memory-$id "zipfs read in-memory $id" -setup {
            unset -nocomplain fd
            zipfs mount_data $data $defMountPt
        } -cleanup {
            # In case open succeeded when it should not
            if {[info exists fd]} {
                close $fd
            }
            cleanup
        } -body {

            }
            cleanup
        } -body $body -result $result {*}$args

        set data [readbin $zippath]
        test zipfs-write-memory-$id "zipfs write in-memory $id" -setup {
            unset -nocomplain fd
            zipfs mount_data $data $defMountPt
        } -cleanup {
            # In case open succeeded when it should not
            if {[info exists fd]} {
                close $fd
            }
            cleanup
        } -body $body -result $result {*}$args

            }
            cleanup
        } -body $body -result $expected {*}$args

        set data [readbin $zippath]
        test zipfs-rw-memory-$id "zipfs read/seek/write in-memory $id" -setup {
            unset -nocomplain fd
            zipfs mount_data $data $defMountPt
        } -cleanup {
            # In case open succeeded when it should not
            if {[info exists fd]} {
                close $fd
            }
            cleanup
        } -body $body -result $expected {*}$args

            cleanup
        } -body {
            set fd [open [file join $defMountPt $filename]]
        } -result $result -returnCodes error {*}$args

        # Mount memory buffer
        test zipfs-crc-memory-$id "zipfs crc memory $id" -setup {
            zipfs mount_data [readbin [zippath $zippath]] $defMountPt
        } -cleanup {
            cleanup
        } -body {
            set fd [open [file join $defMountPt $filename]]
        } -result $result -returnCodes error {*}$args
    }
    testcrc local incons-local-crc.zip a "invalid CRC"