feature/android ed2f8c660bf: Merge remote-tracking branch 'origin/master' into feature/android

[Po Lu]

branch: feature/android
commit ed2f8c660bf501726e687552b56911283d637271
Merge: a94e9f96448 c4e038c7be3
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>

    Merge remote-tracking branch 'origin/master' into feature/android
---
 lisp/arc-mode.el            | 76 ++++++++++++++++++++++++++++++++------------
 lisp/emacs-lisp/gv.el       |  2 +-
 lisp/vc/vc-cvs.el           | 77 +++++++++++++++++++++++----------------------
 test/lisp/arc-mode-tests.el | 67 +++++++++++++++++++++++++++++++++++++++
 4 files changed, 164 insertions(+), 58 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 @@ 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."
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 6c3036da2f2..a5e29dd5e3b 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -641,7 +641,7 @@ REF must have been previously obtained with `gv-ref'."
 
 ;; You'd think noone would write `(setf (error ...) ..)' but it
 ;; appears naturally as the result of macroexpansion of things like
-;; (setf (case-exhaustive ...)).
+;; (setf (pcase-exhaustive ...)).
 ;; We could generalize this to `throw' and `signal', but it seems
 ;; preferable to wait until there's a concrete need.
 (gv-define-expander error (lambda (_do &rest args) `(error . ,args)))
diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el
index b855591e655..145697d1b06 100644
--- a/lisp/vc/vc-cvs.el
+++ b/lisp/vc/vc-cvs.el
@@ -816,7 +816,7 @@ individually should stay local."
 (defun vc-cvs-repository-hostname (dirname)
   "Hostname of the CVS server associated to workarea DIRNAME.
 
-Returns nil if there is no hostname or the hostname could not be
+Return nil if there is no hostname, or the hostname could not be
 determined because the CVS/Root specification is invalid."
   (let ((rootname (expand-file-name "CVS/Root" dirname)))
     (when (file-readable-p rootname)
@@ -836,31 +836,34 @@ determined because the CVS/Root specification is invalid."
 (cl-defun vc-cvs-parse-root (root)
   "Split CVS Root specification string into a list of fields.
 
-A CVS Root specification of the form
-  [:METHOD:][[[USER][:PASSWORD]@]HOSTNAME][:[PORT]]/pathname/to/repository
-is converted to a normalized record with the following structure:
-  \(METHOD USER HOSTNAME PATHNAME).
+Convert a CVS Root specification of the form
 
-The default METHOD for a CVS root of the form
-  /pathname/to/repository
-is \"local\".
-The default METHOD for a CVS root of the form
-  [USER@]HOSTNAME:/pathname/to/repository
-is \"ext\".
+  [:METHOD:][[[USER][:PASSWORD]@]HOSTNAME][:[PORT]]/path/to/repository
 
-If METHOD is explicitly \"local\" or \"fork\", then the pathname
-starts immediately after the method block.  This must be used on
-Windows platforms when pathnames start with a drive letter.
+to a normalized record with the following structure:
+
+  \(METHOD USER HOSTNAME FILENAME).
+
+The default METHOD for a CVS root of the form /path/to/repository
+is \"local\".  The default METHOD for a CVS root of the
+form  [USER@]HOSTNAME:/path/to/repository is \"ext\".
+
+If METHOD is explicitly \"local\" or \"fork\", then the repository's
+file name starts immediately after the [:METHOD:] part.  This must be
+used on MS-Windows platforms where absolute file names start with a
+drive letter.
 
 Note that, except for METHOD, which is defaulted if not present,
-other optional fields are returned as nil if not syntactically
-present, or as the empty string if delimited but empty.
-
-Returns nil in case of an unparsable CVS root (including the
-empty string) and issues a warning.  This function doesn't check
-that an explicit method is valid, or that some fields are empty
-or nil but should not be for a given method."
-  (let (method user password hostname port pathname
+other optional parts will default to nil if not syntactically
+present, or to an empty string if present and delimited, but empty.
+
+Return nil in case of an unparsable CVS Root (including the
+empty string), and issue a warning in that case.
+
+This function doesn't check that an explicit method is valid, or
+that some fields which should not be empty for a given method,
+are empty or nil."
+  (let (method user password hostname port filename
                ;; IDX set by `next-delim' as a side-effect
                idx)
     (cl-labels
@@ -869,21 +872,21 @@ or nil but should not be for a given method."
                   (concat "vc-cvs-parse-root: Can't parse '%s': " reason)
                   root args)
            (cl-return-from vc-cvs-parse-root))
-         (no-pathname ()
-           (invalid "No pathname"))
+         (no-filename ()
+           (invalid "No repository file name"))
          (next-delim (start)
            ;; Search for a :, @ or /.  If none is found, there can be
-           ;; no path at the end, which is an error.
+           ;; no file name at the end, which is an error.
            (setq idx (string-match-p "[:@/]" root start))
-           (if idx (aref root idx) (no-pathname)))
+           (if idx (aref root idx) (no-filename)))
          (grab-user (start end)
            (setq user (substring root start end)))
          (at-hostname-block (start)
            (let ((cand (next-delim start)))
              (cl-ecase cand
                (?:
-                ;; Could be : before PORT and PATHNAME, or before
-                ;; PASSWORD.  We search for a @ to disambiguate.
+                ;; Could be : before PORT and /path/to/repository, or
+                ;; before PASSWORD.  We search for a @ to disambiguate.
                 (let ((colon-idx idx)
                       (cand (next-delim (1+ idx))))
                   (cl-ecase cand
@@ -907,7 +910,7 @@ or nil but should not be for a given method."
                (?/
                 (if (/= idx start)
                     (grab-hostname start idx))
-                (at-pathname idx)))))
+                (at-filename idx)))))
          (delimited-password (start end)
            (setq password (substring root start end))
            (at-hostname (1+ end)))
@@ -923,17 +926,17 @@ or nil but should not be for a given method."
                 (invalid "Hostname: Unexpected @ after index %s" start))
                (?/
                 (grab-hostname start idx)
-                (at-pathname idx)))))
+                (at-filename idx)))))
          (delimited-port (start end)
            (setq port (substring root start end))
-           (at-pathname end))
+           (at-filename end))
          (at-port (start)
            (let ((end (string-match-p "/" root start)))
-             (if end (delimited-port start end) (no-pathname))))
-         (at-pathname (start)
-           (setq pathname (substring root start))))
+             (if end (delimited-port start end) (no-filename))))
+         (at-filename (start)
+           (setq filename (substring root start))))
       (when (string= root "")
-        (invalid "Empty string"))
+        (invalid "Empty Root string"))
       ;; Check for a starting ":"
       (if (= (aref root 0) ?:)
           ;; 3 possible cases:
@@ -948,7 +951,7 @@ or nil but should not be for a given method."
                (setq method (substring root 1 idx))
                ;; Continue
                (if (member method '("local" "fork"))
-                   (at-pathname (1+ idx))
+                   (at-filename (1+ idx))
                  (at-hostname-block (1+ idx))))
               (?@
                ;; :PASSWORD@HOSTNAME case
@@ -962,7 +965,7 @@ or nil but should not be for a given method."
       ;; Default the method if not specified
       (setq method
             (if (or user password hostname port) "ext" "local")))
-    (list method user hostname pathname)))
+    (list method user hostname filename)))
 
 ;; XXX: This does not work correctly for subdirectories.  "cvs status"
 ;; information is context sensitive, it contains lines like:
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 @@
       (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