From 36c5f839042e39b3d49e7939543b988142103033 Mon Sep 17 00:00:00 2001 From: Ruijie Yu 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