procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Po Lu 2023-04-21 08:32:44 +08:00
commit ed2f8c660b
4 changed files with 163 additions and 57 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

76
lisp/arc-mode.el
View file

@ -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."

2
lisp/emacs-lisp/gv.el
View file

@ -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)))

75
lisp/vc/vc-cvs.el
View file

@ -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.
other optional parts will default to nil if not syntactically
present, or to an empty string if present and 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
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:

67
test/lisp/arc-mode-tests.el
View 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