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