retain-copy.el

File contents

;;; retain-copy.el --- maintain file duplicates according to file-name patterns

;; LCD Archive Entry (LCD maintainers, you're welcome to it!):
;; retain-copy|Ken Manheimer|klm@python.org
;; |maintain file duplicates according to file-name patterns
;; |2011-10-07|$Id: retain-copy.el,v 1.13 2011-10-07 21:12:19 klm Exp $||

;; Copyright (C) 2011 Ken Manheimer, Free Software Foundation, Inc.
;; Author: Ken Manheimer, klm@python.org, ken.manheimer@gmail.com

;; This file could be part of GNU Emacs.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

;;; Commentary:
;;
;; Associate locations for duplicate copies, and optional duplication
;; filtering functions, with filename patterns, and perform the duplication
;; and filtering automatically when files with matching names are saved.
;;
;; See the customization group "retain-copy" and the 'retain-copy'
;; docstring for more info.

;;;_  customization
;;;_. defgroup retain-copy
(defgroup retain-copy nil
  "Facilities for retaining local copies of selected remote files."
  :group 'files)
;;;_. defcustom retain-copy-alist nil
(defcustom retain-copy-alist nil
  "Association list of filename patterns and copy-directory names.

The part of the target file's path after the match is appended to the
copy-directory name to determine the full path of the copy. If that
directory does not exist, the user is prompted for its creation.

Use the function `retain-copy' to copy files according to this spec."
  :group 'retain-copy
  :type '(repeat (list (regexp :tag "Regexp matching filename")
		       (directory :tag "Directory name")
                       (function :tag "Filter function"))))
;;;_ internal vars
;;;_. defvar retain-copy-read-only-setting 'retain-copy
(defvar retain-copy-read-only-setting 'retain-copy)
;;;_. defvar retain-copy-managed-files nil
(defvar retain-copy-managed-files nil
  "List of filenames of buffers being actively managed as retain-copy copies.")
;;;_ operations
;;;_. retain-copy (&optional arg)
(defun retain-copy (&optional arg)
  "Retain a copy of current buffer's file.

Location of the copy is determined according to `retain-copy-alist'.

If any filtering is specified, a buffer is created visiting the copy.

With optional universal-argument ARG, we do the copy and then pop
to a buffer visiting the copy.

If a buffer visiting the copy is created for either of the above
reasons, retain-copy leaves the destination buffer read-only.
This is designed to reduce inadvertant editing of the copy when
the original was intended.  If the destination already was
read-only outside of retain-copy's agency, the user is prompted
to confirm writing, and if confirmed the read-only status is
taken-over by retain-copy."

  (interactive "p")
  (let* ((destination (retain-copy-get-destination (buffer-file-name)))
         (filter (retain-copy-get-filter (buffer-file-name)))
         (destdir (and destination (file-name-directory destination)))
         (curmsg (or (current-message) ""))
         (pop-to (and arg (not (= arg 1))))
         destbuf
         contents
         was-point
         was-read-only
         (inhibit-read-only t))
    (if (buffer-modified-p)
        (if (not (y-or-n-p (format "Buffer %s still modifed - retain anyway? "
                                   (buffer-name (current-buffer)))))
            (error "Not retaining unsaved buffer.")))
    (if (not destination)
        (error "No copy destination found for %s" (buffer-file-name)))
    (if (file-exists-p destination)
        (if (not (file-writable-p destination))
            (error "Unwritable file %s" destination))
      (if (not (file-accessible-directory-p destdir))
          (if (file-exists-p destdir)
              (error "Unwritable directory %s" destdir)
            (if (yes-or-no-p (format "Absent directory %s - create it? "
                                     destdir))
                (make-directory destdir)))))
    (message "+ %s ... %s" curmsg destination)
    (if (and (or (not filter) (eq filter 'ignore)) (not pop-to))
        (copy-file (buffer-file-name) destination t t t)
      ;; so the temporary message has a chance to show:
      (with-temp-message
          (format "... retaining %s" destination)
        (save-restriction
          (widen)
          (setq contents (buffer-string)))
        (set-buffer (setq destbuf (find-file-noselect destination)))
        (setq was-read-only buffer-read-only)
        (if was-read-only
            (if (equal was-read-only retain-copy-read-only-setting)
                (setq buffer-read-only nil)
              (if (not (yes-or-no-p
                        (concat "Destination buffer independently"
                                " read-only - write anyway, now onwards? ")))
                  (error "Destination buffer read-only")
                ;; Disable read-only and set to take it over next time.
                (setq buffer-read-only nil)
                (setq was-read-only retain-copy-read-only-setting)))
          ;; XXX If we ever find a common need for manual post-editing of the
          ;;     copy, we'll need to offer an override.
          (setq was-read-only retain-copy-read-only-setting))
        (when (buffer-modified-p)
          (pop-to-buffer destbuf)
          (error "Destination buffer has unmodified changes - rectify first."))
        (setq was-point (point))
        (widen)
        (erase-buffer)
        (insert contents)
        (if filter
            (apply filter nil))
        (save-buffer)
        (setq buffer-read-only was-read-only)
        (if (and (equal was-read-only retain-copy-read-only-setting)
                 (not (member (buffer-file-name) retain-copy-managed-files)))
            (setq retain-copy-managed-files (push (buffer-file-name)
                                                  retain-copy-managed-files)))
        (goto-char was-point)
        (if pop-to
            (pop-to-buffer destbuf))
        (message "Writing %s...  Done." destination)))))
;;;_. retain-copy-get-target (file-name)
(defun retain-copy-get-target (file-name)
  "Return the target path and filter pair for a copy of current buffer's file.

The match data is left so that `(match-end 0)' is the end of the qualifying
path's match.

The pair is determined according to `retain-copy-alist', which see for
specifics.

nil is returned if no match is found."
  (let* ((alist retain-copy-alist)
         elt
         got)
    (while (and alist (not got))
      (setq elt (car alist))
      (if (string-match (car elt) file-name)
	  (setq got elt))
      (setq alist (cdr alist)))
    got))
;;;_. retain-copy-get-destination (file-name)
(defun retain-copy-get-destination (file-name)
  "Return the destination path for a copy of current buffer's file.

The destination is determined according to `retain-copy-alist',
which see for specifics.

Return nil if no match is found."
  (let* ((target (retain-copy-get-target file-name))
         path-remainder
         destination)
    (when target
      (setq destination (cadr target)
            path-remainder (substring file-name (match-end 0)))
      (if destination
          (concat (file-name-as-directory destination)
                  (if (string= path-remainder "")
                      (file-name-nondirectory file-name)
                    path-remainder))))))
;;;_. retain-copy-get-filter (file-name)
(defun retain-copy-get-filter (file-name)
  "Return the filter function for a copy of current buffer's file.

The filter is determined according to `retain-copy-alist',
which see for specifics.

nil is returned if no match is found, or if no filter is registered."
  (let ((target (retain-copy-get-target file-name)))
    (if target (caddr target))))
;;;_. retain-copy-if-registered ()
(defun retain-copy-if-registered ()
  "Retain a copy of file in current buffer if it has a destination.

If the file has no registered filter, just do a copy of the
original file.  Otherwise, do a full retain-copy using a buffer
for the copy and applying the filter function.

Intended for use on after-save-hook to automatically save
retained copies, when the current file has any."
  (if (retain-copy-get-destination (buffer-file-name))
      (retain-copy)))
(add-hook 'after-save-hook 'retain-copy-if-registered nil nil)
;;;_ tests
;;;_. test-retain-copy ()
(defun test-retain-copy ()
  (require 'cl)                         ; for 'assert'
  (let ((retain-copy-alist
         '(("^/ftp:jam.com:/" "~/src/Sites/jam.com/" 'one)
           ("^/ftp:[^@]*@?gross\\.net\\(#[0-9]+\\)?:/gross\\.net/"
            "~/src/Sites/gross.net/"
            'two)
           ("~/some/where/"
            "~/src/elsewhere/"
            'three)
           ("~/"
            "~/mycatchall/"
            'four)
           ("\\([^/]+/\\)\\|\\(/\\)"
            "~/othercatchall/"
            'five)
           ))
        (fodder '(("/ftp:jam.com:/blat/thissentencenoverb"
                   "~/src/Sites/jam.com/blat/thissentencenoverb"
                   'one)
                  ("/ftp:me@gross.net#1021:/gross.net/Sundry/StuffAndWhatnot"
                   "~/src/Sites/gross.net/Sundry/StuffAndWhatnot"
                   'two)
                  ("~/some/where/what/not/stuff.el"
                   "~/src/elsewhere/what/not/stuff.el"
                   'three)
                  ("~/blit/blat/blot"
                   "~/mycatchall/blit/blat/blot"
                   'four)
                  ("~other/blit/blat/blot"
                   "~/othercatchall/blit/blat/blot"
                   'five)
                  )))
    (dolist (elt fodder)
      (assert (string= (retain-copy-get-destination (car elt)) (cadr elt))
              (list (retain-copy-get-destination (car elt)) (cadr elt)))
      (assert (equal (retain-copy-get-filter (car elt)) (caddr elt))
              elt)))
  t)
;;;_ Miscellaneous formatting "filter" functions.
;;;_. rc-massage-zwiki-page ()
(defun rc-massage-zwiki-page ()
  "Strip ZWiki page headers, except Log line if non-empty."
  (save-excursion
    (let ((was-modified (buffer-modified-p)))
      (goto-char 0)
      (if (looking-at "Wiki-Safetybelt: ")
          (kill-line)))))
;;;_. rc-massage-remove-rcs-revision ()
(defun rc-massage-remove-rcs-revision ()
  "Strip parenthesis-contained RCS $revision cookies."
  (if allout-mode
    (allout-mode nil))
  (save-excursion
    (goto-char 0)
    (while (re-search-forward " ($Revision[^)]*)" nil t)
      (replace-match "" nil nil))))
;;;_. rc-remove-allout-inhibit-widgets ()
(defun rc-remove-allout-inhibit-widgets ()
  "Strip parenthesis-contained RCS $revision cookies."
  (if allout-mode
    (allout-mode nil))
  (save-excursion
      (goto-char 0)
      (let (got)
        (while (re-search-forward "^;+allout-widgets-mode-inhibit:.*\n" nil t)
          (setq got t)
          (replace-match "" nil nil)))))
;;;_. rc-place-lisp-files-for-distribution ()
(defun rc-place-lisp-files-for-distribution ()
  (rc-massage-remove-rcs-revision)
  (rc-remove-allout-inhibit-widgets))
;;;_ retain read-only:
;;;_. retain-copy-preserve-read-only-setting ()
(defun retain-copy-preserve-read-only-setting ()
  "if this buffer is being actively managed by retain-copy, mark it read-only."
  (if (member (buffer-file-name) retain-copy-managed-files)
      (setq buffer-read-only retain-copy-read-only-setting)))
;;;_. and after-revert-hook:
;; revert happens on various file-changing vc operations, including checkin
;; and revert.
(add-hook 'after-revert-hook 'retain-copy-preserve-read-only-setting)

;; Run tests during byte compilation:
(eval-after-load 'retain-copy
  (test-retain-copy))
(provide 'retain-copy)
;;;_. Local emacs vars.
;;;_ , Local variables:
;;;_ , allout-layout: (-1 : 0)
;;;_ , End: