diff options
Diffstat (limited to 'lisp/shadowfile.el')
| -rw-r--r-- | lisp/shadowfile.el | 139 |
1 files changed, 60 insertions, 79 deletions
diff --git a/lisp/shadowfile.el b/lisp/shadowfile.el index a4f0eba4449..f67b0b9b39c 100644 --- a/lisp/shadowfile.el +++ b/lisp/shadowfile.el @@ -1,4 +1,4 @@ -;;; shadowfile.el --- automatic file copying +;;; shadowfile.el --- automatic file copying -*- lexical-binding: t; -*- ;; Copyright (C) 1993-1994, 2001-2021 Free Software Foundation, Inc. @@ -90,27 +90,23 @@ "If t, always copy shadow files without asking. If nil (the default), always ask. If not nil and not t, ask only if there is no buffer currently visiting the file." - :type '(choice (const t) (const nil) (other :tag "Ask if no buffer" maybe)) - :group 'shadow) + :type '(choice (const t) (const nil) (other :tag "Ask if no buffer" maybe))) (defcustom shadow-inhibit-message nil "If non-nil, do not display a message when a file needs copying." - :type 'boolean - :group 'shadow) + :type 'boolean) (defcustom shadow-inhibit-overload nil "If non-nil, shadowfile won't redefine \\[save-buffers-kill-emacs]. Normally it overloads the function `save-buffers-kill-emacs' to check for files that have been changed and need to be copied to other systems." - :type 'boolean - :group 'shadow) + :type 'boolean) (defcustom shadow-info-file (locate-user-emacs-file "shadows" ".shadows") "File to keep shadow information in. The `shadow-info-file' should be shadowed to all your accounts to ensure consistency. Default: ~/.emacs.d/shadows" :type 'file - :group 'shadow :version "26.2") (defcustom shadow-todo-file @@ -122,18 +118,17 @@ remember and ask you again in your next Emacs session. This file must NOT be shadowed to any other system, it is host-specific. Default: ~/.emacs.d/shadow_todo" :type 'file - :group 'shadow :version "26.2") -;;; The following two variables should in most cases initialize themselves -;;; correctly. They are provided as variables in case the defaults are wrong -;;; on your machine (and for efficiency). +;; The following two variables should in most cases initialize themselves +;; correctly. They are provided as variables in case the defaults are wrong +;; on your machine (and for efficiency). (defvar shadow-system-name (concat "/" (system-name) ":") "The identification for local files on this machine.") -(defvar shadow-homedir "~" +(defvar shadow-homedir "~/" "Your home directory on this machine.") ;;; @@ -160,7 +155,7 @@ created by `shadow-define-regexp-group'.") (defvar shadow-files-to-copy nil) ; List of files that need to ; be copied to remote hosts. -(defvar shadow-hashtable nil) ; for speed +(defvar shadow-hashtable (make-hash-table :test #'equal)) ; for speed (defvar shadow-info-buffer nil) ; buf visiting shadow-info-file (defvar shadow-todo-buffer nil) ; buf visiting shadow-todo-file @@ -172,20 +167,6 @@ created by `shadow-define-regexp-group'.") ;;; Syntactic sugar; General list and string manipulation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun shadow-union (a b) - "Add members of list A to list B if not equal to items already in B." - (if (null a) - b - (if (member (car a) b) - (shadow-union (cdr a) b) - (shadow-union (cdr a) (cons (car a) b))))) - -(defun shadow-find (func list) - "If FUNC applied to some element of LIST is non-nil, return first such element." - (while (and list (not (funcall func (car list)))) - (setq list (cdr list))) - (car list)) - (defun shadow-regexp-superquote (string) "Like `regexp-quote', but includes the \\` and \\'. This makes sure regexp matches nothing but STRING." @@ -205,11 +186,11 @@ PREFIX." ;;; Clusters and sites ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; I use the term `site' to refer to a string which may be the -;;; cluster identification "/name:", a remote identification -;;; "/method:user@host:", or "/system-name:" (the value of -;;; `shadow-system-name') for the location of local files. All -;;; user-level commands should accept either. +;; I use the term `site' to refer to a string which may be the +;; cluster identification "/name:", a remote identification +;; "/method:user@host:", or "/system-name:" (the value of +;; `shadow-system-name') for the location of local files. All +;; user-level commands should accept either. (cl-defstruct (shadow-cluster (:type list) :named) name primary regexp) @@ -226,7 +207,7 @@ information defining the cluster. For interactive use, call (defun shadow-get-cluster (name) "Return cluster named NAME, or nil." - (shadow-find + (seq-find (lambda (x) (string-equal (shadow-cluster-name x) name)) shadow-clusters)) @@ -252,7 +233,7 @@ information defining the cluster. For interactive use, call (defun shadow-site-cluster (site) "Given a SITE, return cluster it is in, or nil." (or (shadow-get-cluster (shadow-site-name site)) - (shadow-find + (seq-find (lambda (x) (string-match (shadow-cluster-regexp x) (shadow-name-site site))) shadow-clusters))) @@ -303,9 +284,13 @@ Argument can be a simple name, remote file name, or already a (defsubst shadow-make-fullname (hup &optional host name) "Make a Tramp style fullname out of HUP, a `tramp-file-name' structure. -Replace HOST, and NAME when non-nil." +Replace HOST, and NAME when non-nil. HOST can also be a remote file name." (let ((hup (copy-tramp-file-name hup))) - (when host (setf (tramp-file-name-host hup) host)) + (when host + (if (file-remote-p host) + (setq name (or name (and hup (tramp-file-name-localname hup))) + hup (tramp-dissect-file-name (file-remote-p host))) + (setf (tramp-file-name-host hup) host))) (when name (setf (tramp-file-name-localname hup) name)) (if (null (tramp-file-name-method hup)) (format @@ -367,15 +352,16 @@ Will return the name bare if it is a local file." (defun shadow-contract-file-name (file) "Simplify FILE. -Do so by replacing (when possible) home directory with ~, and hostname -with cluster name that includes it. Filename should be absolute and -true." +Do so by replacing (when possible) home directory with ~/, and +hostname with cluster name that includes it. Filename should be +absolute and true." (let* ((hup (shadow-parse-name file)) (homedir (if (shadow-local-file hup) shadow-homedir (file-name-as-directory (file-local-name - (expand-file-name (shadow-make-fullname hup nil "~")))))) + (expand-file-name + (shadow-make-fullname hup nil shadow-homedir)))))) (suffix (shadow-suffix homedir (tramp-file-name-localname hup))) (cluster (shadow-site-cluster (shadow-make-fullname hup nil "")))) (when cluster @@ -384,7 +370,7 @@ true." (shadow-make-fullname hup nil (if suffix - (concat "~/" suffix) + (concat shadow-homedir suffix) (tramp-file-name-localname hup))))) (defun shadow-same-site (pattern file) @@ -594,7 +580,7 @@ be shadowed), and list of SITES." Filename should have clusters expanded, but otherwise can have any format. Return value is a list of dotted pairs like (from . to), where from and to are absolute file names." - (or (symbol-value (intern-soft file shadow-hashtable)) + (or (gethash file shadow-hashtable) (let* ((absolute-file (shadow-expand-file-name (or (shadow-local-file file) file) shadow-homedir)) @@ -612,7 +598,7 @@ and to are absolute file names." "shadow-shadows-of: %s %s %s %s %s" file (shadow-local-file file) shadow-homedir absolute-file canonical-file)) - (set (intern file shadow-hashtable) shadows)))) + (puthash file shadows shadow-hashtable)))) (defun shadow-shadows-of-1 (file groups regexp) "Return list of FILE's shadows in GROUPS. @@ -653,7 +639,7 @@ Consider them as regular expressions if third arg REGEXP is true." shadows shadow-files-to-copy (with-output-to-string (backtrace)))) (when shadows (setq shadow-files-to-copy - (shadow-union shadows shadow-files-to-copy)) + (nreverse (cl-union shadows shadow-files-to-copy :test #'equal))) (when (not shadow-inhibit-message) (message "%s" (substitute-command-keys "Use \\[shadow-copy-files] to update shadows.")) @@ -749,7 +735,7 @@ With non-nil argument also saves the buffer." (sit-for 1)))))) (defun shadow-invalidate-hashtable () - (setq shadow-hashtable (make-vector 37 0))) + (clrhash shadow-hashtable)) (defun shadow-insert-var (variable) "Build a `setq' to restore VARIABLE. @@ -758,17 +744,17 @@ will restore VARIABLE to its current setting. VARIABLE must be the name of a variable whose value is a list." (let ((standard-output (current-buffer))) (insert (format "(setq %s" variable)) - (cond ((consp (eval variable)) + (cond ((consp (symbol-value variable)) (insert "\n '(") - (prin1 (car (eval variable))) - (let ((rest (cdr (eval variable)))) + (prin1 (car (symbol-value variable))) + (let ((rest (cdr (symbol-value variable)))) (while rest (insert "\n ") (prin1 (car rest)) (setq rest (cdr rest))) (insert "))\n\n"))) (t (insert " ") - (prin1 (eval variable)) + (prin1 (symbol-value variable)) (insert ")\n\n"))))) (defun shadow-save-buffers-kill-emacs (&optional arg) @@ -777,6 +763,11 @@ With prefix arg, silently save all file-visiting buffers, then kill. Extended by shadowfile to automatically save `shadow-todo-file' and look for files that have been changed and need to be copied to other systems." + (interactive "P") + (shadow--save-buffers-kill-emacs arg) + (save-buffers-kill-emacs arg)) + +(defun shadow--save-buffers-kill-emacs (&optional arg &rest _) ;; This function is necessary because we need to get control and save ;; the todo file /after/ saving other files, but /before/ the warning ;; message about unsaved buffers (because it can get modified by the @@ -784,27 +775,10 @@ look for files that have been changed and need to be copied to other systems." ;; because it is not called at the correct time, and also because it is ;; called when the terminal is disconnected and we cannot ask whether ;; to copy files. - (interactive "P") (shadow-save-todo-file) (save-some-buffers arg t) (shadow-copy-files) - (shadow-save-todo-file) - (and (or (not (memq t (mapcar (lambda (buf) (and (buffer-file-name buf) - (buffer-modified-p buf))) - (buffer-list)))) - (yes-or-no-p "Modified buffers exist; exit anyway? ")) - (or (not (fboundp 'process-list)) - ;; `process-list' is not defined on MSDOS. - (let ((processes (process-list)) - active) - (while processes - (and (memq (process-status (car processes)) '(run stop open listen)) - (process-query-on-exit-flag (car processes)) - (setq active t)) - (setq processes (cdr processes))) - (or (not active) - (yes-or-no-p "Active processes exist; kill them and exit anyway? ")))) - (kill-emacs))) + (shadow-save-todo-file)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Hook us up @@ -823,22 +797,29 @@ look for files that have been changed and need to be copied to other systems." (message "Shadowfile information files not found - aborting") (beep) (sit-for 3)) - (when (and (not shadow-inhibit-overload) - (not (fboundp 'shadow-orig-save-buffers-kill-emacs))) - (defalias 'shadow-orig-save-buffers-kill-emacs - (symbol-function 'save-buffers-kill-emacs)) - (defalias 'save-buffers-kill-emacs 'shadow-save-buffers-kill-emacs)) - (add-hook 'write-file-functions 'shadow-add-to-todo) - (define-key ctl-x-4-map "s" 'shadow-copy-files))) + (unless shadow-inhibit-overload + (advice-add 'save-buffers-kill-emacs :before + #'shadow--save-buffers-kill-emacs)) + (add-hook 'write-file-functions #'shadow-add-to-todo) + (define-key ctl-x-4-map "s" #'shadow-copy-files))) (defun shadowfile-unload-function () - (substitute-key-definition 'shadow-copy-files nil ctl-x-4-map) - (when (fboundp 'shadow-orig-save-buffers-kill-emacs) - (fset 'save-buffers-kill-emacs - (symbol-function 'shadow-orig-save-buffers-kill-emacs))) + (substitute-key-definition #'shadow-copy-files nil ctl-x-4-map) + (advice-remove 'save-buffers-kill-emacs #'shadow--save-buffers-kill-emacs) ;; continue standard unloading nil) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Obsolete +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun shadow-union (a b) + "Add members of list A to list B if not equal to items already in B." + (declare (obsolete cl-union "28.1")) + (nreverse (cl-union a b :test #'equal))) + +(define-obsolete-function-alias 'shadow-find #'seq-find "28.1") + (provide 'shadowfile) ;;; shadowfile.el ends here |