--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/packages/backup-dir.el	Mon Aug 13 08:48:16 2007 +0200
@@ -0,0 +1,449 @@
+;;; BACKUP-DIR.EL:   Emacs functions to allow backup files to live in
+;;;                  some other directory(s).             Version 2.0
+;;;
+;;; Copyright (C) 1992-97 Greg Klanderman
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 1, or (at your option)
+;;; any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; A copy of the GNU General Public License can be obtained from
+;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
+;;; 02139, USA.
+;;;
+;;; Send bug reports, etc. to greg@alphatech.com or gregk@ai.mit.edu.
+;;;
+;;;
+;;; Modification History
+;;; ====================
+;;;
+;;; 12/28/1996  Version 2.0
+;;; Updated for XEmacs 19.15b4, much of code reorganized & cleaned up
+;;;
+;;; 12/27/1996  Version 1.6
+;;; explicit loading of dired replaced to use dired-load-hook
+;;; (suggested by Thomas Feuster, feuster@tp4.physik.uni-giessen.de)
+;;;
+;;; 12/2/1996 Version 1.5
+;;; Took out obsolete byte compiler options
+;;;
+;;; 9/24/1996 Version 1.4
+;;; Fix some bugs, change to alist OPTIONS list (ok-create, full-path..) from
+;;; separate fields for each option variable.  Added search-upward option.
+;;; Added new function `find-file-latest-backup' to find a file's latest backup.
+;;;
+;;; 1/26/1996 Version 1.3
+;;; Name change to backup-dir.el
+;;;
+;;; 3/22/1995 Version 1.2
+;;; Added new definitions for functions `file-newest-backup', `latest-backup-file',
+;;; and `diff-latest-backup-file' so various other emacs functions will find the
+;;; right backup files.
+;;;
+;;; 4/23/1993 Version 1.1
+;;; Reworked to allow different behavior for different files based on the
+;;; alist `bkup-backup-directory-info'.
+;;;
+;;; Fall 1992 Version 1.0
+;;; Name change and added ability to make directories absolute.  Added the
+;;; full path stuff to make backup name unique for absolute directories.
+;;;
+;;; Spring 1992 Version 0.0
+;;; Original
+;;;
+;;;
+;;; Description:
+;;; ============
+;;;
+;;; Allows backup files to be optionally stored in some directories, based on
+;;; the value of the alist, `bkup-backup-directory-info'.  This variable is a
+;;; list of lists of the form (FILE-REGEXP BACKUP-DIR OPTIONS ...).  If the
+;;; filename to be backed up matches FILE-REGEXP, or FILE-REGEXP is t, then
+;;; BACKUP-DIR is used as the path for its backups.  Directories may begin with
+;;; "/" to specify an absolute pathname.  If BACKUP-DIR does not exist and
+;;; OPTIONS contains the symbol `ok-create', then it is created if possible.
+;;; Otherwise the usual behavior (backup in the same directory as the file)
+;;; results.  If OPTIONS contains the symbol `full-path', then the full path of
+;;; the file being backed up is prepended to the backup file name, with each "/"
+;;; replaced by a "!".  This is intended for cases where an absolute backup path
+;;; is used.  If OPTIONS contains the symbol `search-upward' and the backup
+;;; directory BACKUP-DIR is a relative path, then a directory with that name is
+;;; searched for starting at the current directory and proceeding upward (..,
+;;; ../.., etc) until one is found of that name or the root is reached, and if
+;;; one is found it is used as the backup directory.  Finally, if no FILE-REGEXP
+;;; matches the file name being backed up, then the usual behavior results.
+;;;
+;;; These lines from my .emacs load this file and set the values I like:
+;;;
+;;; (require 'backup-dir)
+;;; (setq bkup-backup-directory-info
+;;;       '(("/home/greg/.*" "/~/.backups/" ok-create full-path)
+;;; 	   (t                ".backups/"    full-path search-upward)))
+;;;
+;;;
+;;; The package also provides a new function, `find-file-latest-backup' to find
+;;; the latest backup file for the current buffer's file.
+;;;
+;;;
+;;; This file is based on `files.el' from XEmacs 19.15b4.
+;;; It has not been extensively tested on GNU Emacs past 18.58.
+;;; It does not work under ms-dos.
+
+
+
+(byte-compiler-options
+ (optimize t)
+ (warnings (- free-vars))              ; Don't warn about free variables
+ )
+
+
+;;; New variables affecting backup file behavior
+;;; This is the only user-customizable variable for this package.
+;;;
+(defvar bkup-backup-directory-info nil
+  "Alist of (FILE-REGEXP BACKUP-DIR OPTIONS ...))
+If the filename to be backed up matches FILE-REGEXP, or FILE-REGEXP is t,
+then BACKUP-DIR is used as the path for its backups.  Directories may
+begin with \"/\" to specify an absolute pathname.  If BACKUP-DIR does
+not exist and OPTIONS contains the symbol `ok-create', then it is created if possible.
+Otherwise the usual behavior (backup in the same directory as the file)
+results.  If OPTIONS contains the symbol `full-path', then the full path of the file
+being backed up is prepended to the backup file name, with each \"/\"
+replaced by a \"!\".  This is intended for cases where an absolute backup path
+is used.  If OPTIONS contains the symbol `search-upward' and the backup
+directory BACKUP-DIR is a relative path, then a directory with that name is
+searched for starting at the current directory and proceeding upward (..,
+../.., etc) until one is found of that name or the root is reached, and if
+one is found it is used as the backup directory.  Finally, if no FILE-REGEXP
+matches the file name being backed up, then the usual behavior results.")
+
+ 
+;;; New functions
+;;;
+(defun bkup-search-upward-for-backup-dir (base bd-name)
+  "search upward for a directory named BD-NAME, starting in the
+directory BASE and continuing with its parent directories until
+one is found or the root is reached."
+  (let ((prev nil) (curr base) (gotit nil) (tryit nil))
+    (while (and (not gotit)
+                (not (equal prev curr))
+                (not (equal curr "//")))
+      (setq prev curr)
+      (setq curr (expand-file-name (concat curr "../")))
+      (setq tryit (expand-file-name bd-name curr))
+      (if (and (file-directory-p tryit) (file-exists-p tryit))
+          (setq gotit tryit)))
+    (if (and gotit
+             (eq (aref gotit (1- (length gotit))) ?/))
+        (setq gotit (substring gotit 0 (1- (length gotit)))))
+    gotit)) 
+
+(defun bkup-replace-slashes-with-exclamations (s)
+  "Replaces slashes in the string S with exclamations.
+A new string is produced and returned."
+  (let ((ns (copy-sequence s))
+	(i (1- (length s))))
+    (while (>= i 0)
+      (if (= (aref ns i) ?/)
+	  (aset ns i ?!))
+      (setq i (1- i)))
+    ns))
+
+(defun bkup-try-making-directory (dir)
+  "try making directory DIR, return non-nil if successful"
+  (condition-case ()
+      (progn (make-directory dir t)
+             t)
+    (t
+     nil)))
+  
+(defun bkup-backup-basename (file full-path)
+  "Gives the base part of the backup name for FILE, according to FULL-PATH."
+  (if full-path
+      (bkup-replace-slashes-with-exclamations file)
+    (file-name-nondirectory file)))
+
+(defun bkup-backup-directory-and-basename (file)
+  "Return the cons of the backup directory name
+and backup file name base for FILE."
+  (let ((file (expand-file-name file)))
+    (let ((dir     (file-name-directory file))
+          (alist   bkup-backup-directory-info)
+          (bk-dir  nil)
+          (bk-base nil))
+      (if (listp alist)
+          (while (and (not bk-dir) alist)
+            (if (or (eq (car (car alist)) t)
+                    (eq (string-match (car (car alist)) file) 0))
+                (let* ((bd            (car (cdr (car alist))))
+                       (bd-rel-p      (and (> (length bd) 0)
+                                           (not (eq (aref bd 0) ?/))))
+                       (bd-expn       (expand-file-name bd dir))
+                       (bd-noslash    (if (eq (aref bd-expn (1- (length bd-expn))) ?/)
+                                          (substring bd-expn 0 (1- (length bd-expn)))
+                                        bd-expn))
+                       (options       (cdr (cdr (car alist))))
+                       (ok-create     (and (memq 'ok-create     options) t))
+                       (full-path     (and (memq 'full-path     options) t))
+                       (search-upward (and (memq 'search-upward options) t)))
+                  (if bd-expn
+                      (cond ((or (file-directory-p bd-expn)
+                                 (and ok-create
+                                      (not (file-exists-p bd-expn))
+                                      (bkup-try-making-directory bd-noslash)))
+                             (setq bk-dir  (concat bd-noslash "/")
+                                   bk-base (bkup-backup-basename file full-path)))
+                            ((and bd-rel-p search-upward)
+                             (let ((bd-up (bkup-search-upward-for-backup-dir dir bd)))
+                               (if bd-up
+                                   (setq bk-dir (concat bd-up "/")
+                                         bk-base (bkup-backup-basename file full-path)))))))))
+            (setq alist (cdr alist))))
+      (if (and bk-dir bk-base)
+          (cons bk-dir bk-base)
+        (cons dir (bkup-backup-basename file nil))))))
+
+
+;;; This next one is based on the following from `files.el'
+;;; but accepts a second optional argument
+
+;;(defun make-backup-file-name (file)
+;;  "Create the non-numeric backup file name for FILE.
+;;This is a separate function so you can redefine it for customization."
+;;  (if (and (eq system-type 'ms-dos)
+;;	   (not (msdos-long-file-names)))
+;;      (let ((fn (file-name-nondirectory file)))
+;;	(concat (file-name-directory file)
+;;		(if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn)
+;;		    (substring fn 0 (match-end 1)))
+;;		".bak"))
+;;    (concat file "~")))
+
+(defun bkup-make-backup-file-name (file &optional dir-n-base)
+  "Create the non-numeric backup file name for FILE.
+Optionally accept a list containing the backup directory and
+backup basename.  NB: we don't really handle ms-dos."
+  (if (and (eq system-type 'ms-dos)
+	   (not (and (fboundp 'msdos-long-file-names) (msdos-long-file-names))))
+      (let ((fn (file-name-nondirectory file)))
+	(concat (file-name-directory file)
+		(if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn)
+		    (substring fn 0 (match-end 1)))
+		".bak"))
+    (let ((d-n-b (or dir-n-base
+                     (bkup-backup-directory-and-basename file))))
+      (concat (car d-n-b) (cdr d-n-b) "~"))))
+
+(defun bkup-existing-backup-files (fn)
+  "Return list of existing backup files for file"
+  (let* ((efn (expand-file-name fn))
+         (dir-n-base (bkup-backup-directory-and-basename efn))
+         (non-num-bk-name (bkup-make-backup-file-name efn dir-n-base))
+         (non-num-bk (file-exists-p non-num-bk-name))
+         (backup-dir (car dir-n-base))
+         (base-versions (concat (cdr dir-n-base) ".~"))
+         (possibilities (file-name-all-completions base-versions backup-dir))
+         (poss (mapcar #'(lambda (name) (concat backup-dir name)) possibilities)))
+    (mapcar #'expand-file-name
+            (if non-num-bk (cons non-num-bk-name poss) poss))))
+
+(defun find-file-latest-backup (file)
+  "Find the latest backup file for FILE"
+  (interactive (list (read-file-name (format "Find latest backup of file (default %s): "
+                                             (file-name-nondirectory (buffer-file-name)))
+                                     nil (buffer-file-name) t)))
+  (let ((backup (file-newest-backup file)))
+    (if backup
+        (find-file backup)
+      (message "no backups found for `%s'" file))))
+
+
+;;; Functions changed from `files.el' and elsewhere -- originals precede new versions
+ 
+;;(defun make-backup-file-name (file)
+;;  "Create the non-numeric backup file name for FILE.
+;;This is a separate function so you can redefine it for customization."
+;;  (if (and (eq system-type 'ms-dos)
+;;	   (not (msdos-long-file-names)))
+;;      (let ((fn (file-name-nondirectory file)))
+;;	(concat (file-name-directory file)
+;;		(if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn)
+;;		    (substring fn 0 (match-end 1)))
+;;		".bak"))
+;;    (concat file "~")))
+
+(defun make-backup-file-name (file)
+  "Create the non-numeric backup file name for FILE.
+This is a separate function so you can redefine it for customization.
+*** Changed by \"backup-dir.el\""
+  (bkup-make-backup-file-name file))
+
+
+;;(defun find-backup-file-name (fn)
+;;  "Find a file name for a backup file, and suggestions for deletions.
+;;Value is a list whose car is the name for the backup file
+;; and whose cdr is a list of old versions to consider deleting now.
+;;If the value is nil, don't make a backup."
+;;  (let ((handler (find-file-name-handler fn 'find-backup-file-name)))
+;;    ;; Run a handler for this function so that ange-ftp can refuse to do it.
+;;    (if handler
+;;	(funcall handler 'find-backup-file-name fn)
+;;      (if (eq version-control 'never)
+;;	  (list (make-backup-file-name fn))
+;;	(let* ((base-versions (concat (file-name-nondirectory fn) ".~"))
+;;	       ;; used by backup-extract-version:
+;;	       (bv-length (length base-versions))
+;;	       possibilities
+;;	       (versions nil)
+;;	       (high-water-mark 0)
+;;	       (deserve-versions-p nil)
+;;	       (number-to-delete 0))
+;;	  (condition-case ()
+;;	      (setq possibilities (file-name-all-completions
+;;				   base-versions
+;;				   (file-name-directory fn))
+;;		    versions (sort (mapcar
+;;				    #'backup-extract-version
+;;				    possibilities)
+;;				   '<)
+;;		    high-water-mark (apply #'max 0 versions)
+;;		    deserve-versions-p (or version-control
+;;					   (> high-water-mark 0))
+;;		    number-to-delete (- (length versions)
+;;					kept-old-versions kept-new-versions -1))
+;;	    (file-error
+;;	     (setq possibilities nil)))
+;;	  (if (not deserve-versions-p)
+;;	      (list (make-backup-file-name fn))
+;;	    (cons (concat fn ".~" (int-to-string (1+ high-water-mark)) "~")
+;;		  (if (and (> number-to-delete 0)
+;;			   ;; Delete nothing if there is overflow
+;;			   ;; in the number of versions to keep.
+;;			   (>= (+ kept-new-versions kept-old-versions -1) 0))
+;;		      (mapcar #'(lambda (n)
+;;				  (concat fn ".~" (int-to-string n) "~"))
+;;			      (let ((v (nthcdr kept-old-versions versions)))
+;;				(rplacd (nthcdr (1- number-to-delete) v) ())
+;;				v))))))))))
+
+(defun find-backup-file-name (fn)
+  "Find a file name for a backup file, and suggestions for deletions.
+Value is a list whose car is the name for the backup file
+ and whose cdr is a list of old versions to consider deleting now.
+If the value is nil, don't make a backup.
+*** Changed by \"backup-dir.el\""
+  (let ((handler (find-file-name-handler fn 'find-backup-file-name)))
+    ;; Run a handler for this function so that ange-ftp can refuse to do it.
+    (if handler
+	(funcall handler 'find-backup-file-name fn)
+      (if (eq version-control 'never)
+	  (list (make-backup-file-name fn))
+	(let* ((dir-n-base (bkup-backup-directory-and-basename fn))         ;add
+               (non-num-bk-name (bkup-make-backup-file-name fn dir-n-base)) ;add
+               (bk-dir  (car dir-n-base))                                   ;add
+               (bk-base (cdr dir-n-base))                                   ;add
+               (base-versions (concat bk-base ".~"))                        ;mod
+	       ;; used by backup-extract-version:
+	       (bv-length (length base-versions))
+	       possibilities
+	       (versions nil)
+	       (high-water-mark 0)
+	       (deserve-versions-p nil)
+	       (number-to-delete 0))
+	  (condition-case ()
+	      (setq possibilities (file-name-all-completions
+				   base-versions
+				   bk-dir)                                  ;mod
+		    versions (sort (mapcar
+				    #'backup-extract-version
+				    possibilities)
+				   '<)
+		    high-water-mark (apply #'max 0 versions)
+		    deserve-versions-p (or version-control
+					   (> high-water-mark 0))
+		    number-to-delete (- (length versions)
+					kept-old-versions kept-new-versions -1))
+	    (file-error
+	     (setq possibilities nil)))
+	  (if (not deserve-versions-p)
+	      (list (bkup-make-backup-file-name fn dir-n-base))             ;mod
+	    (cons (concat bk-dir base-versions (int-to-string (1+ high-water-mark)) "~") ;mod
+		  (if (and (> number-to-delete 0)
+			   ;; Delete nothing if there is overflow
+			   ;; in the number of versions to keep.
+			   (>= (+ kept-new-versions kept-old-versions -1) 0))
+		      (mapcar #'(lambda (n)
+				  (concat bk-dir base-versions (int-to-string n) "~")) ;mod
+			      (let ((v (nthcdr kept-old-versions versions)))
+				(rplacd (nthcdr (1- number-to-delete) v) ())
+				v))))))))))
+
+
+;;(defun file-newest-backup (filename)
+;;  "Return most recent backup file for FILENAME or nil if no backups exist."
+;;  (let* ((filename (expand-file-name filename))
+;;	 (file (file-name-nondirectory filename))
+;;	 (dir  (file-name-directory    filename))
+;;	 (comp (file-name-all-completions file dir))
+;;	 newest tem)
+;;    (while comp
+;;      (setq tem (car comp)
+;;	    comp (cdr comp))
+;;      (cond ((and (backup-file-name-p tem)
+;;		  (string= (file-name-sans-versions tem) file))
+;;	     (setq tem (concat dir tem))
+;;	     (if (or (null newest)
+;;		     (file-newer-than-file-p tem newest))
+;;		 (setq newest tem)))))
+;;    newest))
+
+(defun file-newest-backup (filename)
+  "Return most recent backup file for FILENAME or nil if no backups exist.
+*** Changed by \"backup-dir.el\""
+  (let ((comp (bkup-existing-backup-files filename))
+        (newest nil)
+        (file nil))
+    (while comp
+      (setq file (car comp)
+	    comp (cdr comp))
+      (if (and (backup-file-name-p file)
+	       (or (null newest) (file-newer-than-file-p file newest)))
+	  (setq newest file)))
+    newest))
+
+
+;;; patch `latest-backup-file' from "dired"
+;;;
+;;; we use `dired-load-hook' to avoid loading dired now.  This speeds things up
+;;; considerably according to Thomas Feuster, feuster@tp4.physik.uni-giessen.de
+;;;
+;;; one really wonders why there are 3 functions to do the same thing...
+;;;
+(defun bkup-patch-latest-backup-file ()
+  (fset 'latest-backup-file (symbol-function 'file-newest-backup))
+  (remove-hook 'dired-load-hook 'bkup-patch-latest-backup-file))
+
+(if (featurep 'dired)
+    ;; if loaded, patch it now
+    (fset 'latest-backup-file (symbol-function 'file-newest-backup))
+  ;; otherwise do it later
+  (add-hook 'dired-load-hook 'bkup-patch-latest-backup-file))
+
+
+;;; patch `diff-latest-backup-file' from "diff"
+;;;
+(require 'diff)
+(fset 'diff-latest-backup-file (symbol-function 'file-newest-backup))
+
+
+;;; finally, add to list of features
+;;;
+(provide 'backup-dir)
+
+;;; backup-dir.el ends here