Handle modifications in extensionless zip files (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.
This commit is contained in:
Ruijie Yu
Eli Zaretskii
parent
e0c8e4f12f
commit
fd4c9246fc
2 changed files with 123 additions and 20 deletions
|
|
@ -645,6 +645,49 @@ Does not signal an error if optional argument NOERROR is non-nil."
|
|||
(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 @@ NEW-NAME."
|
|||
(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 @@ as a relative change like \"g+rw\" as for chmod(2)."
|
|||
(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 @@ as a relative change like \"g+rw\" as for chmod(2)."
|
|||
(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 @@ as a relative change like \"g+rw\" as for chmod(2)."
|
|||
(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."
|
||||
|
|
|
|||
|
|
@ -46,6 +46,73 @@
|
|||
(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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue