TclVFS

View Ticket
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Ticket Hash: 887778e1916c934f8a303a6337a10869d0ac2963
Title: tclvfs module vfs::zip discards the leading dot of files stored in an ZIP archive
Status: Open Type: Code_Defect
Severity: Severe Priority: Immediate
Subsystem: Resolution: Open
Last Modified: 2022-05-10 17:09:30
Version Found In: 1.0.4
User Comments:
anonymous added on 2022-05-09 17:04:57:

tcl 8.6.12

tclvfs module vfs::zip discards the leading dot of files stored in an ZIP archive:

# create ZIP archive
$ touch .foo bar
$ zip test.zip .foo bar

open via vfs::zip

$ tclsh
% package require vfs::zip
1.0.4
% vfs::zip::Mount test.zip test.zip
file3
% glob test.zip/*
test.zip/bar test.zip/foo

As you can see, '.foo' became 'foo' in vfs::zip

% open test.zip/bar
rc0
% open test.zip/.foo
couldn't open "test.zip/.foo": no such file or directory
% open test.zip/foo
rc1

But the ZIP really holds '.foo', not 'foo'

% exec unzip -l test.zip
Archive:  test.zip
  Length      Date    Time    Name
---------  ---------- -----   ----
        0  2022-05-09 18:15   .foo
        0  2022-05-09 18:15   bar
---------                     -------
        0                     2 files

This is due to the following code in

proc zip::TOC {...} {
  ...
  set sb(name) [string trimleft $sb(name) "./"]

which looks suspiciously like someone was trying to strip off the "./" prefix sequence from names like "./foo"

Cleary stripping off the dot from the beginning of a file name is plain wrong.

Proposed patch:

--- zipvfs.tcl	2022/05/09 17:00:22	1.1
+++ zipvfs.tcl	2022/05/09 17:00:28
@@ -546,7 +546,9 @@
         set sb(name) [encoding convertfrom utf-8 $sb(name)]
         set sb(comment) [encoding convertfrom utf-8 $sb(comment)]
     }
-    set sb(name) [string trimleft $sb(name) "./"]
+    if {[string range $sb(name) 0 1] == "./"} {
+	set sb(name) [string range $sb(name) 2 end]
+    }
     set parent [file dirname $sb(name)]
     if {$parent == "."} {set parent ""}
     lappend cbdir([string tolower $parent]) [file tail [string trimright $sb(name) /]]

anonymous added on 2022-05-10 17:09:30:

The line of code you highlighted is plain wrong as pointed out. It gives the following results:

% string trimleft "/.hello" "./" hello

% string trimleft "../../../../hello" "./" hello

I would ask that the proposed fix handles these cases correctly.