retain-copy.el

;;; 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$||

;; 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 file-name patterns with locations for duplicate copies, and
;; optional duplication filtering functions.  Duplication and filtering are
;; automatically performed 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 destination directory pairs.

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

Inhibit uid/gid preservation is for filesystems that can't.

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")
                       (boolean :tag "Ignore this entry?")
                       (boolean :tag "Inhibit uid/gid preservation?"))))
;;;_ 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* ((disabled (retain-copy-get-disabled (buffer-file-name)))
         (inhibit-uidgid (retain-copy-get-inhibit-uidgid (buffer-file-name)))
         (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 disabled
        nil
      (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                         ; ok-if-already-exists
                     t                         ; keep-time
                     (not inhibit-uidgid)      ; preserve-uid-gid
                     t)                        ; perserve-permissions
        ;; 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-path)
(defun retain-copy-get-target (file-path)
  "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-path)
	  (setq got elt))
      (setq alist (cdr alist)))
    got))
;;;_. retain-copy-get-destination (file-path)
(defun retain-copy-get-destination (file-path)
  "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-path))
         path-remainder
         destination)
    (when target
      (setq destination (cadr target)
            path-remainder (substring file-path (match-end 0)))
      (if destination
          (concat destination
                  (if (string= (substring destination -1) "/")
                      ""
                    "/")
                  (if (string= path-remainder "")
                      (file-name-nondirectory file-path)
                    path-remainder))))))
;;;_. retain-copy-get-filter (file-path)
(defun retain-copy-get-filter (file-path)
  "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-path)))
    (if target (caddr target))))
;;;_. retain-copy-get-disabled (file-path)
(defun retain-copy-get-disabled (file-path)
  "Return whether the entry for the current buffer's file should be ignored.

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

t is returned if a match is found and the entry is marked disabled."
  (let ((target (retain-copy-get-target file-path)))
    (if target (cadddr target))))
;;;_. retain-copy-get-inhibit-uidgid (file-path)
(defun retain-copy-get-inhibit-uidgid (file-path)
  "Return whether entry gid/uid preservation is enabled.

Nil is returned if no match is found."
  (let ((target (retain-copy-get-target file-path)))
    (if target (cadddr (cdr 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-lib)                         ; 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)
      (cl-assert
       (string= (retain-copy-get-destination (car elt)) (cadr elt))
       (list (retain-copy-get-destination (car elt)) (cadr elt)))
      (cl-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: