lisp/shadowfile.el

   1 ;;; shadowfile.el --- automatic file copying
   2
   3 ;; Copyright (C) 1993-1994, 2001-2018 Free Software Foundation, Inc.
   4
   5 ;; Author: Boris Goldowsky <boris@gnu.org>
   6 ;; Keywords: comm files
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;  This package helps you to keep identical copies of files in more than one
  26 ;;  place - possibly on different machines.  When you save a file, it checks
  27 ;;  whether it is on the list of files with "shadows", and if so, it tries to
  28 ;;  copy it when you exit Emacs (or use the `shadow-copy-files' command).
  29
  30 ;; Installation & Use:
  31
  32 ;;  Add clusters (if necessary) and file groups with `shadow-define-cluster',
  33 ;;  `shadow-define-literal-group', and `shadow-define-regexp-group' (see the
  34 ;;  documentation for these functions for information on how and when to use
  35 ;;  them).  After doing this once, everything should be automatic.
  36
  37 ;;  The lists of clusters and shadows are saved in `shadow-info-file',
  38 ;;  so that they can be remembered from one Emacs session to another,
  39 ;;  even (as much as possible) if the Emacs session terminates
  40 ;;  abnormally.  The files needing to be copied are stored in
  41 ;;  `shadow-todo-file'; if a file cannot be copied for any reason, it
  42 ;;  will stay on the list to be tried again next time.  The
  43 ;;  `shadow-info-file' file should itself have shadows on all your
  44 ;;  accounts so that the information in it is consistent everywhere,
  45 ;;  but `shadow-todo-file' is local information and should have no
  46 ;;  shadows.
  47
  48 ;;  If you do not want to copy a particular file, you can answer "no" and
  49 ;;  be asked again next time you hit "C-x 4 s" or exit Emacs.  If you do not
  50 ;;  want to be asked again, use "M-x shadow-cancel", and you will not be asked
  51 ;;  until you change the file and save it again.  If you do not want to
  52 ;;  shadow that file ever again, you can edit it out of the shadows
  53 ;;  buffer.  Anytime you edit the shadows buffer, you must type "M-x
  54 ;;  shadow-read-files" to load in the new information, or your changes will
  55 ;;  be overwritten!
  56
  57 ;; Bugs & Warnings:
  58 ;;
  59 ;;  - It is bad to have two Emacsen both running shadowfile at the same
  60 ;;  time.  It tries to detect this condition, but is not always successful.
  61 ;;
  62 ;;  - You have to be careful not to edit a file in two locations
  63 ;;  before shadowfile has had a chance to copy it; otherwise
  64 ;;  "updating shadows" will overwrite one of the changed versions.
  65 ;;
  66 ;;  - It ought to check modification times of both files to make sure
  67 ;;  it is doing the right thing.  This will have to wait until
  68 ;;  `file-newer-than-file-p' works between machines.
  69 ;;
  70 ;;  - It will not make directories for you, it just fails to copy files
  71 ;;  that belong in non-existent directories.
  72
  73
  74 ;;; Code:
  75
  76 (require 'cl-lib)
  77 (require 'tramp)
  78
  79 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  80 ;;; Variables
  81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82
  83 (defgroup shadow nil
  84   "Automatic file copying when saving a file."
  85   :prefix "shadow-"
  86   :link '(emacs-commentary-link "shadowfile")
  87   :group 'files)
  88
  89 (defcustom shadow-noquery nil
  90   "If t, always copy shadow files without asking.
  91 If nil (the default), always ask.  If not nil and not t, ask only if there
  92 is no buffer currently visiting the file."
  93   :type '(choice (const t) (const nil) (other :tag "Ask if no buffer" maybe))
  94   :group 'shadow)
  95
  96 (defcustom shadow-inhibit-message nil
  97   "If non-nil, do not display a message when a file needs copying."
  98   :type 'boolean
  99   :group 'shadow)
 100
 101 (defcustom shadow-inhibit-overload nil
 102   "If non-nil, shadowfile won't redefine \\[save-buffers-kill-emacs].
 103 Normally it overloads the function `save-buffers-kill-emacs' to check for
 104 files that have been changed and need to be copied to other systems."
 105   :type 'boolean
 106   :group 'shadow)
 107
 108 (defcustom shadow-info-file (locate-user-emacs-file "shadows" ".shadows")
 109   "File to keep shadow information in.
 110 The `shadow-info-file' should be shadowed to all your accounts to
 111 ensure consistency.  Default: ~/.emacs.d/shadows"
 112   :type 'file
 113   :group 'shadow
 114   :version "26.2")
 115
 116 (defcustom shadow-todo-file
 117   (locate-user-emacs-file "shadow_todo" ".shadow_todo")
 118   "File to store the list of uncopied shadows in.
 119 This means that if a remote system is down, or for any reason you cannot or
 120 decide not to copy your shadow files at the end of one Emacs session, it will
 121 remember and ask you again in your next Emacs session.
 122 This file must NOT be shadowed to any other system, it is host-specific.
 123 Default: ~/.emacs.d/shadow_todo"
 124   :type 'file
 125   :group 'shadow
 126   :version "26.2")
 127
 128
 129 ;;; The following two variables should in most cases initialize themselves
 130 ;;; correctly.  They are provided as variables in case the defaults are wrong
 131 ;;; on your machine (and for efficiency).
 132
 133 (defvar shadow-system-name (concat "/" (system-name) ":")
 134   "The identification for local files on this machine.")
 135
 136 (defvar shadow-homedir "~"
 137   "Your home directory on this machine.")
 138
 139 ;;;
 140 ;;; Internal variables whose values are stored in the info and todo files:
 141 ;;;
 142
 143 (defvar shadow-clusters nil
 144   "List of host clusters (see `shadow-define-cluster').")
 145
 146 (defvar shadow-literal-groups nil
 147   "List of files that are shared between hosts.
 148 This list contains shadow structures with literal filenames, created by
 149 `shadow-define-literal-group'.")
 150
 151 (defvar shadow-regexp-groups nil
 152   "List of file types that are shared between hosts.
 153 This list contains shadow structures with regexps matching filenames,
 154 created by `shadow-define-regexp-group'.")
 155
 156 ;;;
 157 ;;; Other internal variables:
 158 ;;;
 159
 160 (defvar shadow-files-to-copy nil)       ; List of files that need to
 161                                         ; be copied to remote hosts.
 162
 163 (defvar shadow-hashtable nil)           ; for speed
 164
 165 (defvar shadow-info-buffer nil)         ; buf visiting shadow-info-file
 166 (defvar shadow-todo-buffer nil)         ; buf visiting shadow-todo-file
 167
 168 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 169 ;;; Syntactic sugar; General list and string manipulation
 170 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 171
 172 (defun shadow-union (a b)
 173   "Add members of list A to list B if not equal to items already in B."
 174   (if (null a)
 175       b
 176     (if (member (car a) b)
 177         (shadow-union (cdr a) b)
 178       (shadow-union (cdr a) (cons (car a) b)))))
 179
 180 (defun shadow-find (func list)
 181   "If FUNC applied to some element of LIST is non-nil, return first such element."
 182   (while (and list (not (funcall func (car list))))
 183     (setq list (cdr list)))
 184   (car list))
 185
 186 (defun shadow-regexp-superquote (string)
 187   "Like `regexp-quote', but includes the \\` and \\'.
 188 This makes sure regexp matches nothing but STRING."
 189   (concat "\\`" (regexp-quote string) "\\'"))
 190
 191 (defun shadow-suffix (prefix string)
 192   "If PREFIX begins with STRING, return the rest.
 193 Return value is non-nil if PREFIX and STRING are `string=' up to the length of
 194 PREFIX."
 195   (let ((lp (length prefix))
 196         (ls (length string)))
 197     (if (and (>= ls lp)
 198              (string= prefix (substring string 0 lp)))
 199         (substring string lp))))
 200
 201 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 202 ;;; Clusters and sites
 203 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 204
 205 ;;; I use the term `site' to refer to a string which may be the
 206 ;;; cluster identification "/name:", a remote identification
 207 ;;; "/method:user@host:", or "/system-name:' (the value of
 208 ;;; `shadow-system-name') for the location of local files.  All
 209 ;;; user-level commands should accept either.
 210
 211 (cl-defstruct (shadow-cluster (:type list) :named) name primary regexp)
 212
 213 (defun shadow-set-cluster (name primary regexp)
 214   "Put cluster NAME on the list of clusters.
 215 Replace old definition, if any.  PRIMARY and REGEXP are the
 216 information defining the cluster.  For interactive use, call
 217 `shadow-define-cluster' instead."
 218   (let ((rest (cl-remove-if (lambda (x) (equal name (shadow-cluster-name x)))
 219                             shadow-clusters)))
 220     (setq shadow-clusters
 221           (cons (make-shadow-cluster :name name :primary primary :regexp regexp)
 222                 rest))))
 223
 224 (defun shadow-get-cluster (name)
 225   "Return cluster named NAME, or nil."
 226   (shadow-find
 227    (lambda (x) (string-equal (shadow-cluster-name x) name))
 228    shadow-clusters))
 229
 230 ;;; SITES
 231
 232 (defun shadow-site-name (site)
 233   "Return name if SITE has the form \"/name:\", otherwise SITE."
 234   (if (string-match "\\`/\\([-.[:word:]]+\\):\\'" site)
 235       (match-string 1 site) site))
 236
 237 (defun shadow-name-site (name)
 238   "Return \"/name:\" if NAME has word syntax, otherwise NAME."
 239   (if (string-match "\\`[-.[:word:]]+\\'" name)
 240       (format "/%s:"name) name))
 241
 242 (defun shadow-site-primary (site)
 243   "If SITE is a cluster, return primary identification, otherwise return SITE."
 244   (let ((cluster (shadow-get-cluster (shadow-site-name site))))
 245     (if cluster
 246         (shadow-cluster-primary cluster)
 247       site)))
 248
 249 (defun shadow-site-cluster (site)
 250   "Given a SITE, return cluster it is in, or nil."
 251   (or (shadow-get-cluster (shadow-site-name site))
 252       (shadow-find
 253        (lambda (x)
 254          (string-match (shadow-cluster-regexp x) (shadow-name-site site)))
 255        shadow-clusters)))
 256
 257 (defun shadow-read-site ()
 258   "Read a cluster name or host identification from the minibuffer."
 259   (let ((ans (completing-read "Host identification or cluster name: "
 260                               shadow-clusters)))
 261     (when (or (shadow-get-cluster (shadow-site-name ans))
 262               (string-equal ans shadow-system-name)
 263               (string-equal ans (shadow-site-name shadow-system-name))
 264               (setq ans (file-remote-p ans)))
 265       ans)))
 266
 267 (defun shadow-site-match (site1 site2)
 268   "Non-nil if SITE1 is or includes SITE2.
 269 Each may be a host or cluster name; if they are clusters, regexp of SITE1 will
 270 be matched against the primary of SITE2."
 271   (or (string-equal site1 site2) ; quick check
 272       (let* ((cluster1 (shadow-get-cluster site1))
 273              (primary2 (shadow-site-primary site2)))
 274         (if cluster1
 275             (string-match (shadow-cluster-regexp cluster1) primary2)
 276           (string-equal site1 primary2)))))
 277
 278 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 279 ;;; Filename manipulation
 280 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 281
 282 (defun shadow-parse-name (name)
 283   "Parse any NAME into a `tramp-file-name' structure.
 284 Argument can be a simple name, remote file name, or already a
 285 `tramp-file-name' structure."
 286   (cond
 287    ((null name) nil)
 288    ((tramp-file-name-p name) name)
 289    ((file-remote-p name) (tramp-dissect-file-name name))
 290    ((shadow-local-file name)
 291     (make-tramp-file-name
 292      :host (shadow-site-name shadow-system-name)
 293      :localname (shadow-local-file name)))
 294    ;; Cluster name.
 295    ((string-match "^/\\([^:/]+\\):\\([^:]*\\)$" name)
 296     (let ((name (match-string 1 name))
 297           (file (match-string 2 name)))
 298       (when (shadow-get-cluster name)
 299         (make-tramp-file-name :host name :localname file))))))
 300
 301 (defsubst shadow-make-fullname (hup &optional host name)
 302   "Make a Tramp style fullname out of HUP, a `tramp-file-name' structure.
 303 Replace HOST, and NAME when non-nil."
 304   (let ((hup (copy-tramp-file-name hup)))
 305     (when host (setf (tramp-file-name-host hup) host))
 306     (when name (setf (tramp-file-name-localname hup) name))
 307     (if (null (tramp-file-name-method hup))
 308         (format
 309          "/%s:%s" (tramp-file-name-host hup) (tramp-file-name-localname hup))
 310       (tramp-make-tramp-file-name hup))))
 311
 312 (defun shadow-replace-name-component (fullname newname)
 313   "Return FULLNAME with the name component changed to NEWNAME."
 314   (concat (file-remote-p fullname) newname))
 315
 316 (defun shadow-local-file (file)
 317   "If FILE is not remote, return it.
 318 If it refers to a different system, return nil."
 319   (cond
 320    ((null file) nil)
 321    ;; `tramp-file-name' structure.
 322    ((and (tramp-file-name-p file) (null (tramp-file-name-method file)))
 323     (tramp-file-name-localname file))
 324    ((tramp-file-name-p file) nil)
 325    ;; Local host name.
 326    ((string-match
 327      (format "^%s\\([^:]*\\)$" (regexp-quote shadow-system-name)) file)
 328     (match-string 1 file))
 329    ;; Cluster name.
 330    ((and (string-match "^/\\([^:/]+\\):\\([^:]*\\)$" file)
 331          (shadow-get-cluster (match-string 1 file)))
 332     (let ((file (match-string 2 file))
 333           (primary
 334            (shadow-cluster-primary
 335             (shadow-get-cluster (match-string 1 file)))))
 336       (when (string-equal primary shadow-system-name) (setq primary nil))
 337       (shadow-local-file (concat primary file))))
 338    ;; Local name.
 339    ((null (file-remote-p file)) file)))
 340
 341 (defun shadow-expand-cluster-in-file-name (file)
 342   "If hostname part of FILE is a cluster, expand it to cluster's primary hostname.
 343 Will return the name bare if it is a local file."
 344   (when (stringp file)
 345     (cond
 346      ;; Local file.
 347      ((shadow-local-file file))
 348      ;; Cluster name.
 349      ((string-match "^\\(/[^:/]+:\\)[^:]*$" file)
 350       (let ((primary
 351              (save-match-data
 352                (shadow-cluster-primary
 353                 (shadow-get-cluster
 354                  (shadow-site-name (match-string 1 file)))))))
 355         (if (not primary)
 356             file
 357           (setq file (replace-match primary nil nil file 1))
 358           (or (shadow-local-file file) file))))
 359      (t file))))
 360
 361 (defun shadow-expand-file-name (file &optional default)
 362   "Expand file name and get FILE's true name."
 363   (file-truename (expand-file-name file default)))
 364
 365 (defun shadow-contract-file-name (file)
 366   "Simplify FILE.
 367 Do so by replacing (when possible) home directory with ~, and hostname
 368 with cluster name that includes it.  Filename should be absolute and
 369 true."
 370   (let* ((hup (shadow-parse-name file))
 371          (homedir (if (shadow-local-file hup)
 372                       shadow-homedir
 373                     (file-name-as-directory
 374                      (file-local-name
 375                       (expand-file-name (shadow-make-fullname hup nil "~"))))))
 376          (suffix (shadow-suffix homedir (tramp-file-name-localname hup)))
 377          (cluster (shadow-site-cluster (shadow-make-fullname hup nil ""))))
 378     (when cluster
 379       (setf (tramp-file-name-method hup) nil
 380             (tramp-file-name-host hup) (shadow-cluster-name cluster)))
 381     (shadow-make-fullname
 382      hup nil
 383      (if suffix
 384          (concat "~/" suffix)
 385        (tramp-file-name-localname hup)))))
 386
 387 (defun shadow-same-site (pattern file)
 388   "True if the site of PATTERN and of FILE are on the same site.
 389 PATTERN and FILE may be Tramp vectors, or remote file names.
 390 FILE may also be just a local filename."
 391   (let ((pattern-sup (shadow-parse-name pattern))
 392         (file-sup    (shadow-parse-name file)))
 393     (and
 394      (shadow-site-match
 395       (tramp-file-name-host pattern-sup) (tramp-file-name-host file-sup))
 396      (or (null (tramp-file-name-user pattern-sup))
 397          (string-equal
 398           (tramp-file-name-user pattern-sup)
 399           (tramp-file-name-user file-sup))))))
 400
 401 (defun shadow-file-match (pattern file &optional regexp)
 402  "Return t if PATTERN matches FILE.
 403 If REGEXP is supplied and non-nil, the file part of the pattern is a regular
 404 expression, otherwise it must match exactly.  The sites must
 405 match---see `shadow-same-site'.  The pattern must be in full Tramp format,
 406 but the file can be any valid filename.  This function does not do any
 407 filename expansion or contraction, you must do that yourself first."
 408  (let* ((pattern-sup (shadow-parse-name pattern))
 409         (file-sup (shadow-parse-name file)))
 410    (and (shadow-same-site pattern-sup file-sup)
 411         (if regexp
 412             (string-match
 413              (tramp-file-name-localname pattern-sup)
 414              (tramp-file-name-localname file-sup))
 415           (string-equal
 416            (tramp-file-name-localname pattern-sup)
 417            (tramp-file-name-localname file-sup))))))
 418
 419 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 420 ;;; User-level Commands
 421 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 422
 423 ;;;###autoload
 424 (defun shadow-define-cluster (name)
 425   "Edit (or create) the definition of a cluster NAME.
 426 This is a group of hosts that share directories, so that copying to or from
 427 one of them is sufficient to update the file on all of them.  Clusters are
 428 defined by a name, the network address of a primary host (the one we copy
 429 files to), and a regular expression that matches the hostnames of all the
 430 sites in the cluster."
 431   (interactive (list (completing-read "Cluster name: " shadow-clusters)))
 432   (let* ((old (shadow-get-cluster name))
 433          (primary (let (try-primary)
 434                     (while (not
 435                             (or
 436                              (string-equal
 437                               (setq try-primary
 438                                     (read-string
 439                                      "Primary host: "
 440                                      (if old (shadow-cluster-primary old)
 441                                        name)))
 442                               shadow-system-name)
 443                              (file-remote-p try-primary)))
 444                       (message "Not a valid primary!")
 445                       (sit-for 2))
 446                     try-primary))
 447          (regexp  (let (try-regexp)
 448                     (while (not
 449                             (string-match
 450                              (setq try-regexp
 451                                    (read-string
 452                                     "Regexp matching all host names: "
 453                                     (if old (shadow-cluster-regexp old)
 454                                       (shadow-regexp-superquote primary))))
 455                              primary))
 456                       (message "Regexp doesn't include the primary host!")
 457                       (sit-for 2))
 458                     try-regexp)))
 459     (shadow-set-cluster name primary regexp)))
 460
 461 ;;;###autoload
 462 (defun shadow-define-literal-group ()
 463   "Declare a single file to be shared between sites.
 464 It may have different filenames on each site.  When this file is edited, the
 465 new version will be copied to each of the other locations.  Sites can be
 466 specific hostnames, or names of clusters (see `shadow-define-cluster')."
 467   (interactive)
 468   (let* ((hup (shadow-parse-name
 469                (shadow-contract-file-name (buffer-file-name))))
 470          (name (tramp-file-name-localname hup))
 471          site group)
 472     (while (setq site (shadow-read-site))
 473       (setq name (read-string "Filename: " name)
 474             hup (shadow-parse-name (shadow-contract-file-name name))
 475             group (cons (shadow-make-fullname hup site) group)))
 476     (setq shadow-literal-groups (cons group shadow-literal-groups)))
 477   (shadow-write-info-file))
 478
 479 ;;;###autoload
 480 (defun shadow-define-regexp-group ()
 481   "Make each of a group of files be shared between hosts.
 482 Prompts for regular expression; files matching this are shared between a list
 483 of sites, which are also prompted for.  The filenames must be identical on all
 484 hosts (if they aren't, use `shadow-define-literal-group' instead of this
 485 function).  Each site can be either a hostname or the name of a cluster (see
 486 `shadow-define-cluster')."
 487   (interactive)
 488   (let ((regexp (read-string
 489                  "Filename regexp: "
 490                  (if (buffer-file-name)
 491                      (shadow-regexp-superquote
 492                       (file-local-name (buffer-file-name))))))
 493         site sites)
 494     (while (setq site (shadow-read-site))
 495       (setq sites (cons site sites)))
 496     (setq shadow-regexp-groups
 497           (cons (shadow-make-group regexp sites)
 498                 shadow-regexp-groups))
 499     (shadow-write-info-file)))
 500
 501 (defun shadow-shadows ()
 502   ;; Mostly for debugging.
 503   "Interactive function to display shadows of a buffer."
 504   (interactive)
 505   (let ((msg (mapconcat #'cdr (shadow-shadows-of (buffer-file-name)) " ")))
 506     (message "%s"
 507              (if (zerop (length msg))
 508                  "No shadows."
 509                msg))))
 510
 511 (defun shadow-copy-files (&optional arg)
 512   "Copy all pending shadow files.
 513 With prefix argument, copy all pending files without query.
 514 Pending copies are stored in variable `shadow-files-to-copy', and in
 515 `shadow-todo-file' if necessary.  This function is invoked by
 516 `shadow-save-buffers-kill-emacs', so it is not usually necessary to
 517 call it manually."
 518   (interactive "P")
 519   (if (not shadow-files-to-copy)
 520       (if (called-interactively-p 'interactive)
 521           (message "No files need to be shadowed."))
 522     (save-excursion
 523       (map-y-or-n-p (function
 524                      (lambda (pair)
 525                        (or arg shadow-noquery
 526                            (format "Copy shadow file %s? " (cdr pair)))))
 527                     (function shadow-copy-file)
 528                     shadow-files-to-copy
 529                     '("shadow" "shadows" "copy"))
 530       (shadow-write-todo-file t))))
 531
 532 (defun shadow-cancel ()
 533   "Cancel the instruction to copy some files.
 534 Prompts for which copy operations to cancel.  You will not be asked to copy
 535 them again, unless you make more changes to the files.  To cancel a shadow
 536 permanently, remove the group from `shadow-literal-groups' or
 537 `shadow-regexp-groups'."
 538   (interactive)
 539   (map-y-or-n-p (function (lambda (pair)
 540                             (format "Cancel copying %s to %s? "
 541                                     (car pair) (cdr pair))))
 542                 (function (lambda (pair)
 543                             (shadow-remove-from-todo pair)))
 544                 shadow-files-to-copy
 545                 '("shadow" "shadows" "cancel copy"))
 546   (message "There are %d shadows to be updated."
 547            (length shadow-files-to-copy))
 548   (shadow-write-todo-file))
 549
 550 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 551 ;;; Internal functions
 552 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 553
 554 (defun shadow-make-group (regexp sites)
 555   "Make a description of a file group---
 556 actually a list of regexp Tramp file names---from REGEXP (name of file to
 557 be shadowed), and list of SITES"
 558   (if sites
 559       (cons (shadow-make-fullname
 560              (shadow-parse-name (shadow-site-primary (car sites))) nil regexp)
 561             (shadow-make-group regexp (cdr sites)))
 562     nil))
 563
 564 (defun shadow-copy-file (s)
 565   "Copy one shadow file."
 566   (let* ((buffer
 567           (cond ((get-file-buffer
 568                   (abbreviate-file-name (shadow-expand-file-name (car s)))))
 569                 ((not (file-readable-p (car s)))
 570                  (if (y-or-n-p
 571                       (format "Cannot find file %s--cancel copy request? "
 572                               (car s)))
 573                      (shadow-remove-from-todo s))
 574                  nil)
 575                 ((or (eq t shadow-noquery)
 576                      (y-or-n-p
 577                       (format "No buffer for %s -- update shadow anyway? "
 578                               (car s))))
 579                  (find-file-noselect (car s)))))
 580          (to (shadow-expand-cluster-in-file-name (cdr s))))
 581     (when buffer
 582       (set-buffer buffer)
 583       (condition-case nil
 584           (progn
 585             (write-region nil nil to)
 586             (shadow-remove-from-todo s))
 587         (error (message "Shadow %s not updated!" (cdr s)))))))
 588
 589 (defun shadow-shadows-of (file)
 590   "Return copy operations needed to update FILE.
 591 Filename should have clusters expanded, but otherwise can have any format.
 592 Return value is a list of dotted pairs like (from . to), where from
 593 and to are absolute file names."
 594   (or (symbol-value (intern-soft file shadow-hashtable))
 595       (let* ((absolute-file (shadow-expand-file-name
 596                              (or (shadow-local-file file) file)
 597                              shadow-homedir))
 598              (canonical-file (shadow-contract-file-name absolute-file))
 599              (shadows
 600               (mapcar (function (lambda (shadow)
 601                                   (cons absolute-file shadow)))
 602                       (append
 603                        (shadow-shadows-of-1
 604                         canonical-file shadow-literal-groups nil)
 605                        (shadow-shadows-of-1
 606                         canonical-file shadow-regexp-groups t)))))
 607         (set (intern file shadow-hashtable) shadows))))
 608
 609 (defun shadow-shadows-of-1 (file groups regexp)
 610   "Return list of FILE's shadows in GROUPS.
 611 Consider them as regular expressions if third arg REGEXP is true."
 612   (if groups
 613       (let ((nonmatching
 614              (cl-remove-if (lambda (x) (shadow-file-match x file regexp))
 615                            (car groups))))
 616         (append (cond ((equal nonmatching (car groups)) nil)
 617                       (regexp
 618                        (let ((realname
 619                               (tramp-file-name-localname
 620                                (shadow-parse-name file))))
 621                          (mapcar
 622                           (function
 623                            (lambda (x)
 624                              (shadow-replace-name-component x realname)))
 625                           nonmatching)))
 626                       (t nonmatching))
 627                 (shadow-shadows-of-1 file (cdr groups) regexp)))))
 628
 629 (defun shadow-add-to-todo ()
 630   "If current buffer has shadows, add them to the list needing to be copied."
 631   (let ((shadows (shadow-shadows-of
 632                   (shadow-expand-file-name
 633                    (buffer-file-name (current-buffer))))))
 634     (when shadows
 635       (setq shadow-files-to-copy
 636             (shadow-union shadows shadow-files-to-copy))
 637       (when (not shadow-inhibit-message)
 638         (message "%s" (substitute-command-keys
 639                        "Use \\[shadow-copy-files] to update shadows."))
 640         (sit-for 1))
 641       (shadow-write-todo-file)))
 642   nil)     ; Return nil for write-file-functions
 643
 644 (defun shadow-remove-from-todo (pair)
 645   "Remove PAIR from `shadow-files-to-copy'.
 646 PAIR must be `eq' to one of the elements of that list."
 647   (setq shadow-files-to-copy
 648         (cl-remove-if (lambda (s) (eq s pair)) shadow-files-to-copy)))
 649
 650 (defun shadow-read-files ()
 651   "Visit and load `shadow-info-file' and `shadow-todo-file'.
 652 Thus restores shadowfile's state from your last Emacs session.
 653 Return t unless files were locked; then return nil."
 654   (interactive)
 655   (if (or (stringp (file-locked-p shadow-info-file))
 656           (stringp (file-locked-p shadow-todo-file)))
 657       (progn
 658         (message "Shadowfile is running in another Emacs; can't have two.")
 659         (beep)
 660         (sit-for 3)
 661         nil)
 662     (save-current-buffer
 663       (when shadow-info-file
 664         (set-buffer (setq shadow-info-buffer
 665                           (find-file-noselect shadow-info-file 'nowarn)))
 666         (when (and (not (buffer-modified-p))
 667                    (file-newer-than-file-p (make-auto-save-file-name)
 668                                            shadow-info-file))
 669           (erase-buffer)
 670           (message "Data recovered from %s."
 671                    (car (insert-file-contents (make-auto-save-file-name))))
 672           (sit-for 1))
 673         (eval-buffer))
 674       (when shadow-todo-file
 675         (set-buffer (setq shadow-todo-buffer
 676                           (find-file-noselect shadow-todo-file)))
 677         (when (and (not (buffer-modified-p))
 678                    (file-newer-than-file-p (make-auto-save-file-name)
 679                                            shadow-todo-file))
 680           (erase-buffer)
 681           (message "Data recovered from %s."
 682                    (car (insert-file-contents (make-auto-save-file-name))))
 683           (sit-for 1))
 684         (eval-buffer nil))
 685       (shadow-invalidate-hashtable))
 686     t))
 687
 688 (defun shadow-write-info-file ()
 689   "Write out information to `shadow-info-file'.
 690 Also clear `shadow-hashtable', since when there are new shadows
 691 defined, the old hashtable info is invalid."
 692   (shadow-invalidate-hashtable)
 693   (if shadow-info-file
 694       (save-current-buffer
 695         (if (not shadow-info-buffer)
 696             (setq shadow-info-buffer (find-file-noselect shadow-info-file)))
 697         (set-buffer shadow-info-buffer)
 698         (setq buffer-read-only nil)
 699         (delete-region (point-min) (point-max))
 700         (shadow-insert-var 'shadow-clusters)
 701         (shadow-insert-var 'shadow-literal-groups)
 702         (shadow-insert-var 'shadow-regexp-groups))))
 703
 704 (defun shadow-write-todo-file (&optional save)
 705   "Write out information to `shadow-todo-file'.
 706 With non-nil argument also saves the buffer."
 707   (save-excursion
 708     (if (not shadow-todo-buffer)
 709         (setq shadow-todo-buffer (find-file-noselect shadow-todo-file)))
 710     (set-buffer shadow-todo-buffer)
 711     (setq buffer-read-only nil)
 712     (delete-region (point-min) (point-max))
 713     (shadow-insert-var 'shadow-files-to-copy)
 714     (if save (shadow-save-todo-file))))
 715
 716 (defun shadow-save-todo-file ()
 717   (if (and shadow-todo-buffer (buffer-modified-p shadow-todo-buffer))
 718       (with-current-buffer shadow-todo-buffer
 719         (condition-case nil             ; have to continue even in case of
 720             (basic-save-buffer)         ; error, otherwise kill-emacs might
 721           (error                        ; not work!
 722            (message "WARNING: Can't save shadow todo file; it is locked!")
 723            (sit-for 1))))))
 724
 725 (defun shadow-invalidate-hashtable ()
 726   (setq shadow-hashtable (make-vector 37 0)))
 727
 728 (defun shadow-insert-var (variable)
 729   "Build a `setq' to restore VARIABLE.
 730 Prettily insert a `setq' command which, when later evaluated,
 731 will restore VARIABLE to its current setting.
 732 VARIABLE must be the name of a variable whose value is a list."
 733   (let ((standard-output (current-buffer)))
 734     (insert (format "(setq %s" variable))
 735     (cond ((consp (eval variable))
 736            (insert "\n  '(")
 737            (prin1 (car (eval variable)))
 738            (let ((rest (cdr (eval variable))))
 739              (while rest
 740                (insert "\n    ")
 741                (prin1 (car rest))
 742                (setq rest (cdr rest)))
 743              (insert "))\n\n")))
 744           (t (insert " ")
 745              (prin1 (eval variable))
 746              (insert ")\n\n")))))
 747
 748 (defun shadow-save-buffers-kill-emacs (&optional arg)
 749   "Offer to save each buffer and copy shadows, then kill this Emacs process.
 750 With prefix arg, silently save all file-visiting buffers, then kill.
 751
 752 Extended by shadowfile to automatically save `shadow-todo-file' and
 753 look for files that have been changed and need to be copied to other systems."
 754   ;; This function is necessary because we need to get control and save
 755   ;; the todo file /after/ saving other files, but /before/ the warning
 756   ;; message about unsaved buffers (because it can get modified by the
 757   ;; action of saving other buffers).  `kill-emacs-hook' is no good
 758   ;; because it is not called at the correct time, and also because it is
 759   ;; called when the terminal is disconnected and we cannot ask whether
 760   ;; to copy files.
 761   (interactive "P")
 762   (shadow-save-todo-file)
 763   (save-some-buffers arg t)
 764   (shadow-copy-files)
 765   (shadow-save-todo-file)
 766   (and (or (not (memq t (mapcar (function
 767                                  (lambda (buf) (and (buffer-file-name buf)
 768                                                     (buffer-modified-p buf))))
 769                                 (buffer-list))))
 770            (yes-or-no-p "Modified buffers exist; exit anyway? "))
 771        (or (not (fboundp 'process-list))
 772            ;; process-list is not defined on MSDOS.
 773            (let ((processes (process-list))
 774                  active)
 775              (while processes
 776                (and (memq (process-status (car processes)) '(run stop open listen))
 777                     (process-query-on-exit-flag (car processes))
 778                     (setq active t))
 779                (setq processes (cdr processes)))
 780              (or (not active)
 781                  (yes-or-no-p "Active processes exist; kill them and exit anyway? "))))
 782        (kill-emacs)))
 783
 784 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 785 ;;; Hook us up
 786 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 787
 788 ;;;###autoload
 789 (defun shadow-initialize ()
 790   "Set up file shadowing."
 791   (interactive)
 792   (setq shadow-homedir
 793         (file-name-as-directory (shadow-expand-file-name shadow-homedir))
 794         shadow-info-file (shadow-expand-file-name shadow-info-file)
 795         shadow-todo-file (shadow-expand-file-name shadow-todo-file))
 796   (if (not (shadow-read-files))
 797       (progn
 798         (message "Shadowfile information files not found - aborting")
 799         (beep)
 800         (sit-for 3))
 801     (when (and (not shadow-inhibit-overload)
 802                (not (fboundp 'shadow-orig-save-buffers-kill-emacs)))
 803       (defalias 'shadow-orig-save-buffers-kill-emacs
 804         (symbol-function 'save-buffers-kill-emacs))
 805       (defalias 'save-buffers-kill-emacs 'shadow-save-buffers-kill-emacs))
 806     (add-hook 'write-file-functions 'shadow-add-to-todo)
 807     (define-key ctl-x-4-map "s" 'shadow-copy-files)))
 808
 809 (defun shadowfile-unload-function ()
 810   (substitute-key-definition 'shadow-copy-files nil ctl-x-4-map)
 811   (when (fboundp 'shadow-orig-save-buffers-kill-emacs)
 812     (fset 'save-buffers-kill-emacs
 813           (symbol-function 'shadow-orig-save-buffers-kill-emacs)))
 814   ;; continue standard unloading
 815   nil)
 816
 817 (provide 'shadowfile)
 818
 819 ;;; shadowfile.el ends here