Merge 8.7 - Bug [d5d03207ca] - Tcl hang on zipfs writes greater than …

…buffer size
tcltk · Sep 26, 2023 · e8ffd66 · e8ffd66
2 parents b4158a1 + b730c0e
commit e8ffd66
Show file tree

Hide file tree

Showing 2 changed files with 36 additions and 12 deletions.
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
@@ -4324,18 +4324,17 @@ ZipChannelWrite(
     ZipChannel *info = (ZipChannel *) instanceData;
     unsigned long nextpos;
 
-    if (!info->isWriting) {
+    if (toWrite == 0 || !info->isWriting) {
 	*errloc = EINVAL;
 	return -1;
     }
-    nextpos = info->numRead + toWrite;
-    if (nextpos > info->maxWrite) {
-	toWrite = info->maxWrite - info->numRead;
-	nextpos = info->maxWrite;
-    }
-    if (toWrite == 0) {
-	return 0;
+    assert(info->maxWrite >= info->numRead);
+    if (toWrite > (int) (info->maxWrite - info->numRead)) {
+	/* Don't do partial writes in error case. Or should we? */
+	*errloc = EFBIG;
+	return -1;
     }
+    nextpos = info->numRead + toWrite;
     memcpy(info->ubuf + info->numRead, buf, toWrite);
     info->numRead = nextpos;
     if (info->numRead > info->numBytes) {

diff --git a/tests/zipfs.test b/tests/zipfs.test
@@ -1073,7 +1073,7 @@ namespace eval test_ns_zipfs {
         set result
     } -result [list newtext test\n]
 
-    test zipfs-write-size-limit-0 "Writes have a size limit" -setup {
+    test zipfs-write-size-limit-0 "Writes more than size limit with flush" -setup {
         set origlimit $::tcl::zipfs::wrmax
         mount [zippath test.zip]
     } -cleanup {
@@ -1083,10 +1083,35 @@ namespace eval test_ns_zipfs {
     } -body {
         set ::tcl::zipfs::wrmax 10
         set fd [open [file join $defaultMountPoint test] w]
-        puts -nonewline $fd [string repeat x 11]
-    } -result {} -returnCodes error -constraints bug-d5d03207ca
+        puts $fd [string repeat x 11]
+        flush $fd
+    } -result {error flushing *: file too large} -match glob -returnCodes error
 
-    test zipfs-write-size-limit-1 "Writes disallowed" -setup {
+    test zipfs-write-size-limit-1 "Writes size limit on close" -setup {
+        set origlimit $::tcl::zipfs::wrmax
+        mount [zippath test.zip]
+    } -cleanup {
+        set ::tcl::zipfs::wrmax $origlimit
+        cleanup
+    } -body {
+        set ::tcl::zipfs::wrmax 10
+        set fd [open [file join $defaultMountPoint test] w]
+        puts $fd [string repeat x 11]
+        close $fd
+    } -result {file too large} -match glob -returnCodes error
+
+    test zipfs-write-size-limit-2 "Writes max size" -setup {
+        mount [zippath test.zip]
+    } -cleanup {
+        cleanup
+    } -body {
+        set fd [open [file join $defaultMountPoint test] w]
+        puts -nonewline $fd [string repeat x $::tcl::zipfs::wrmax]
+        close $fd
+        file size [file join $defaultMountPoint test]
+    } -result $::tcl::zipfs::wrmax
+
+    test zipfs-write-size-limit-3 "Writes disallowed" -setup {
         set origlimit $::tcl::zipfs::wrmax
         mount [zippath test.zip]
     } -cleanup {