diff lisp/files.el @ 28524:98e34e5245c9

(backup-enable-predicate): Use temporary-file-directory, small-temporary-file-directory. (make-backup-file-name-function, backup-directory-alist): New variables. (make-backup-file-name-1): New function. (make-backup-file-name): Use it. (find-backup-file-name): Likewise. Use format for clarity, not concat. (file-newest-backup): Use make-backup-file-name.

--- a/lisp/files.el	Sun Apr 09 11:15:57 2000 +0000
+++ b/lisp/files.el	Sun Apr 09 17:18:48 2000 +0000
@@ -135,10 +135,20 @@
 
 (defvar backup-enable-predicate
   '(lambda (name)
-     (or (< (length name) 5)
-	 (not (string-equal "/tmp/" (substring name 0 5)))))
+     (and (let ((comp (compare-strings temporary-file-directory 0 nil
+				       name 0 nil)))
+	    (and (not (eq comp t))
+		 (< comp -1)))
+	  (if small-temporary-file-directory
+	      (let ((comp (compare-strings small-temporary-file-directory 0 nil
+					   name 0 nil)))
+		(and (not (eq comp t))
+		     (< comp -1)))
+	    t)))
   "Predicate that looks at a file name and decides whether to make backups.
-Called with an absolute file name as argument, it returns t to enable backup.")
+Called with an absolute file name as argument, it returns t to enable backup.
+The default version checks for files in `temporary-file-directory' or
+`small-temporary-file-directory'.")
 
 (defcustom buffer-offer-save nil
   "*Non-nil in a buffer means always offer to save buffer on exit.
@@ -724,7 +734,7 @@
 
 (defun find-file-read-only (filename &optional wildcards)
   "Edit file FILENAME but don't allow changes.
-Like \\[find-file] but marks buffer as read-only.
+Like `find-file' but marks buffer as read-only.
 Use \\[toggle-read-only] to permit editing."
   (interactive "fFind file read-only: \np")
   (find-file filename wildcards)
@@ -1571,10 +1581,9 @@
 		  (if (string-match (car (car alist)) name)
 		      (if (and (consp (cdr (car alist)))
 			       (nth 2 (car alist)))
-			  (progn
-			    (setq mode (car (cdr (car alist)))
-				  name (substring name 0 (match-beginning 0))
-				  keep-going t))
+			  (setq mode (car (cdr (car alist)))
+				name (substring name 0 (match-beginning 0))
+				keep-going t)
 			(setq mode (cdr (car alist))
 			      keep-going nil)))
 		  (setq alist (cdr alist))))
@@ -1593,9 +1602,9 @@
 		(let ((interpreter
 		       (save-excursion
 			 (goto-char (point-min))
-			 (if (looking-at "#![ \t]?\\([^ \t\n]*/bin/env[ \t]\\)?\\([^ \t\n]+\\)")
-			     (buffer-substring (match-beginning 2)
-					       (match-end 2))
+			 (if (looking-at "#![ \t]?\\([^ \t\n]*\
+/bin/env[ \t]\\)?\\([^ \t\n]+\\)")
+			     (match-string 2)
 			   "")))
 		      elt)
 		  ;; Map interpreter name to a mode.
@@ -2173,19 +2182,94 @@
         (if period
             "")))))
 
+(defcustom make-backup-file-name-function nil
+  "A function to use instead of the default `make-backup-file-name'.
+A value of nil gives the default `make-backup-file-name' behaviour.
+
+This could be buffer-local to do something special for for specific
+files.  If you define it, you may need to change `backup-file-name-p'
+and `file-name-sans-versions' too.
+
+See also `backup-directory-alist'."
+  :group 'backup
+  :type '(choice (const :tag "Default" nil)
+		 (function :tag "Your function")))
+
+(defcustom backup-directory-alist nil
+  "Alist of filename patterns and backup directory names.
+Each element looks like (REGEXP . DIRECTORY).  Backups of files with
+names matching REGEXP will be made in DIRECTORY.  DIRECTORY may be
+relative or absolute.  If it is absolute, so that all matching files
+are backed up into the same directory, the file names in this
+directory will be the full name of the file backed up with all
+directory separators changed to `|' to prevent clashes.  This will not
+work correctly if your filesystem truncates the resulting name.
+
+For the common case of all backups going into one directory, the alist
+should contain a single element pairing \".\" with the appropriate
+directory name.
+
+If this variable is nil, or it fails to match a filename, the backup
+is made in the original file's directory.
+
+On MS-DOS filesystems without long names this variable is always
+ignored."
+  :group 'backup
+  :type '(repeat (cons (regexp :tag "Regexp macthing filename")
+		       (directory :tag "Backup directory name"))))
+
 (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)
-		(or
-		 (and (string-match "\\`[^.]+\\'" fn)
-		      (concat (match-string 0 fn) ".~"))
-		 (and (string-match "\\`[^.]+\\.\\(..?\\)?" fn)
-		      (concat (match-string 0 fn) "~")))))
-    (concat file "~")))
+Normally this will just be the file's name with `~' appended.
+Customization hooks are provided as follows.
+
+If the variable `make-backup-file-name-function' is non-nil, its value
+should be a function which will be called with FILE as its argument;
+the resulting name is used.
+
+Otherwise a match for FILE is sought in `backup-directory-alist'; see
+the documentation of that variable.  If the directory for the backup
+doesn't exist, it is created."
+  (if make-backup-file-name-function
+      (funcall make-backup-file-name-function file)
+    (if (and (eq system-type 'ms-dos)
+	     (not (msdos-long-file-names)))
+	(let ((fn (file-name-nondirectory file)))
+	  (concat (file-name-directory file)
+		  (or (and (string-match "\\`[^.]+\\'" fn)
+			   (concat (match-string 0 fn) ".~"))
+		      (and (string-match "\\`[^.]+\\.\\(..?\\)?" fn)
+			   (concat (match-string 0 fn) "~")))))
+      (concat (make-backup-file-name-1 file) "~"))))
+
+(defun make-backup-file-name-1 (file)
+  "Subroutine of `make-backup-file-name' and `find-backup-file-name'."
+  (let ((alist backup-directory-alist)
+	elt backup-directory)
+    (while alist
+      (setq elt (pop alist))
+      (if (string-match (car elt) file)
+	  (setq backup-directory (cdr elt)
+		alist nil)))
+    (if (null backup-directory)
+	file
+      (unless (file-exists-p backup-directory)
+	(condition-case nil
+	    (make-directory backup-directory 'parents)
+	  (file-error file)))
+      (if (file-name-absolute-p backup-directory)
+	  ;; Make the name unique by substituting directory
+	  ;; separators.  It may not really be worth bothering about
+	  ;; doubling `|'s in the original name...
+	  (expand-file-name
+	   (subst-char-in-string
+	    directory-sep-char ?|
+	    (replace-regexp-in-string "|" "||" file))
+	   backup-directory)
+	(expand-file-name (file-name-nondirectory file)
+			  (file-name-as-directory
+			   (expand-file-name backup-directory
+					     (file-name-directory file))))))))
 
 (defun backup-file-name-p (file)
   "Return non-nil if FILE is a backup file name (numeric or not).
@@ -2212,45 +2296,47 @@
 (defun find-backup-file-name (fn)
   "Find a file name for a backup file FN, 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."
+and whose cdr is a list of old versions to consider deleting now.
+If the value is nil, don't make a backup.
+Uses `backup-directory-alist' in the same way as does
+`make-backup-file-name'."
   (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) ".~"))
+	(let* ((basic-name (make-backup-file-name-1 fn))
+	       (base-versions (concat (file-name-nondirectory basic-name)
+				      ".~"))
 	       (backup-extract-version-start (length base-versions))
-	       possibilities
-	       (versions nil)
 	       (high-water-mark 0)
-	       (deserve-versions-p nil)
-	       (number-to-delete 0))
+	       (number-to-delete 0)
+	       possibilities deserve-versions-p versions)
 	  (condition-case ()
 	      (setq possibilities (file-name-all-completions
 				   base-versions
-				   (file-name-directory fn))
-		    versions (sort (mapcar
-				    (function backup-extract-version)
-				    possibilities)
-				   '<)
+				   (file-name-directory basic-name))
+		    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)))
+					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)) "~")
+	      (list (concat basic-name "~"))
+	    (cons (format "%s.~%d~" basic-name (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 (function (lambda (n)
-					  (concat fn ".~" (int-to-string n) "~")))
+		      (mapcar (lambda (n)
+				(format "%s.~%d~" basic-name n))
 			      (let ((v (nthcdr kept-old-versions versions)))
 				(rplacd (nthcdr (1- number-to-delete) v) ())
 				v))))))))))
@@ -2651,15 +2737,18 @@
 
 (defun file-newest-backup (filename)
   "Return most recent backup file for FILENAME or nil if no backups exist."
-  (let* ((filename (expand-file-name filename))
+  ;; `make-backup-file-name' will get us the right directory for
+  ;; ordinary or numeric backups.  It might create a directory for
+  ;; backups as a side-effect, according to `backup-directory-alist'.
+  (let* ((filename (file-name-sans-versions
+		    (make-backup-file-name filename)))
 	 (file (file-name-nondirectory filename))
 	 (dir  (file-name-directory    filename))
 	 (comp (file-name-all-completions file dir))
          (newest nil)
          tem)
     (while comp
-      (setq tem (car comp)
-	    comp (cdr comp))
+      (setq tem (pop comp))
       (cond ((and (backup-file-name-p tem)
                   (string= (file-name-sans-versions tem) file))
              (setq tem (concat dir tem))