Mercurial > hg > xemacs-beta

comparison lisp/packages/backup-dir.el @ 12:bcdc7deadc19 r19-15b7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b7
author cvs
date Mon, 13 Aug 2007 08:48:16 +0200
parents
children e45d5e7c476e
comparison
equal deleted inserted replaced
11:91ffe8bd52e4 12:bcdc7deadc19
1 ;;; BACKUP-DIR.EL: Emacs functions to allow backup files to live in
2 ;;; some other directory(s). Version 2.0
3 ;;;
4 ;;; Copyright (C) 1992-97 Greg Klanderman
5 ;;;
6 ;;; This program is free software; you can redistribute it and/or modify
7 ;;; it under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 1, or (at your option)
9 ;;; any later version.
10 ;;;
11 ;;; This program is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
15 ;;;
16 ;;; A copy of the GNU General Public License can be obtained from
17 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
18 ;;; 02139, USA.
19 ;;;
20 ;;; Send bug reports, etc. to greg@alphatech.com or gregk@ai.mit.edu.
21 ;;;
22 ;;;
23 ;;; Modification History
24 ;;; ====================
25 ;;;
26 ;;; 12/28/1996 Version 2.0
27 ;;; Updated for XEmacs 19.15b4, much of code reorganized & cleaned up
28 ;;;
29 ;;; 12/27/1996 Version 1.6
30 ;;; explicit loading of dired replaced to use dired-load-hook
31 ;;; (suggested by Thomas Feuster, feuster@tp4.physik.uni-giessen.de)
32 ;;;
33 ;;; 12/2/1996 Version 1.5
34 ;;; Took out obsolete byte compiler options
35 ;;;
36 ;;; 9/24/1996 Version 1.4
37 ;;; Fix some bugs, change to alist OPTIONS list (ok-create, full-path..) from
38 ;;; separate fields for each option variable. Added search-upward option.
39 ;;; Added new function `find-file-latest-backup' to find a file's latest backup.
40 ;;;
41 ;;; 1/26/1996 Version 1.3
42 ;;; Name change to backup-dir.el
43 ;;;
44 ;;; 3/22/1995 Version 1.2
45 ;;; Added new definitions for functions `file-newest-backup', `latest-backup-file',
46 ;;; and `diff-latest-backup-file' so various other emacs functions will find the
47 ;;; right backup files.
48 ;;;
49 ;;; 4/23/1993 Version 1.1
50 ;;; Reworked to allow different behavior for different files based on the
51 ;;; alist `bkup-backup-directory-info'.
52 ;;;
53 ;;; Fall 1992 Version 1.0
54 ;;; Name change and added ability to make directories absolute. Added the
55 ;;; full path stuff to make backup name unique for absolute directories.
56 ;;;
57 ;;; Spring 1992 Version 0.0
58 ;;; Original
59 ;;;
60 ;;;
61 ;;; Description:
62 ;;; ============
63 ;;;
64 ;;; Allows backup files to be optionally stored in some directories, based on
65 ;;; the value of the alist, `bkup-backup-directory-info'. This variable is a
66 ;;; list of lists of the form (FILE-REGEXP BACKUP-DIR OPTIONS ...). If the
67 ;;; filename to be backed up matches FILE-REGEXP, or FILE-REGEXP is t, then
68 ;;; BACKUP-DIR is used as the path for its backups. Directories may begin with
69 ;;; "/" to specify an absolute pathname. If BACKUP-DIR does not exist and
70 ;;; OPTIONS contains the symbol `ok-create', then it is created if possible.
71 ;;; Otherwise the usual behavior (backup in the same directory as the file)
72 ;;; results. If OPTIONS contains the symbol `full-path', then the full path of
73 ;;; the file being backed up is prepended to the backup file name, with each "/"
74 ;;; replaced by a "!". This is intended for cases where an absolute backup path
75 ;;; is used. If OPTIONS contains the symbol `search-upward' and the backup
76 ;;; directory BACKUP-DIR is a relative path, then a directory with that name is
77 ;;; searched for starting at the current directory and proceeding upward (..,
78 ;;; ../.., etc) until one is found of that name or the root is reached, and if
79 ;;; one is found it is used as the backup directory. Finally, if no FILE-REGEXP
80 ;;; matches the file name being backed up, then the usual behavior results.
81 ;;;
82 ;;; These lines from my .emacs load this file and set the values I like:
83 ;;;
84 ;;; (require 'backup-dir)
85 ;;; (setq bkup-backup-directory-info
86 ;;; '(("/home/greg/.*" "/~/.backups/" ok-create full-path)
87 ;;; (t ".backups/" full-path search-upward)))
88 ;;;
89 ;;;
90 ;;; The package also provides a new function, `find-file-latest-backup' to find
91 ;;; the latest backup file for the current buffer's file.
92 ;;;
93 ;;;
94 ;;; This file is based on `files.el' from XEmacs 19.15b4.
95 ;;; It has not been extensively tested on GNU Emacs past 18.58.
96 ;;; It does not work under ms-dos.
97
98
99
100 (byte-compiler-options
101 (optimize t)
102 (warnings (- free-vars)) ; Don't warn about free variables
103 )
104
105
106 ;;; New variables affecting backup file behavior
107 ;;; This is the only user-customizable variable for this package.
108 ;;;
109 (defvar bkup-backup-directory-info nil
110 "Alist of (FILE-REGEXP BACKUP-DIR OPTIONS ...))
111 If the filename to be backed up matches FILE-REGEXP, or FILE-REGEXP is t,
112 then BACKUP-DIR is used as the path for its backups. Directories may
113 begin with \"/\" to specify an absolute pathname. If BACKUP-DIR does
114 not exist and OPTIONS contains the symbol `ok-create', then it is created if possible.
115 Otherwise the usual behavior (backup in the same directory as the file)
116 results. If OPTIONS contains the symbol `full-path', then the full path of the file
117 being backed up is prepended to the backup file name, with each \"/\"
118 replaced by a \"!\". This is intended for cases where an absolute backup path
119 is used. If OPTIONS contains the symbol `search-upward' and the backup
120 directory BACKUP-DIR is a relative path, then a directory with that name is
121 searched for starting at the current directory and proceeding upward (..,
122 ../.., etc) until one is found of that name or the root is reached, and if
123 one is found it is used as the backup directory. Finally, if no FILE-REGEXP
124 matches the file name being backed up, then the usual behavior results.")
125
126
127 ;;; New functions
128 ;;;
129 (defun bkup-search-upward-for-backup-dir (base bd-name)
130 "search upward for a directory named BD-NAME, starting in the
131 directory BASE and continuing with its parent directories until
132 one is found or the root is reached."
133 (let ((prev nil) (curr base) (gotit nil) (tryit nil))
134 (while (and (not gotit)
135 (not (equal prev curr))
136 (not (equal curr "//")))
137 (setq prev curr)
138 (setq curr (expand-file-name (concat curr "../")))
139 (setq tryit (expand-file-name bd-name curr))
140 (if (and (file-directory-p tryit) (file-exists-p tryit))
141 (setq gotit tryit)))
142 (if (and gotit
143 (eq (aref gotit (1- (length gotit))) ?/))
144 (setq gotit (substring gotit 0 (1- (length gotit)))))
145 gotit))
146
147 (defun bkup-replace-slashes-with-exclamations (s)
148 "Replaces slashes in the string S with exclamations.
149 A new string is produced and returned."
150 (let ((ns (copy-sequence s))
151 (i (1- (length s))))
152 (while (>= i 0)
153 (if (= (aref ns i) ?/)
154 (aset ns i ?!))
155 (setq i (1- i)))
156 ns))
157
158 (defun bkup-try-making-directory (dir)
159 "try making directory DIR, return non-nil if successful"
160 (condition-case ()
161 (progn (make-directory dir t)
162 t)
163 (t
164 nil)))
165
166 (defun bkup-backup-basename (file full-path)
167 "Gives the base part of the backup name for FILE, according to FULL-PATH."
168 (if full-path
169 (bkup-replace-slashes-with-exclamations file)
170 (file-name-nondirectory file)))
171
172 (defun bkup-backup-directory-and-basename (file)
173 "Return the cons of the backup directory name
174 and backup file name base for FILE."
175 (let ((file (expand-file-name file)))
176 (let ((dir (file-name-directory file))
177 (alist bkup-backup-directory-info)
178 (bk-dir nil)
179 (bk-base nil))
180 (if (listp alist)
181 (while (and (not bk-dir) alist)
182 (if (or (eq (car (car alist)) t)
183 (eq (string-match (car (car alist)) file) 0))
184 (let* ((bd (car (cdr (car alist))))
185 (bd-rel-p (and (> (length bd) 0)
186 (not (eq (aref bd 0) ?/))))
187 (bd-expn (expand-file-name bd dir))
188 (bd-noslash (if (eq (aref bd-expn (1- (length bd-expn))) ?/)
189 (substring bd-expn 0 (1- (length bd-expn)))
190 bd-expn))
191 (options (cdr (cdr (car alist))))
192 (ok-create (and (memq 'ok-create options) t))
193 (full-path (and (memq 'full-path options) t))
194 (search-upward (and (memq 'search-upward options) t)))
195 (if bd-expn
196 (cond ((or (file-directory-p bd-expn)
197 (and ok-create
198 (not (file-exists-p bd-expn))
199 (bkup-try-making-directory bd-noslash)))
200 (setq bk-dir (concat bd-noslash "/")
201 bk-base (bkup-backup-basename file full-path)))
202 ((and bd-rel-p search-upward)
203 (let ((bd-up (bkup-search-upward-for-backup-dir dir bd)))
204 (if bd-up
205 (setq bk-dir (concat bd-up "/")
206 bk-base (bkup-backup-basename file full-path)))))))))
207 (setq alist (cdr alist))))
208 (if (and bk-dir bk-base)
209 (cons bk-dir bk-base)
210 (cons dir (bkup-backup-basename file nil))))))
211
212
213 ;;; This next one is based on the following from `files.el'
214 ;;; but accepts a second optional argument
215
216 ;;(defun make-backup-file-name (file)
217 ;; "Create the non-numeric backup file name for FILE.
218 ;;This is a separate function so you can redefine it for customization."
219 ;; (if (and (eq system-type 'ms-dos)
220 ;; (not (msdos-long-file-names)))
221 ;; (let ((fn (file-name-nondirectory file)))
222 ;; (concat (file-name-directory file)
223 ;; (if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn)
224 ;; (substring fn 0 (match-end 1)))
225 ;; ".bak"))
226 ;; (concat file "~")))
227
228 (defun bkup-make-backup-file-name (file &optional dir-n-base)
229 "Create the non-numeric backup file name for FILE.
230 Optionally accept a list containing the backup directory and
231 backup basename. NB: we don't really handle ms-dos."
232 (if (and (eq system-type 'ms-dos)
233 (not (and (fboundp 'msdos-long-file-names) (msdos-long-file-names))))
234 (let ((fn (file-name-nondirectory file)))
235 (concat (file-name-directory file)
236 (if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn)
237 (substring fn 0 (match-end 1)))
238 ".bak"))
239 (let ((d-n-b (or dir-n-base
240 (bkup-backup-directory-and-basename file))))
241 (concat (car d-n-b) (cdr d-n-b) "~"))))
242
243 (defun bkup-existing-backup-files (fn)
244 "Return list of existing backup files for file"
245 (let* ((efn (expand-file-name fn))
246 (dir-n-base (bkup-backup-directory-and-basename efn))
247 (non-num-bk-name (bkup-make-backup-file-name efn dir-n-base))
248 (non-num-bk (file-exists-p non-num-bk-name))
249 (backup-dir (car dir-n-base))
250 (base-versions (concat (cdr dir-n-base) ".~"))
251 (possibilities (file-name-all-completions base-versions backup-dir))
252 (poss (mapcar #'(lambda (name) (concat backup-dir name)) possibilities)))
253 (mapcar #'expand-file-name
254 (if non-num-bk (cons non-num-bk-name poss) poss))))
255
256 (defun find-file-latest-backup (file)
257 "Find the latest backup file for FILE"
258 (interactive (list (read-file-name (format "Find latest backup of file (default %s): "
259 (file-name-nondirectory (buffer-file-name)))
260 nil (buffer-file-name) t)))
261 (let ((backup (file-newest-backup file)))
262 (if backup
263 (find-file backup)
264 (message "no backups found for `%s'" file))))
265
266
267 ;;; Functions changed from `files.el' and elsewhere -- originals precede new versions
268
269 ;;(defun make-backup-file-name (file)
270 ;; "Create the non-numeric backup file name for FILE.
271 ;;This is a separate function so you can redefine it for customization."
272 ;; (if (and (eq system-type 'ms-dos)
273 ;; (not (msdos-long-file-names)))
274 ;; (let ((fn (file-name-nondirectory file)))
275 ;; (concat (file-name-directory file)
276 ;; (if (string-match "\\([^.]*\\)\\(\\..*\\)?" fn)
277 ;; (substring fn 0 (match-end 1)))
278 ;; ".bak"))
279 ;; (concat file "~")))
280
281 (defun make-backup-file-name (file)
282 "Create the non-numeric backup file name for FILE.
283 This is a separate function so you can redefine it for customization.
284 *** Changed by \"backup-dir.el\""
285 (bkup-make-backup-file-name file))
286
287
288 ;;(defun find-backup-file-name (fn)
289 ;; "Find a file name for a backup file, and suggestions for deletions.
290 ;;Value is a list whose car is the name for the backup file
291 ;; and whose cdr is a list of old versions to consider deleting now.
292 ;;If the value is nil, don't make a backup."
293 ;; (let ((handler (find-file-name-handler fn 'find-backup-file-name)))
294 ;; ;; Run a handler for this function so that ange-ftp can refuse to do it.
295 ;; (if handler
296 ;; (funcall handler 'find-backup-file-name fn)
297 ;; (if (eq version-control 'never)
298 ;; (list (make-backup-file-name fn))
299 ;; (let* ((base-versions (concat (file-name-nondirectory fn) ".~"))
300 ;; ;; used by backup-extract-version:
301 ;; (bv-length (length base-versions))
302 ;; possibilities
303 ;; (versions nil)
304 ;; (high-water-mark 0)
305 ;; (deserve-versions-p nil)
306 ;; (number-to-delete 0))
307 ;; (condition-case ()
308 ;; (setq possibilities (file-name-all-completions
309 ;; base-versions
310 ;; (file-name-directory fn))
311 ;; versions (sort (mapcar
312 ;; #'backup-extract-version
313 ;; possibilities)
314 ;; '<)
315 ;; high-water-mark (apply #'max 0 versions)
316 ;; deserve-versions-p (or version-control
317 ;; (> high-water-mark 0))
318 ;; number-to-delete (- (length versions)
319 ;; kept-old-versions kept-new-versions -1))
320 ;; (file-error
321 ;; (setq possibilities nil)))
322 ;; (if (not deserve-versions-p)
323 ;; (list (make-backup-file-name fn))
324 ;; (cons (concat fn ".~" (int-to-string (1+ high-water-mark)) "~")
325 ;; (if (and (> number-to-delete 0)
326 ;; ;; Delete nothing if there is overflow
327 ;; ;; in the number of versions to keep.
328 ;; (>= (+ kept-new-versions kept-old-versions -1) 0))
329 ;; (mapcar #'(lambda (n)
330 ;; (concat fn ".~" (int-to-string n) "~"))
331 ;; (let ((v (nthcdr kept-old-versions versions)))
332 ;; (rplacd (nthcdr (1- number-to-delete) v) ())
333 ;; v))))))))))
334
335 (defun find-backup-file-name (fn)
336 "Find a file name for a backup file, and suggestions for deletions.
337 Value is a list whose car is the name for the backup file
338 and whose cdr is a list of old versions to consider deleting now.
339 If the value is nil, don't make a backup.
340 *** Changed by \"backup-dir.el\""
341 (let ((handler (find-file-name-handler fn 'find-backup-file-name)))
342 ;; Run a handler for this function so that ange-ftp can refuse to do it.
343 (if handler
344 (funcall handler 'find-backup-file-name fn)
345 (if (eq version-control 'never)
346 (list (make-backup-file-name fn))
347 (let* ((dir-n-base (bkup-backup-directory-and-basename fn)) ;add
348 (non-num-bk-name (bkup-make-backup-file-name fn dir-n-base)) ;add
349 (bk-dir (car dir-n-base)) ;add
350 (bk-base (cdr dir-n-base)) ;add
351 (base-versions (concat bk-base ".~")) ;mod
352 ;; used by backup-extract-version:
353 (bv-length (length base-versions))
354 possibilities
355 (versions nil)
356 (high-water-mark 0)
357 (deserve-versions-p nil)
358 (number-to-delete 0))
359 (condition-case ()
360 (setq possibilities (file-name-all-completions
361 base-versions
362 bk-dir) ;mod
363 versions (sort (mapcar
364 #'backup-extract-version
365 possibilities)
366 '<)
367 high-water-mark (apply #'max 0 versions)
368 deserve-versions-p (or version-control
369 (> high-water-mark 0))
370 number-to-delete (- (length versions)
371 kept-old-versions kept-new-versions -1))
372 (file-error
373 (setq possibilities nil)))
374 (if (not deserve-versions-p)
375 (list (bkup-make-backup-file-name fn dir-n-base)) ;mod
376 (cons (concat bk-dir base-versions (int-to-string (1+ high-water-mark)) "~") ;mod
377 (if (and (> number-to-delete 0)
378 ;; Delete nothing if there is overflow
379 ;; in the number of versions to keep.
380 (>= (+ kept-new-versions kept-old-versions -1) 0))
381 (mapcar #'(lambda (n)
382 (concat bk-dir base-versions (int-to-string n) "~")) ;mod
383 (let ((v (nthcdr kept-old-versions versions)))
384 (rplacd (nthcdr (1- number-to-delete) v) ())
385 v))))))))))
386
387
388 ;;(defun file-newest-backup (filename)
389 ;; "Return most recent backup file for FILENAME or nil if no backups exist."
390 ;; (let* ((filename (expand-file-name filename))
391 ;; (file (file-name-nondirectory filename))
392 ;; (dir (file-name-directory filename))
393 ;; (comp (file-name-all-completions file dir))
394 ;; newest tem)
395 ;; (while comp
396 ;; (setq tem (car comp)
397 ;; comp (cdr comp))
398 ;; (cond ((and (backup-file-name-p tem)
399 ;; (string= (file-name-sans-versions tem) file))
400 ;; (setq tem (concat dir tem))
401 ;; (if (or (null newest)
402 ;; (file-newer-than-file-p tem newest))
403 ;; (setq newest tem)))))
404 ;; newest))
405
406 (defun file-newest-backup (filename)
407 "Return most recent backup file for FILENAME or nil if no backups exist.
408 *** Changed by \"backup-dir.el\""
409 (let ((comp (bkup-existing-backup-files filename))
410 (newest nil)
411 (file nil))
412 (while comp
413 (setq file (car comp)
414 comp (cdr comp))
415 (if (and (backup-file-name-p file)
416 (or (null newest) (file-newer-than-file-p file newest)))
417 (setq newest file)))
418 newest))
419
420
421 ;;; patch `latest-backup-file' from "dired"
422 ;;;
423 ;;; we use `dired-load-hook' to avoid loading dired now. This speeds things up
424 ;;; considerably according to Thomas Feuster, feuster@tp4.physik.uni-giessen.de
425 ;;;
426 ;;; one really wonders why there are 3 functions to do the same thing...
427 ;;;
428 (defun bkup-patch-latest-backup-file ()
429 (fset 'latest-backup-file (symbol-function 'file-newest-backup))
430 (remove-hook 'dired-load-hook 'bkup-patch-latest-backup-file))
431
432 (if (featurep 'dired)
433 ;; if loaded, patch it now
434 (fset 'latest-backup-file (symbol-function 'file-newest-backup))
435 ;; otherwise do it later
436 (add-hook 'dired-load-hook 'bkup-patch-latest-backup-file))
437
438
439 ;;; patch `diff-latest-backup-file' from "diff"
440 ;;;
441 (require 'diff)
442 (fset 'diff-latest-backup-file (symbol-function 'file-newest-backup))
443
444
445 ;;; finally, add to list of features
446 ;;;
447 (provide 'backup-dir)
448
449 ;;; backup-dir.el ends here