andros/emacs-gpu
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Improve robustness of shadowfile.el

Browse source 
* lisp/shadowfile.el (shadow-site-help): New defconst.
(shadow-read-site): Use it.
(shadow-make-fullname, shadow-contract-file-name)
(shadow-define-literal-group): Handle errors more robust.  (Bug#49596)

* test/lisp/shadowfile-tests.el (shadow-test06-literal-groups):
Extend test.
This commit is contained in:
Michael Albinus 2021-08-26 13:14:19 +02:00
parent fbf2933e69
commit e5f82c1305
2 changed files with 64 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

72
lisp/shadowfile.el
View file

@ -213,6 +213,14 @@ information defining the cluster. For interactive use, call
;;; SITES ;;; SITES
;; This simplifies it a little bit. "system-name" is also accepted.
;; But we don't want to make the help echo too long.
(defconst shadow-site-help "\
A cluster identification \"/name:\", a remote identification
\"/method:user@host:\", or \"/system-name:\" (the value of
`shadow-system-name')"
"The help string describing a valid site.")
(defun shadow-site-name (site) (defun shadow-site-name (site)
"Return name if SITE has the form \"/name:\", otherwise SITE." "Return name if SITE has the form \"/name:\", otherwise SITE."
(if (string-match "\\`/\\([-.[:word:]]+\\):\\'" site) (if (string-match "\\`/\\([-.[:word:]]+\\):\\'" site)
@ -239,9 +247,10 @@ information defining the cluster. For interactive use, call
shadow-clusters))) shadow-clusters)))
(defun shadow-read-site () (defun shadow-read-site ()
"Read a cluster name or host identification from the minibuffer." "Read a site name from the minibuffer."
(let ((ans (completing-read "Host identification or cluster name: " (let ((ans (completing-read
shadow-clusters))) (propertize "Site name: " 'help-echo shadow-site-help)
shadow-clusters)))
(when (or (shadow-get-cluster (shadow-site-name ans)) (when (or (shadow-get-cluster (shadow-site-name ans))
(string-equal ans shadow-system-name) (string-equal ans shadow-system-name)
(string-equal ans (shadow-site-name shadow-system-name)) (string-equal ans (shadow-site-name shadow-system-name))
@ -285,7 +294,7 @@ Argument can be a simple name, remote file name, or already a
(defsubst shadow-make-fullname (hup &optional host name) (defsubst shadow-make-fullname (hup &optional host name)
"Make a Tramp style fullname out of HUP, a `tramp-file-name' structure. "Make a Tramp style fullname out of HUP, a `tramp-file-name' structure.
Replace HOST, and NAME when non-nil. HOST can also be a remote file name." Replace HOST, and NAME when non-nil. HOST can also be a remote file name."
(let ((hup (copy-tramp-file-name hup))) (when-let ((hup (copy-tramp-file-name hup)))
(when host (when host
(if (file-remote-p host) (if (file-remote-p host)
(setq name (or name (and hup (tramp-file-name-localname hup))) (setq name (or name (and hup (tramp-file-name-localname hup)))
@ -355,23 +364,23 @@ Will return the name bare if it is a local file."
Do so by replacing (when possible) home directory with ~/, and Do so by replacing (when possible) home directory with ~/, and
hostname with cluster name that includes it. Filename should be hostname with cluster name that includes it. Filename should be
absolute and true." absolute and true."
(let* ((hup (shadow-parse-name file)) (when-let ((hup (shadow-parse-name file)))
(homedir (if (shadow-local-file hup) (let* ((homedir (if (shadow-local-file hup)
shadow-homedir shadow-homedir
(file-name-as-directory (file-name-as-directory
(file-local-name (file-local-name
(expand-file-name (expand-file-name
(shadow-make-fullname hup nil shadow-homedir)))))) (shadow-make-fullname hup nil shadow-homedir))))))
(suffix (shadow-suffix homedir (tramp-file-name-localname hup))) (suffix (shadow-suffix homedir (tramp-file-name-localname hup)))
(cluster (shadow-site-cluster (shadow-make-fullname hup nil "")))) (cluster (shadow-site-cluster (shadow-make-fullname hup nil ""))))
(when cluster (when cluster
(setf (tramp-file-name-method hup) nil (setf (tramp-file-name-method hup) nil
(tramp-file-name-host hup) (shadow-cluster-name cluster))) (tramp-file-name-host hup) (shadow-cluster-name cluster)))
(shadow-make-fullname (shadow-make-fullname
hup nil hup nil
(if suffix (if suffix
(concat shadow-homedir suffix) (concat shadow-homedir suffix)
(tramp-file-name-localname hup))))) (tramp-file-name-localname hup))))))
(defun shadow-same-site (pattern file) (defun shadow-same-site (pattern file)
"True if the site of PATTERN and of FILE are on the same site. "True if the site of PATTERN and of FILE are on the same site.
@ -455,16 +464,17 @@ It may have different filenames on each site. When this file is edited, the
new version will be copied to each of the other locations. Sites can be new version will be copied to each of the other locations. Sites can be
specific hostnames, or names of clusters (see `shadow-define-cluster')." specific hostnames, or names of clusters (see `shadow-define-cluster')."
(interactive) (interactive)
(let* ((hup (shadow-parse-name (when-let ((hup (shadow-parse-name
(shadow-contract-file-name (buffer-file-name)))) (shadow-contract-file-name (buffer-file-name)))))
(name (tramp-file-name-localname hup)) (let* ((name (tramp-file-name-localname hup))
site group) site group)
(while (setq site (shadow-read-site)) (while (setq site (shadow-read-site))
(setq name (read-string "Filename: " name) (setq name (read-string "Filename: " name)
hup (shadow-parse-name (shadow-contract-file-name name)) hup (shadow-parse-name (shadow-contract-file-name name))
group (cons (shadow-make-fullname hup site) group))) group (cons (shadow-make-fullname hup site) group)))
(setq shadow-literal-groups (cons group shadow-literal-groups))) (when group
(shadow-write-info-file)) (setq shadow-literal-groups (cons group shadow-literal-groups))))
(shadow-write-info-file)))
;;;###autoload ;;;###autoload
(defun shadow-define-regexp-group () (defun shadow-define-regexp-group ()

24
test/lisp/shadowfile-tests.el
View file

@ -664,7 +664,29 @@ guaranteed by the originator of a cluster definition."
(should (member (format "/%s:%s" cluster2 (file-local-name file2)) (should (member (format "/%s:%s" cluster2 (file-local-name file2))
(car shadow-literal-groups))) (car shadow-literal-groups)))
;; Bug#49596. ;; Bug#49596.
(should (member (concat primary file1) (car shadow-literal-groups)))) (should (member (concat primary file1) (car shadow-literal-groups)))
;; Error handling.
(setq shadow-literal-groups nil)
;; There's no `buffer-file-name'.
(with-temp-buffer
(call-interactively #'shadow-define-literal-group)
(set-buffer-modified-p nil))
(should-not shadow-literal-groups)
;; Define an empty literal group.
(setq mocked-input `(,(kbd "RET")))
(with-temp-buffer
(set-visited-file-name file1)
(call-interactively #'shadow-define-literal-group)
(set-buffer-modified-p nil))
(should-not shadow-literal-groups)
;; Use a non-existing site name.
(setq mocked-input `("foo" ,(kbd "RET")))
(with-temp-buffer
(set-visited-file-name file1)
(call-interactively #'shadow-define-literal-group)
(set-buffer-modified-p nil))
(should-not shadow-literal-groups))
;; Cleanup. ;; Cleanup.
(shadow--tests-cleanup)))) (shadow--tests-cleanup))))