home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / shadow-files.el < prev    next >
Encoding:
Text File  |  1992-11-23  |  12.6 KB  |  347 lines
  1. ;;;; shadow-files.el
  2. ;;; LCD Archive Entry:
  3. ;;; shadow-files|Boris Goldowsky|boris@prodigal.psych.rochester.edu|
  4. ;;; Helps you keep identical copies of files on multiple hosts.|
  5. ;;; 11/23/92|version 1.2|~/misc/shadow-files.el.Z|
  6.  
  7. ;;; USE: put (require 'shadow-files) in your .emacs; add clusters (if
  8. ;;; necessary) and file groups with shadow-define-cluster, shadow-define-group,
  9. ;;; and shadow-define-regexp-group (see the documentation for these functions
  10. ;;; for information on how and when to use them).  After doing this once, 
  11. ;;; everything should be automatic.
  12. ;;;     If you need to remove or edit a cluster or file group, you can edit the
  13. ;;; .shadows buffer, then type M-x shadow-read to load in the new information
  14. ;;; (if you do not do this, your changes could be overwritten!).
  15.  
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. ;;; DEPENDENCIES:
  18. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19. ;;;  All of the packages mentioned below are available from archive sites,
  20. ;;; including archive.cis.ohio-state.edu:pub/gnu/emacs/elisp-archive.
  21.  
  22. ;;; ANGE-FTP.  This file could be modified (with some loss of generality and
  23. ;;; cleanliness of the user interface) to use only the standard ftp library by
  24. ;;; replacing the call to write-region with:
  25. ;;;  (ftp-write-file (shadow-primary (shadow-site s)) (shadow-file s))
  26.  
  27. (require 'ange-ftp)
  28.  
  29. ;;; ADD-HOOK.  Several implementations of this are available.  I'd
  30. ;;; use ange-ftp-add-hook, but that is capable of messing up write-file-hooks.
  31.  
  32. (require 'add-hook)
  33.  
  34. ;;; CL, the common lisp library in the standard emacs distribution.
  35.  
  36. (require 'cl)
  37.  
  38. ;;; SYMLINK-FIX.  Symbolic links can cause nasty surprises, so I recommend
  39. ;;; loading this package.  However, it is not actually necessary, so comment
  40. ;;; out the next two lines if you want, and proceeed at your own risk.
  41.  
  42. (setq symlink-overload-expand-file-name t)
  43. (require 'symlink-fix)
  44.  
  45. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  46. ;;; Variables
  47. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48.  
  49. (defvar shadow-info-file "~/.shadows"
  50.   "*File to keep shadow information in.  
  51. If this is nil, the information will not be read from or saved to a file.")
  52.  
  53. (defvar shadow-noquery nil
  54.   "*If t, always copy shadow files without asking.")
  55.  
  56. (defvar kill-emacs-hooks nil
  57.   ;; Note, this is the one symbol defined in this file which does not begin
  58.   ;; with shadow- .  However, if it is already defined, we don't clobber it.
  59.   "*Functions to run before exiting emacs.
  60. This is a replacement for kill-emacs-hook, which only allowed one hook
  61. function.")
  62.  
  63. ;;; The following two variables should in most cases initialize themselves
  64. ;;; correctly.  They are provided as variables in case the defaults are wrong
  65. ;;; on your machine.
  66.  
  67. (defvar shadow-system-name (system-name)
  68.   "The complete hostname of this machine.")
  69.  
  70. (defvar shadow-homedir (expand-file-name (getenv "HOME"))
  71.   ;; Call to expand-file-name is in case we are using symlink-fix
  72.   "The directory that shadow file specs are assumed to be relative to 
  73. \(on this machine), if not specified as absolute pathnames.")
  74.  
  75. (defvar shadow-clusters nil
  76.   "List of host clusters.")
  77.  
  78. (defvar shadow-literal-groups nil
  79.   "List of files that are shared between hosts.
  80. This list contains shadow structures with literal filenames, created by
  81. shadow-define-group.")
  82.  
  83. (defvar shadow-regexp-groups nil
  84.   "List of file types that are shared between hosts.
  85. This list contains shadow structures with regexps matching filenames, 
  86. created by shadow-define-regexp-group.")
  87.  
  88. (defvar shadow-marked-files nil
  89.   "List of files that need to be copied to remote hosts.")
  90.  
  91. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92.  
  93. (defstruct shadow-cluster
  94.   "Structure for holding information about host clusters.
  95. The shadow-clusters variable associates the names of clusters to these
  96. structures."
  97.   primary
  98.   regexp)
  99.  
  100. (defstruct shadow
  101.   "Structure for holding information about shadows of files.
  102. The site can be a cluster \(symbol) or a hostname \(string).  The file can be
  103. either a literal filename, or a regexp.  The buffer may is only filled in once
  104. something is in the shadow-marked-files list."
  105.   site
  106.   file
  107.   buffer
  108.   )
  109.  
  110. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  111. ;;; User-level Commands
  112. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  113.  
  114. (defun shadow-define-cluster (name primary regexp)
  115.   "Define a new `cluster.'
  116. This is a group of hosts that share files, so that copying to or from
  117. one of them is sufficient to update the file on all of them.  Clusters are
  118. defined by a NAME, the name of a PRIMARY host \(the one we copy files to), and
  119. a REGEXP that matches the hostname of all the sites in the cluster."
  120.   (interactive (let* ((name (read-no-blanks-input "Cluster name: " ""))
  121.               (primary (read-no-blanks-input "Primary host: " name))
  122.               (regexp (read-string "Regexp matching all host names: "
  123.                        (regexp-quote primary))))
  124.          (list (intern name) primary regexp)))
  125.   (let ((c (cons name (make-shadow-cluster :primary primary
  126.                        :regexp regexp))))
  127.     (when (not (member c shadow-clusters))
  128.       (push c shadow-clusters)
  129.       (shadow-write))))
  130.  
  131. (defun shadow-define-group (&rest shadows)
  132.   "Set things up so that one file is shared between hosts.
  133. Prompts for hostnames and the file's name on each host.  When any of these is
  134. edited, the new file will be copied to each of the other locations.  Filenames
  135. may be either absolute or relative to the home directory; sites can be specific
  136. hostnames or names of clusters \(see shadow-define-cluster).
  137.   Noninteractively, each arg is a dotted pair of a site and a filename."
  138.   (interactive (let (args site file)
  139.          (while (setq site (shadow-read-site))
  140.            (setq args (cons (cons site (read-string "Filename: "
  141.                                 (cdar args)))
  142.                     args)))
  143.          args))
  144.   (push (mapcar (function (lambda (pair) 
  145.                 (make-shadow :site (car pair)
  146.                      :file (cdr pair))))
  147.         shadows)
  148.     shadow-literal-groups)
  149.   (shadow-write))
  150.  
  151. (defun shadow-define-regexp-group (regexp sites)
  152.   "Set things up so that a group of files are shared between hosts.
  153. Files matching REGEXP are shared between the list of SITES;
  154. the filenames must be identical on all hosts \(if they aren't, use
  155. shadow-define-group instead of this function).  Each site can be either a
  156. hostname or the name of a cluster \(see shadow-define-cluster)."
  157.   (interactive (let ((regexp (read-string "Filename regexp: " 
  158.                       (if (buffer-file-name)
  159.                           (regexp-quote 
  160.                            (file-name-nondirectory
  161.                         (buffer-file-name))))))
  162.              site sites)
  163.          (while (setq site (shadow-read-site))
  164.            (push site sites))
  165.          (list regexp sites)))
  166.   (push (mapcar (function (lambda (site)
  167.                 (make-shadow :site site
  168.                      :file regexp)))
  169.         sites)
  170.     shadow-regexp-groups)
  171.   (shadow-write))
  172.  
  173. (defun shadow-write-marked-files ()
  174.   "FTP all files in shadow-marked-files list to their shadows.
  175. This is invoked from kill-emacs-hook, so you do not need to call it
  176. explicitly."
  177.   (interactive)
  178.   (let (notdone)
  179.     (dolist (s shadow-marked-files)
  180.       (if (or shadow-noquery 
  181.           (y-or-n-p (format "Write shadow file %s:%s?" 
  182.                 (shadow-site s)
  183.                 (shadow-file s)))) 
  184.       (let ((buffer (condition-case i
  185.                 (set-buffer (shadow-buffer s))
  186.               (error (if (y-or-n-p 
  187.                       (format
  188.                        "Buffer killed -- ftp %s anyway?"
  189.                        (shadow-file s)))
  190.                      (set-buffer
  191.                       (find-file-noselect 
  192.                        (expand-file-name (shadow-file s)
  193.                              shadow-homedir))))))))
  194.         (when buffer
  195.           (save-restriction
  196.         (widen)
  197.         (condition-case i 
  198.             (write-region (point-min) (point-max) ; see note 1 above
  199.                   (concat "/" (shadow-primary (shadow-site s))
  200.                       ":" (shadow-file s)))
  201.           (error (setq notdone (cons s notdone)))))))
  202.     (setq notdone (cons s notdone))))
  203.     (setq shadow-marked-files notdone)))
  204.  
  205. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  206. ;;; Internal functions
  207. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  208.  
  209. (defun shadow-member (item list)
  210.   "Like `member' or `memq', but uses EQUAL for comparison."
  211.   (let ((ptr list)
  212.         (done nil)
  213.         (result '()))
  214.     (while (not (or done (endp ptr)))
  215.       (cond ((equal item (car ptr))
  216.              (setq done t)
  217.              (setq result ptr)))
  218.       (setq ptr (cdr ptr)))
  219.     result))
  220.  
  221. (defun shadow-of (buffer)
  222.   "If BUFFER's file has shadows, return the list of shadow structures."
  223.   (let* ((file-abs (buffer-file-name buffer))
  224.      (file-rel (if (string-match (concat "^" (regexp-quote shadow-homedir))
  225.                      file-abs)
  226.                (substring file-abs (1+ (match-end 0)))))
  227.      (found nil))
  228.     (dolist (group shadow-literal-groups)
  229.       (if (some (function 
  230.          (lambda (s)
  231.            (let ((f (shadow-file s)))
  232.              (and (string-equal file-abs 
  233.                     (expand-file-name f shadow-homedir))
  234.               (shadow-site-match (shadow-site s) 
  235.                          shadow-system-name)))))
  236.         group)
  237.       (setq found (append found 
  238.                   (shadow-what-to-copy shadow-system-name
  239.                            nil buffer group)))))
  240.     (dolist (group shadow-regexp-groups)
  241.       (if (and (or (string-match (shadow-file (car group)) file-abs)
  242.            (if file-rel
  243.                (string-match (shadow-file (car group)) file-rel)))
  244.            (some (function
  245.               (lambda (s)
  246.             (shadow-site-match (shadow-site s) 
  247.                        shadow-system-name)))
  248.              group))
  249.       (setq found (append found
  250.                   (shadow-what-to-copy shadow-system-name
  251.                            (or file-rel file-abs)
  252.                            buffer group)))))
  253.     found))
  254.  
  255. (defun shadow-what-to-copy (site file buffer group)
  256.   "Return list of shadow structures indicating the copy operations that need to
  257.   be performed in order to reflect a modification made at SITE to FILE/BUFFER
  258.   which has the given GROUP of shadow files.  If file argument is nil, trust
  259.   the filenames in the structures in group.  You probably don't want to use
  260.   this unless you are the shadow-of function \(which I doubt :-)."
  261.   (let (found)
  262.     (dolist (s group)
  263.       (if (not (shadow-site-match (shadow-site s) site))
  264.       (push (make-shadow :site (shadow-primary (shadow-site s))
  265.                  :file (or file (shadow-file s))
  266.                  :buffer buffer)
  267.         found)))
  268.     found))
  269.  
  270. (defun shadow-mark-file-for-write ()
  271.   "Add the current file to the list of shadow-marked-files,
  272. if it is on the shadow-file-list."
  273.   (let ((shadows (shadow-of (current-buffer))))
  274.     (dolist (s shadows)
  275.       (when (not (shadow-member s shadow-marked-files))
  276.     (push s shadow-marked-files)
  277.     (message "Use %s to copy this file to %s."
  278.          (substitute-command-keys "\\[shadow-write-marked-files]")
  279.          (shadow-primary (shadow-site s)))
  280.     (sit-for 1))))
  281.    nil); Return nil for write-file-hooks
  282.  
  283. (defun shadow-read-site ()
  284.   "Read a site or cluster name from the minibuffer."
  285.   (let ((ans (read-no-blanks-input "Site or cluster [RET when done]: " "")))
  286.     (cond ((equal "" ans) nil)
  287.       ((assoc (intern ans) shadow-clusters) (intern ans))
  288.       (t ans))))
  289.  
  290. (defun shadow-site-match (site1 site2)
  291.   "See if SITE1 matches SITE2.  
  292. Each may be a string or a cluster; if they are clusters,
  293. regexp of site1 will be matched against the primary of site2."
  294.   (setq site2 (shadow-primary site2))
  295.   (if (symbolp site1)
  296.       (string-match (shadow-cluster-regexp (cdr (assoc site1 shadow-clusters)))
  297.             site2)
  298.     (string-equal site1 site2)))
  299.  
  300. (defun shadow-primary (host)
  301.   (if (symbolp host)
  302.       (shadow-cluster-primary (cdr (assoc host shadow-clusters)))
  303.     host))
  304.  
  305. (defun shadow-read ()
  306.   (interactive)
  307.   (when shadow-info-file
  308.     (save-excursion
  309.       (set-buffer (find-file-noselect shadow-info-file))
  310.       (eval-current-buffer nil))))
  311.  
  312. (defun shadow-write ()
  313.   (when shadow-info-file
  314.     (save-excursion
  315.       (set-buffer (find-file-noselect shadow-info-file))
  316.       (delete-region (point-min) (point-max))
  317.       (insert (format "(setq shadow-clusters '%s)\n\n" 
  318.               shadow-clusters)
  319.           (format "(setq shadow-literal-groups '%s)\n\n" 
  320.               shadow-literal-groups)
  321.           (format "(setq shadow-regexp-groups '%s)\n\n" 
  322.               shadow-regexp-groups)))))
  323.  
  324. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  325. ;;; Hook us up
  326. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  327.  
  328. (defun shadow-kill-emacs-hook ()
  329.   "Make there be more than one kill-emacs-hook,
  330. so we can hook ourselves up without messing up any other packages."
  331.   (run-hooks 'kill-emacs-hooks))
  332.  
  333. (when (not (and (boundp 'kill-emacs-hook)
  334.         (eq kill-emacs-hook 'shadow-kill-emacs-hook)))
  335.   (setq kill-emacs-hooks (if (boundp 'kill-emacs-hook) kill-emacs-hook nil))
  336.   (setq kill-emacs-hook 'shadow-kill-emacs-hook)
  337.   (add-hook 'kill-emacs-hooks 'shadow-write-marked-files))
  338.  
  339. (add-hook 'write-file-hooks 'shadow-mark-file-for-write)
  340.  
  341. (define-key ctl-x-4-map "s" 'shadow-write-marked-files)
  342.  
  343. (shadow-read)
  344.  
  345. (provide 'shadow-files)
  346.  
  347.