(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
(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)
(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)
(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"))
(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."
(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
projects / emacs.git / commitdiff