bug#61326: [PATCH v5] Work around zip's filename extension limitation (was: Adding --no-add-suffix to zip patch)

[Ruijie Yu via "Bug reports for GNU Emacs, the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 1149 bytes --]


Eli Zaretskii <eliz@gnu.org> writes:

>> From: Ruijie Yu <ruijie@netyu.xyz>
>> Cc: Eli Zaretskii <eliz@gnu.org>, asjo@koldfront.dk, 61326@debbugs.gnu.org
>> Date: Mon, 17 Apr 2023 16:48:13 +0800
>> 
>> 
>> Ruijie Yu <ruijie@netyu.xyz> writes:
>> 
>> > New iteration.  As mentioned from my last message, I have reverted the
>> > part where I tried to rewrite part of `archive-expunge' using `cl-do'.
>> >
>> > FTR, I am still waiting for the counter signature from FSF before this
>> > can be included into emacs.git.
>> >
>> 
>> Ping?
>> 
>> Removing the "DRAFT" from subject, because I think it is probably
>> complete.  Also, my FSF process should now be complete.
>
> Great, then, with these two issues out of our way, we can install this
> now.
>
> However, the patch as posted back then no longer applies.  Please
> rebase on the current master branch and re-post.
>
> Thanks.

Thanks.  I have made one change after the previous iteration: I turned
the "bug#xxx" comment in the test/lisp/arc-mode-tests.el into a
docstring.  Also, interestingly, git-rebase finishes cleanly on my end.

Here attached is a patch _without_ indentation changes.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Patch *without* indentation changes --]
[-- Type: text/x-patch, Size: 9046 bytes --]

From a98a530d7a7e73404c107e77c173d8981db811ce Mon Sep 17 00:00:00 2001
From: Ruijie Yu <ruijie+git@netyu.xyz>
Date: Mon, 6 Mar 2023 11:03:32 +0800
Subject: [PATCH] Handle modifications on extensionless zips correctly
 (Bug#61326)

* lisp/arc-mode.el
(archive-*-write-file-member) (archive-*-expunge):
Refactor to correctly modify extensionless zip archives.
(archive-expunge):
Move implementation to a separate helper function to facilitate testing.
(archive--act-files): New helper function to wrap around `call-process' calls.
(archive--need-rename-p):
New helper function to check whether a temporary rename is necessary.
(archive--ensure-extension) (archive--maybe-rename):
New helper functions to rename archive if the caller deems it necessary.
(archive--with-ensure-extension):
New helper function to handle writing an archive while ensuring extensionless
archives work correctly by temporarily renaming them.

* test/lisp/arc-mode-tests.el
(arc-mode-test-zip-ensure-ext): New regression test for bug#61326.
---
 lisp/arc-mode.el            | 76 +++++++++++++++++++++++++++----------
 test/lisp/arc-mode-tests.el | 67 ++++++++++++++++++++++++++++++++
 2 files changed, 123 insertions(+), 20 deletions(-)

diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index 5e696c091b2..0a971799746 100644
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -645,6 +645,49 @@ archive-get-descr
       (if (not noerror)
           (error "Line does not describe a member of the archive")))))
 ;; -------------------------------------------------------------------------
+;;; Section: Helper functions for requiring filename extensions
+
+(defun archive--act-files (command files)
+  (lambda (archive)
+    (apply #'call-process (car command)
+           nil nil nil (append (cdr command) (cons archive files)))))
+
+(defun archive--need-rename-p (&optional archive)
+  (let ((archive
+         (file-name-nondirectory (or archive buffer-file-name))))
+    (cl-case archive-subtype
+      ((zip) (not (seq-contains-p archive ?. #'eq))))))
+
+(defun archive--ensure-extension (archive ensure-extension)
+  (if ensure-extension
+      (make-temp-name (expand-file-name (concat archive "_tmp.")))
+    archive))
+
+(defun archive--maybe-rename (newname need-rename-p)
+  ;; Operating with archive as current buffer, and protect
+  ;; `default-directory' from being modified in `rename-visited-file'.
+  (when need-rename-p
+    (let ((default-directory default-directory))
+      (rename-visited-file newname))))
+
+(defun archive--with-ensure-extension (archive proc-fn)
+  (let ((saved default-directory))
+    (with-current-buffer (find-buffer-visiting archive)
+      (let ((ensure-extension (archive--need-rename-p))
+            (default-directory saved))
+        (unwind-protect
+            ;; Some archive programs (like zip) expect filenames to
+            ;; have an extension, so if necessary, temporarily rename
+            ;; an extensionless file for write accesses.
+            (let ((archive (archive--ensure-extension
+                            archive ensure-extension)))
+              (archive--maybe-rename archive ensure-extension)
+              (let ((exitcode (funcall proc-fn archive)))
+                (or (zerop exitcode)
+                    (error "Updating was unsuccessful (%S)" exitcode))))
+          (progn (archive--maybe-rename archive ensure-extension)
+                 (revert-buffer nil t)))))))
+;; -------------------------------------------------------------------------
 ;;; Section: the mode definition
 
 ;;;###autoload
@@ -1378,16 +1421,9 @@ archive-*-write-file-member
 	  (setq ename
 		(encode-coding-string ename archive-file-name-coding-system))
           (let* ((coding-system-for-write 'no-conversion)
-		 (default-directory (file-name-as-directory archive-tmpdir))
-		 (exitcode (apply #'call-process
-				  (car command)
-				  nil
-				  nil
-				  nil
-				  (append (cdr command)
-					  (list archive ename)))))
-            (or (zerop exitcode)
-		(error "Updating was unsuccessful (%S)" exitcode))))
+                 (default-directory (file-name-as-directory archive-tmpdir)))
+            (archive--with-ensure-extension
+             archive (archive--act-files command (list ename)))))
       (archive-delete-local tmpfile))))
 
 (defun archive-write-file (&optional file)
@@ -1510,9 +1546,7 @@ archive-chgrp-entry
 	  (archive-resummarize))
       (error "Setting group is not supported for this archive type"))))
 
-(defun archive-expunge ()
-  "Do the flagged deletions."
-  (interactive)
+(defun archive--expunge-maybe-force (force)
   (let (files)
     (save-excursion
       (goto-char archive-file-list-start)
@@ -1526,7 +1560,8 @@ archive-expunge
     (and files
 	 (or (not archive-read-only)
 	     (error "Archive is read-only"))
-	 (or (yes-or-no-p (format "Really delete %d member%s? "
+         (or force
+             (yes-or-no-p (format "Really delete %d member%s? "
 				  (length files)
 				  (if (null (cdr files)) "" "s")))
 	     (error "Operation aborted"))
@@ -1540,13 +1575,14 @@ archive-expunge
 	       (archive-resummarize)
 	     (revert-buffer))))))
 
+(defun archive-expunge ()
+  "Do the flagged deletions."
+  (interactive)
+  (archive--expunge-maybe-force nil))
+
 (defun archive-*-expunge (archive files command)
-  (apply #'call-process
-	 (car command)
-	 nil
-	 nil
-	 nil
-	 (append (cdr command) (cons archive files))))
+  (archive--with-ensure-extension
+   archive (archive--act-files command files)))
 
 (defun archive-rename-entry (newname)
   "Change the name associated with this entry in the archive file."
diff --git a/test/lisp/arc-mode-tests.el b/test/lisp/arc-mode-tests.el
index 32bce1b71bd..b6e06a563fe 100644
--- a/test/lisp/arc-mode-tests.el
+++ b/test/lisp/arc-mode-tests.el
@@ -46,6 +46,73 @@ arc-mode-test-zip-extract-gz
       (when (buffer-live-p zip-buffer) (kill-buffer zip-buffer))
       (when (buffer-live-p gz-buffer) (kill-buffer gz-buffer)))))
 
+(ert-deftest arc-mode-test-zip-ensure-ext ()
+  "Regression test for bug#61326."
+  (skip-unless (executable-find "zip"))
+  (let* ((default-directory arc-mode-tests-data-directory)
+         (base-zip-1 "base-1.zip")
+         (base-zip-2 "base-2.zip")
+         (content-1 '("1" "2"))
+         (content-2 '("3" "4"))
+         (make-file (lambda (name)
+                      (with-temp-buffer
+                        (insert name)
+                        (write-file name))))
+         (make-zip
+          (lambda (zip files)
+            (delete-file zip nil)
+            (funcall (archive--act-files '("zip") files) zip)))
+         (update-fn
+          (lambda (zip-nonempty)
+            (with-current-buffer (find-file-noselect zip-nonempty)
+              (save-excursion
+                (goto-char archive-file-list-start)
+                (save-current-buffer
+                  (archive-extract)
+                  (save-excursion
+                    (goto-char (point-max))
+                    (insert ?a)
+                    (save-buffer))
+                  (kill-buffer (current-buffer)))
+                (archive-extract)
+                ;; [2] must be ?a; [3] must be (eobp)
+                (should (eq (char-after 2) ?a))
+                (should (eq (point-max) 3))))))
+         (delete-fn
+          (lambda (zip-nonempty)
+            (with-current-buffer (find-file-noselect zip-nonempty)
+              ;; mark delete and expunge first entry
+              (save-excursion
+                (goto-char archive-file-list-start)
+                (should (length= archive-files 2))
+                (archive-flag-deleted 1)
+                (archive--expunge-maybe-force t)
+                (should (length= archive-files 1))))))
+         (test-modify
+          (lambda (zip mod-fn)
+            (let ((zip-base (concat zip ".zip"))
+                  (tag (gensym)))
+              (copy-file base-zip-1 zip t)
+              (copy-file base-zip-2 zip-base t)
+              (file-has-changed-p zip tag)
+              (file-has-changed-p zip-base tag)
+              (funcall mod-fn zip)
+              (should-not (file-has-changed-p zip-base tag))
+              (should (file-has-changed-p zip tag))))))
+    ;; setup: make two zip files with different contents
+    (mapc make-file (append content-1 content-2))
+    (mapc (lambda (args) (apply make-zip args))
+          (list (list base-zip-1 content-1)
+                (list base-zip-2 content-2)))
+    ;; test 1: with "test-update" and "test-update.zip", update
+    ;; "test-update": (1) ensure only "test-update" is modified, (2)
+    ;; ensure the contents of the new member is expected.
+    (funcall test-modify "test-update" update-fn)
+    ;; test 2: with "test-delete" and "test-delete.zip", delete entry
+    ;; from "test-delete": (1) ensure only "test-delete" is modified,
+    ;; (2) ensure the file list is reduced as expected.
+    (funcall test-modify "test-delete" delete-fn)))
+
 (provide 'arc-mode-tests)
 
 ;;; arc-mode-tests.el ends here
-- 
2.40.0


[-- Attachment #3: Type: text/plain, Size: 273 bytes --]


Here attached is a patch _with_ indentation changes (on functions which
I have touched) -- I simply re-indented these functions without tabs.
Not sure if you want this, so I provided the other patch file as an
alternative.  Please choose whichever you prefer to install.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: Patch *with* indentation changes --]
[-- Type: text/x-patch, Size: 12416 bytes --]

From 36c5f839042e39b3d49e7939543b988142103033 Mon Sep 17 00:00:00 2001
From: Ruijie Yu <ruijie+git@netyu.xyz>
Date: Mon, 6 Mar 2023 11:03:32 +0800
Subject: [PATCH] Handle modifications on extensionless zips correctly
 (Bug#61326)

* lisp/arc-mode.el
(archive-*-write-file-member) (archive-*-expunge):
Refactor to correctly modify extensionless zip archives.
(archive-expunge):
Move implementation to a separate helper function to facilitate testing.
(archive--act-files): New helper function to wrap around `call-process' calls.
(archive--need-rename-p):
New helper function to check whether a temporary rename is necessary.
(archive--ensure-extension) (archive--maybe-rename):
New helper functions to rename archive if the caller deems it necessary.
(archive--with-ensure-extension):
New helper function to handle writing an archive while ensuring extensionless
archives work correctly by temporarily renaming them.

* test/lisp/arc-mode-tests.el
(arc-mode-test-zip-ensure-ext): New regression test for bug#61326.
---
 lisp/arc-mode.el            | 144 ++++++++++++++++++++++--------------
 test/lisp/arc-mode-tests.el |  67 +++++++++++++++++
 2 files changed, 157 insertions(+), 54 deletions(-)

diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index 5e696c091b2..89b3e720ed9 100644
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -645,6 +645,49 @@ archive-get-descr
       (if (not noerror)
           (error "Line does not describe a member of the archive")))))
 ;; -------------------------------------------------------------------------
+;;; Section: Helper functions for requiring filename extensions
+
+(defun archive--act-files (command files)
+  (lambda (archive)
+    (apply #'call-process (car command)
+           nil nil nil (append (cdr command) (cons archive files)))))
+
+(defun archive--need-rename-p (&optional archive)
+  (let ((archive
+         (file-name-nondirectory (or archive buffer-file-name))))
+    (cl-case archive-subtype
+      ((zip) (not (seq-contains-p archive ?. #'eq))))))
+
+(defun archive--ensure-extension (archive ensure-extension)
+  (if ensure-extension
+      (make-temp-name (expand-file-name (concat archive "_tmp.")))
+    archive))
+
+(defun archive--maybe-rename (newname need-rename-p)
+  ;; Operating with archive as current buffer, and protect
+  ;; `default-directory' from being modified in `rename-visited-file'.
+  (when need-rename-p
+    (let ((default-directory default-directory))
+      (rename-visited-file newname))))
+
+(defun archive--with-ensure-extension (archive proc-fn)
+  (let ((saved default-directory))
+    (with-current-buffer (find-buffer-visiting archive)
+      (let ((ensure-extension (archive--need-rename-p))
+            (default-directory saved))
+        (unwind-protect
+            ;; Some archive programs (like zip) expect filenames to
+            ;; have an extension, so if necessary, temporarily rename
+            ;; an extensionless file for write accesses.
+            (let ((archive (archive--ensure-extension
+                            archive ensure-extension)))
+              (archive--maybe-rename archive ensure-extension)
+              (let ((exitcode (funcall proc-fn archive)))
+                (or (zerop exitcode)
+                    (error "Updating was unsuccessful (%S)" exitcode))))
+          (progn (archive--maybe-rename archive ensure-extension)
+                 (revert-buffer nil t)))))))
+;; -------------------------------------------------------------------------
 ;;; Section: the mode definition
 
 ;;;###autoload
@@ -1357,37 +1400,30 @@ archive-*-write-file-member
          (ename (archive--file-desc-ext-file-name descr))
          (tmpfile (expand-file-name ename archive-tmpdir))
          (top (directory-file-name (file-name-as-directory archive-tmpdir)))
-	 (default-directory (file-name-as-directory top)))
+         (default-directory (file-name-as-directory top)))
     (unwind-protect
         (progn
           (make-directory (file-name-directory tmpfile) t)
-	  ;; If the member is itself an archive, write it without
-	  ;; the dired-like listing we created.
-	  (if (eq major-mode 'archive-mode)
-	      (archive-write-file tmpfile)
-	    (write-region nil nil tmpfile nil 'nomessage))
-	  ;; basic-save-buffer needs last-coding-system-used to have
-	  ;; the value used to write the file, so save it before any
-	  ;; further processing clobbers it (we restore it in
-	  ;; archive-write-file-member, above).
-	  (setq archive-member-coding-system last-coding-system-used)
-	  (if (archive--file-desc-mode descr)
-	      ;; Set the file modes, but make sure we can read it.
-	      (set-file-modes tmpfile
-	                      (logior ?\400 (archive--file-desc-mode descr))))
-	  (setq ename
-		(encode-coding-string ename archive-file-name-coding-system))
+          ;; If the member is itself an archive, write it without
+          ;; the dired-like listing we created.
+          (if (eq major-mode 'archive-mode)
+              (archive-write-file tmpfile)
+            (write-region nil nil tmpfile nil 'nomessage))
+          ;; basic-save-buffer needs last-coding-system-used to have
+          ;; the value used to write the file, so save it before any
+          ;; further processing clobbers it (we restore it in
+          ;; archive-write-file-member, above).
+          (setq archive-member-coding-system last-coding-system-used)
+          (if (archive--file-desc-mode descr)
+              ;; Set the file modes, but make sure we can read it.
+              (set-file-modes tmpfile
+                              (logior ?\400 (archive--file-desc-mode descr))))
+          (setq ename
+                (encode-coding-string ename archive-file-name-coding-system))
           (let* ((coding-system-for-write 'no-conversion)
-		 (default-directory (file-name-as-directory archive-tmpdir))
-		 (exitcode (apply #'call-process
-				  (car command)
-				  nil
-				  nil
-				  nil
-				  (append (cdr command)
-					  (list archive ename)))))
-            (or (zerop exitcode)
-		(error "Updating was unsuccessful (%S)" exitcode))))
+                 (default-directory (file-name-as-directory archive-tmpdir)))
+            (archive--with-ensure-extension
+             archive (archive--act-files command (list ename)))))
       (archive-delete-local tmpfile))))
 
 (defun archive-write-file (&optional file)
@@ -1510,43 +1546,43 @@ archive-chgrp-entry
 	  (archive-resummarize))
       (error "Setting group is not supported for this archive type"))))
 
-(defun archive-expunge ()
-  "Do the flagged deletions."
-  (interactive)
+(defun archive--expunge-maybe-force (force)
   (let (files)
     (save-excursion
       (goto-char archive-file-list-start)
       (while (< (point) archive-file-list-end)
         (if (= (following-char) ?D)
-	    (setq files (cons (archive--file-desc-ext-file-name
-	                       (archive-get-descr))
-	                      files)))
+            (setq files (cons (archive--file-desc-ext-file-name
+                               (archive-get-descr))
+                              files)))
         (forward-line 1)))
     (setq files (nreverse files))
     (and files
-	 (or (not archive-read-only)
-	     (error "Archive is read-only"))
-	 (or (yes-or-no-p (format "Really delete %d member%s? "
-				  (length files)
-				  (if (null (cdr files)) "" "s")))
-	     (error "Operation aborted"))
-	 (let ((archive (archive-maybe-copy (buffer-file-name)))
-	       (expunger (archive-name "expunge")))
-	   (if (fboundp expunger)
-	       (funcall expunger archive files)
-	     (archive-*-expunge archive files (symbol-value expunger)))
-	   (archive-maybe-update nil)
-	   (if archive-remote
-	       (archive-resummarize)
-	     (revert-buffer))))))
+         (or (not archive-read-only)
+             (error "Archive is read-only"))
+         (or force
+             (yes-or-no-p (format "Really delete %d member%s? "
+                                  (length files)
+                                  (if (null (cdr files)) "" "s")))
+             (error "Operation aborted"))
+         (let ((archive (archive-maybe-copy (buffer-file-name)))
+               (expunger (archive-name "expunge")))
+           (if (fboundp expunger)
+               (funcall expunger archive files)
+             (archive-*-expunge archive files (symbol-value expunger)))
+           (archive-maybe-update nil)
+           (if archive-remote
+               (archive-resummarize)
+             (revert-buffer))))))
+
+(defun archive-expunge ()
+  "Do the flagged deletions."
+  (interactive)
+  (archive--expunge-maybe-force nil))
 
 (defun archive-*-expunge (archive files command)
-  (apply #'call-process
-	 (car command)
-	 nil
-	 nil
-	 nil
-	 (append (cdr command) (cons archive files))))
+  (archive--with-ensure-extension
+   archive (archive--act-files command files)))
 
 (defun archive-rename-entry (newname)
   "Change the name associated with this entry in the archive file."
diff --git a/test/lisp/arc-mode-tests.el b/test/lisp/arc-mode-tests.el
index 32bce1b71bd..b6e06a563fe 100644
--- a/test/lisp/arc-mode-tests.el
+++ b/test/lisp/arc-mode-tests.el
@@ -46,6 +46,73 @@ arc-mode-test-zip-extract-gz
       (when (buffer-live-p zip-buffer) (kill-buffer zip-buffer))
       (when (buffer-live-p gz-buffer) (kill-buffer gz-buffer)))))
 
+(ert-deftest arc-mode-test-zip-ensure-ext ()
+  "Regression test for bug#61326."
+  (skip-unless (executable-find "zip"))
+  (let* ((default-directory arc-mode-tests-data-directory)
+         (base-zip-1 "base-1.zip")
+         (base-zip-2 "base-2.zip")
+         (content-1 '("1" "2"))
+         (content-2 '("3" "4"))
+         (make-file (lambda (name)
+                      (with-temp-buffer
+                        (insert name)
+                        (write-file name))))
+         (make-zip
+          (lambda (zip files)
+            (delete-file zip nil)
+            (funcall (archive--act-files '("zip") files) zip)))
+         (update-fn
+          (lambda (zip-nonempty)
+            (with-current-buffer (find-file-noselect zip-nonempty)
+              (save-excursion
+                (goto-char archive-file-list-start)
+                (save-current-buffer
+                  (archive-extract)
+                  (save-excursion
+                    (goto-char (point-max))
+                    (insert ?a)
+                    (save-buffer))
+                  (kill-buffer (current-buffer)))
+                (archive-extract)
+                ;; [2] must be ?a; [3] must be (eobp)
+                (should (eq (char-after 2) ?a))
+                (should (eq (point-max) 3))))))
+         (delete-fn
+          (lambda (zip-nonempty)
+            (with-current-buffer (find-file-noselect zip-nonempty)
+              ;; mark delete and expunge first entry
+              (save-excursion
+                (goto-char archive-file-list-start)
+                (should (length= archive-files 2))
+                (archive-flag-deleted 1)
+                (archive--expunge-maybe-force t)
+                (should (length= archive-files 1))))))
+         (test-modify
+          (lambda (zip mod-fn)
+            (let ((zip-base (concat zip ".zip"))
+                  (tag (gensym)))
+              (copy-file base-zip-1 zip t)
+              (copy-file base-zip-2 zip-base t)
+              (file-has-changed-p zip tag)
+              (file-has-changed-p zip-base tag)
+              (funcall mod-fn zip)
+              (should-not (file-has-changed-p zip-base tag))
+              (should (file-has-changed-p zip tag))))))
+    ;; setup: make two zip files with different contents
+    (mapc make-file (append content-1 content-2))
+    (mapc (lambda (args) (apply make-zip args))
+          (list (list base-zip-1 content-1)
+                (list base-zip-2 content-2)))
+    ;; test 1: with "test-update" and "test-update.zip", update
+    ;; "test-update": (1) ensure only "test-update" is modified, (2)
+    ;; ensure the contents of the new member is expected.
+    (funcall test-modify "test-update" update-fn)
+    ;; test 2: with "test-delete" and "test-delete.zip", delete entry
+    ;; from "test-delete": (1) ensure only "test-delete" is modified,
+    ;; (2) ensure the file list is reduced as expected.
+    (funcall test-modify "test-delete" delete-fn)))
+
 (provide 'arc-mode-tests)
 
 ;;; arc-mode-tests.el ends here
-- 
2.40.0


[-- Attachment #5: Type: text/plain, Size: 128 bytes --]


-- 
Best,


RY

[Please note that this mail might go to spam due to some
misconfiguration in my mail server -- will fix soon.]