Merge from gnus--rel--5.10
[emacs.git] / lisp / uniquify.el
blob24b49a983ad7fd6c6ecf1551a7776b840694f6a1
1 ;;; uniquify.el --- unique buffer names dependent on file name
3 ;; Copyright (C) 1989, 1995, 1996, 1997, 2001, 2002, 2003,
4 ;; 2004, 2005, 2006 Free Software Foundation, Inc.
6 ;; Author: Dick King <king@reasoning.com>
7 ;; Maintainer: FSF
8 ;; Keywords: files
9 ;; Created: 15 May 86
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26 ;; Boston, MA 02110-1301, USA.
28 ;;; Commentary:
30 ;; Emacs's standard method for making buffer names unique adds <2>, <3>,
31 ;; etc. to the end of (all but one of) the buffers. This file replaces
32 ;; that behavior, for buffers visiting files and dired buffers, with a
33 ;; uniquification that adds parts of the file name until the buffer names
34 ;; are unique. For instance, buffers visiting /u/mernst/tmp/Makefile and
35 ;; /usr/projects/zaphod/Makefile would be named Makefile|tmp and
36 ;; Makefile|zaphod, respectively (instead of Makefile and Makefile<2>).
37 ;; Other buffer name styles are also available.
39 ;; To use this file, do (require 'uniquify)
40 ;; and set uniquify-buffer-name-style to one of its non-nil alternative values.
42 ;; For other options, see "User-visible variables", below.
44 ;; A version of uniquify.el that works under Emacs 18, Emacs 19, XEmacs,
45 ;; and InfoDock is available from the maintainer.
47 ;;; Change Log:
49 ;; Originally by Dick King <king@reasoning.com> 15 May 86
50 ;; Converted for Emacs 18 by Stephen Gildea <gildea@stop.mail-abuse.org>
51 ;; Make uniquify-min-dir-content 0 truly non-invasive. gildea 23 May 89
52 ;; Some cleanup. uniquify-min-dir-content default 0. gildea 01 Jun 89
53 ;; Don't rename to "". Michael Ernst <mernst@theory.lcs.mit.edu> 15 Jun 94
54 ;; Add kill-buffer-hook. Kenneth Manheimer <ken.manheimer@nist.gov> 09 May 95
55 ;; Add advice for rename-buffer and create-file-buffer, handle dired buffers,
56 ;; kill-buffer-rationalize-buffer-names-p, documentation. mernst 24 May 95
57 ;; Remove free variables, fix typos. mernst 5 Jun 95
58 ;; Efficiently support Emacs 19.27 & earlier. ken.manheimer, mernst 10 Jun 95
59 ;; Rename user options to "uniquify-...", add uniquify-reverse-dir-content-p,
60 ;; add uniquify-ask-about-buffer-names-p. king, mernst 13 Jun 95
61 ;; Prefix functions by "uniquify-..."; rename mnemonic-buffer-names to
62 ;; uniquify-buffer-name-style; add 'forward and 'post-forward-angle-brackets
63 ;; styles; remove uniquify-reverse-dir-content-p; add
64 ;; uniquify-trailing-separator-p. mernst 4 Aug 95
65 ;; Don't call expand-file-name on nil. mernst 7 Jan 96
66 ;; Check whether list-buffers-directory is bound. mernst 11 Oct 96
67 ;; Ignore non-file non-dired buffers. Colin Rafferty <craffert@ml.com> 3 Mar 97
68 ;; Use last component, not "", for file name of directories. mernst 27 Jun 97
69 ;; Use directory-file-name; code cleanup. mernst 6 Sep 97
70 ;; Add uniquify-ignore-buffers-re.
71 ;; Andre Srinivasan <andre@visigenic.com> 9 Sep 97
72 ;; Add uniquify-list-buffers-directory-modes
73 ;; Stefan Monnier <monnier@cs.yale.edu> 17 Nov 2000
74 ;; Algorithm and data structure changed to reduce consing with lots of buffers
75 ;; Francesco Potortì <pot@gnu.org> (ideas by rms and monnier) 2001-07-18
77 ;; Valuable feedback was provided by
78 ;; Paul Smith <psmith@baynetworks.com>,
79 ;; Alastair Burt <burt@dfki.uni-kl.de>,
80 ;; Bob Weiner <weiner@footloose.sps.mot.com>,
81 ;; Albert L. Ting <alt@vlibs.com>,
82 ;; gyro@reasoning.com,
83 ;; Bryan O'Sullivan <bos@eng.sun.com>.
86 ;;; Code:
88 (eval-when-compile (require 'cl))
90 ;;; User-visible variables
92 (defgroup uniquify nil
93 "Unique buffer names dependent on file name."
94 :group 'applications)
97 (defcustom uniquify-buffer-name-style nil
98 "*If non-nil, buffer names are uniquified with parts of directory name.
99 The value determines the buffer name style and is one of `forward',
100 `reverse', `post-forward', or `post-forward-angle-brackets'.
101 For example, files `/foo/bar/mumble/name' and `/baz/quux/mumble/name'
102 would have the following buffer names in the various styles:
103 forward bar/mumble/name quux/mumble/name
104 reverse name\\mumble\\bar name\\mumble\\quux
105 post-forward name|bar/mumble name|quux/mumble
106 post-forward-angle-brackets name<bar/mumble> name<quux/mumble>
107 nil name name<2>"
108 :type '(radio (const forward)
109 (const reverse)
110 (const post-forward)
111 (const post-forward-angle-brackets)
112 (const :tag "standard Emacs behavior (nil)" nil))
113 :require 'uniquify
114 :group 'uniquify)
116 (defcustom uniquify-after-kill-buffer-p t
117 "If non-nil, rerationalize buffer names after a buffer has been killed."
118 :type 'boolean
119 :group 'uniquify)
121 (defcustom uniquify-ask-about-buffer-names-p nil
122 "*If non-nil, permit user to choose names for buffers with same base file.
123 If the user chooses to name a buffer, uniquification is preempted and no
124 other buffer names are changed."
125 :type 'boolean
126 :group 'uniquify)
128 ;; The default value matches certain Gnus buffers.
129 (defcustom uniquify-ignore-buffers-re nil
130 "*Regular expression matching buffer names that should not be uniquified.
131 For instance, set this to \"^draft-[0-9]+$\" to avoid having uniquify rename
132 draft buffers even if `uniquify-after-kill-buffer-p' is non-nil and the
133 visited file name isn't the same as that of the buffer."
134 :type '(choice (const :tag "Uniquify all buffers" nil) regexp)
135 :group 'uniquify)
137 (defcustom uniquify-min-dir-content 0
138 "*Minimum number of directory name components included in buffer name."
139 :type 'integer
140 :group 'uniquify)
142 (defcustom uniquify-separator nil
143 "*String separator for buffer name components.
144 When `uniquify-buffer-name-style' is `post-forward', separates
145 base file name from directory part in buffer names (default \"|\").
146 When `uniquify-buffer-name-style' is `reverse', separates all
147 file name components (default \"\\\")."
148 :type '(choice (const nil) string)
149 :group 'uniquify)
151 (defcustom uniquify-trailing-separator-p nil
152 "*If non-nil, add a file name separator to dired buffer names.
153 If `uniquify-buffer-name-style' is `forward', add the separator at the end;
154 if it is `reverse', add the separator at the beginning; otherwise, this
155 variable is ignored."
156 :type 'boolean
157 :group 'uniquify)
159 (defcustom uniquify-strip-common-suffix
160 ;; Using it when uniquify-min-dir-content>0 doesn't make much sense.
161 (eq 0 uniquify-min-dir-content)
162 "If non-nil, strip common directory suffixes of conflicting files.
163 E.g. if you open /a1/b/c/d and /a2/b/c/d, the buffer names will say
164 \"d|a1\" and \"d|a2\" instead of \"d|a1/b/c\" and \"d|a2/b/c\".
165 This can be handy when you have deep parallel hierarchies."
166 :type 'boolean
167 :group 'uniquify)
169 (defvar uniquify-list-buffers-directory-modes '(dired-mode cvs-mode)
170 "List of modes for which uniquify should obey `list-buffers-directory'.
171 That means that when `buffer-file-name' is set to nil, `list-buffers-directory'
172 contains the name of the directory which the buffer is visiting.")
174 ;;; Utilities
176 ;; uniquify-fix-list data structure
177 (defstruct (uniquify-item
178 (:constructor nil) (:copier nil)
179 (:constructor uniquify-make-item
180 (base dirname buffer &optional proposed)))
181 base dirname buffer proposed)
183 ;; Internal variables used free
184 (defvar uniquify-possibly-resolvable nil)
186 (defvar uniquify-managed nil
187 "Non-nil if the name of this buffer is managed by uniquify.
188 It actually holds the list of `uniquify-item's corresponding to the conflict.")
189 (make-variable-buffer-local 'uniquify-managed)
190 (put 'uniquify-managed 'permanent-local t)
192 ;;; Main entry point.
194 (defun uniquify-rationalize-file-buffer-names (base dirname newbuf)
195 "Make file buffer names unique by adding segments from file name.
196 If `uniquify-min-dir-content' > 0, always pulls that many
197 file name elements.
198 Arguments BASE, DIRNAME, and NEWBUF specify the new buffer that causes
199 this rationalization."
200 (interactive
201 (list (if uniquify-managed
202 (uniquify-item-base (car uniquify-managed)) (buffer-name))
203 (uniquify-buffer-file-name (current-buffer))
204 (current-buffer)))
205 ;; Make sure we don't get confused by outdated uniquify-managed info in
206 ;; this buffer.
207 (with-current-buffer newbuf (setq uniquify-managed nil))
208 (when dirname
209 (setq dirname (expand-file-name (directory-file-name dirname)))
210 (let ((fix-list (list (uniquify-make-item base dirname newbuf)))
211 items)
212 (dolist (buffer (buffer-list))
213 (when (and (not (and uniquify-ignore-buffers-re
214 (string-match uniquify-ignore-buffers-re
215 (buffer-name buffer))))
216 ;; Only try to rename buffers we actually manage.
217 (setq items (buffer-local-value 'uniquify-managed buffer))
218 (equal base (uniquify-item-base (car items)))
219 ;; Don't re-add stuff we already have. Actually this
220 ;; whole `and' test should only match at most once.
221 (not (memq (car items) fix-list)))
222 (unless (cdr items)
223 ;; If there was no conflict, the buffer-name is equal to the
224 ;; base-name and we may have missed a rename-buffer because
225 ;; of code like in set-visited-file-name:
226 ;; (or (string= new-name (buffer-name)) (rename-buffer new-name t))
227 ;; So we need to refresh the dirname of the uniquify-item.
228 (setf (uniquify-item-dirname (car items))
229 (uniquify-buffer-file-name
230 (uniquify-item-buffer (car items))))
231 ;; This shouldn't happen, but maybe there's no dirname any more.
232 (unless (uniquify-item-dirname (car items))
233 (with-current-buffer (uniquify-item-buffer (car items))
234 (setq uniquify-managed nil))
235 (setq items nil)))
236 (setq fix-list (append fix-list items))))
237 ;; selects buffers whose names may need changing, and others that
238 ;; may conflict, then bring conflicting names together
239 (uniquify-rationalize fix-list))))
241 ;; uniquify's version of buffer-file-name; result never contains trailing slash
242 (defun uniquify-buffer-file-name (buffer)
243 "Return name of directory, file BUFFER is visiting, or nil if none.
244 Works on ordinary file-visiting buffers and buffers whose mode is mentioned
245 in `uniquify-list-buffers-directory-modes', otherwise returns nil."
246 (with-current-buffer buffer
247 (let ((filename
248 (or buffer-file-name
249 (if (memq major-mode uniquify-list-buffers-directory-modes)
250 list-buffers-directory))))
251 (when filename
252 (directory-file-name
253 (file-name-directory
254 (expand-file-name
255 (directory-file-name filename))))))))
257 (defun uniquify-rerationalize-w/o-cb (fix-list)
258 "Re-rationalize the buffers in FIX-LIST, but ignoring current-buffer."
259 (let ((new-fix-list nil))
260 (dolist (item fix-list)
261 (let ((buf (uniquify-item-buffer item)))
262 (unless (or (eq buf (current-buffer)) (not (buffer-live-p buf)))
263 (push item new-fix-list))))
264 (when new-fix-list
265 (uniquify-rationalize new-fix-list))))
267 (defun uniquify-rationalize (fix-list)
268 ;; Set up uniquify to re-rationalize after killing/renaming
269 ;; if there is a conflict.
270 (dolist (item fix-list)
271 (with-current-buffer (uniquify-item-buffer item)
272 ;; Refresh the dirnames and proposed names.
273 (setf (uniquify-item-proposed item)
274 (uniquify-get-proposed-name (uniquify-item-base item)
275 (uniquify-item-dirname item)))
276 (setq uniquify-managed fix-list)))
277 ;; Strip any shared last directory names of the dirname.
278 (when (and (cdr fix-list) uniquify-strip-common-suffix)
279 (let ((strip t))
280 (while (let* ((base (file-name-nondirectory
281 (uniquify-item-dirname (car fix-list))))
282 (items fix-list))
283 (when (> (length base) 0)
284 (while (and strip items)
285 (unless (equal base (file-name-nondirectory
286 (uniquify-item-dirname (pop items))))
287 (setq strip nil)))
288 strip))
289 ;; It's all the same => strip.
290 (dolist (item (prog1 fix-list (setq fix-list nil)))
291 ;; Create new items because the old ones are kept (with the true
292 ;; `dirname') for later rerationalizing.
293 (push (uniquify-make-item (uniquify-item-base item)
294 (let ((f (file-name-directory
295 (uniquify-item-dirname item))))
296 (and f (directory-file-name f)))
297 (uniquify-item-buffer item)
298 (uniquify-item-proposed item))
299 fix-list)))))
300 ;; If uniquify-min-dir-content is 0, this will end up just
301 ;; passing fix-list to uniquify-rationalize-conflicting-sublist.
302 (uniquify-rationalize-a-list fix-list))
304 (defun uniquify-item-greaterp (item1 item2)
305 (string-lessp (uniquify-item-proposed item2)
306 (uniquify-item-proposed item1)))
308 (defun uniquify-rationalize-a-list (fix-list &optional depth)
309 (unless depth (setq depth uniquify-min-dir-content))
310 (let (conflicting-sublist ; all elements have the same proposed name
311 (old-proposed "")
312 proposed)
313 ;; Divide fix-list into items with same proposed names and pass them
314 ;; to uniquify-rationalize-conflicting-sublist.
315 (dolist (item (sort fix-list 'uniquify-item-greaterp))
316 (setq proposed (uniquify-item-proposed item))
317 (unless (equal proposed old-proposed)
318 (uniquify-rationalize-conflicting-sublist conflicting-sublist
319 old-proposed depth)
320 (setq conflicting-sublist nil))
321 (push item conflicting-sublist)
322 (setq old-proposed proposed))
323 (uniquify-rationalize-conflicting-sublist conflicting-sublist
324 old-proposed depth)))
326 (defun uniquify-get-proposed-name (base dirname &optional depth)
327 (unless depth (setq depth uniquify-min-dir-content))
328 (assert (equal (directory-file-name dirname) dirname)) ;No trailing slash.
330 ;; Distinguish directories by adding extra separator.
331 (if (and uniquify-trailing-separator-p
332 (file-directory-p (expand-file-name base dirname))
333 (not (string-equal base "")))
334 (cond ((eq uniquify-buffer-name-style 'forward)
335 (setq base (file-name-as-directory base)))
336 ;; (setq base (concat base "/")))
337 ((eq uniquify-buffer-name-style 'reverse)
338 (setq base (concat (or uniquify-separator "\\") base)))))
340 (let ((extra-string nil)
341 (n depth))
342 (while (and (> n 0) dirname)
343 (let ((file (file-name-nondirectory dirname)))
344 (when (setq dirname (file-name-directory dirname))
345 (setq dirname (directory-file-name dirname)))
346 (setq n (1- n))
347 (push (if (zerop (length file)) ;nil or "".
348 (prog1 "" (setq dirname nil)) ;Could be `dirname' iso "".
349 file)
350 extra-string)))
351 (when (zerop n)
352 (if (and dirname extra-string
353 (equal dirname (file-name-directory dirname)))
354 ;; We're just before the root. Let's add the leading / already.
355 ;; With "/a/b"+"/c/d/b" this leads to "/a/b" and "d/b" but with
356 ;; "/a/b"+"/c/a/b" this leads to "/a/b" and "a/b".
357 (push "" extra-string))
358 (setq uniquify-possibly-resolvable t))
360 (cond
361 ((null extra-string) base)
362 ((string-equal base "") ;Happens for dired buffers on the root directory.
363 (mapconcat 'identity extra-string "/"))
364 ((eq uniquify-buffer-name-style 'reverse)
365 (mapconcat 'identity
366 (cons base (nreverse extra-string))
367 (or uniquify-separator "\\")))
368 ((eq uniquify-buffer-name-style 'forward)
369 (mapconcat 'identity (nconc extra-string (list base))
370 "/"))
371 ((eq uniquify-buffer-name-style 'post-forward)
372 (concat base (or uniquify-separator "|")
373 (mapconcat 'identity extra-string "/")))
374 ((eq uniquify-buffer-name-style 'post-forward-angle-brackets)
375 (concat base "<" (mapconcat 'identity extra-string "/")
376 ">"))
377 (t (error "Bad value for uniquify-buffer-name-style: %s"
378 uniquify-buffer-name-style)))))
381 ;; Deal with conflicting-sublist, all of whose elements have identical
382 ;; "base" components.
383 (defun uniquify-rationalize-conflicting-sublist (conf-list old-name depth)
384 (when conf-list
385 (if (or (cdr conf-list)
386 ;; Check that the proposed name doesn't conflict with some
387 ;; existing buffer.
388 (let ((buf (get-buffer old-name)))
389 (and buf (not (eq buf (uniquify-item-buffer (car conf-list)))))))
390 (when uniquify-possibly-resolvable
391 (setq uniquify-possibly-resolvable nil
392 depth (1+ depth))
393 (dolist (item conf-list)
394 (setf (uniquify-item-proposed item)
395 (uniquify-get-proposed-name
396 (uniquify-item-base item)
397 (uniquify-item-dirname item)
398 depth)))
399 (uniquify-rationalize-a-list conf-list depth))
400 (unless (string= old-name "")
401 (uniquify-rename-buffer (car conf-list) old-name)))))
404 (defun uniquify-rename-buffer (item newname)
405 (let ((buffer (uniquify-item-buffer item)))
406 (unless (equal newname (buffer-name buffer))
407 (with-current-buffer buffer
408 (let ((uniquify-buffer-name-style nil)) ;Avoid hooks on rename-buffer.
409 ;; Pass the `unique' arg, so the advice doesn't mark it as unmanaged.
410 (rename-buffer newname t))))))
412 ;;; Hooks from the rest of Emacs
414 ;; The logical place to put all this code is in generate-new-buffer-name.
415 ;; It's written in C, so we would add a generate-new-buffer-name-function
416 ;; which, if non-nil, would be called instead of the C. One problem with
417 ;; that is that generate-new-buffer-name takes a potential buffer name as
418 ;; its argument -- not other information, such as what file the buffer will
419 ;; visit.
421 ;; The below solution works because generate-new-buffer-name is called
422 ;; only by rename-buffer (which, as of 19.29, is never called from C) and
423 ;; generate-new-buffer, which is called only by Lisp functions
424 ;; create-file-buffer and rename-uniquely. Rename-uniquely generally
425 ;; isn't used for buffers visiting files, so it's sufficient to hook
426 ;; rename-buffer and create-file-buffer. (Setting find-file-hook isn't
427 ;; sufficient.)
429 (defadvice rename-buffer (after rename-buffer-uniquify activate)
430 "Uniquify buffer names with parts of directory name."
431 (uniquify-maybe-rerationalize-w/o-cb)
432 (if (null (ad-get-arg 1)) ; no UNIQUE argument.
433 ;; Mark this buffer so it won't be renamed by uniquify.
434 (setq uniquify-managed nil)
435 (when uniquify-buffer-name-style
436 ;; Rerationalize w.r.t the new name.
437 (uniquify-rationalize-file-buffer-names
438 (ad-get-arg 0)
439 (uniquify-buffer-file-name (current-buffer))
440 (current-buffer))
441 (setq ad-return-value (buffer-name (current-buffer))))))
443 (defadvice create-file-buffer (after create-file-buffer-uniquify activate)
444 "Uniquify buffer names with parts of directory name."
445 (if uniquify-buffer-name-style
446 (let ((filename (expand-file-name (directory-file-name (ad-get-arg 0)))))
447 (uniquify-rationalize-file-buffer-names
448 (file-name-nondirectory filename)
449 (file-name-directory filename) ad-return-value))))
451 ;; Buffer deletion
452 ;; Rerationalize after a buffer is killed, to reduce coinciding buffer names.
453 ;; This mechanism uses `kill-buffer-hook', which runs *before* deletion.
454 ;; That means that the kill-buffer-hook function cannot just delete the
455 ;; buffer -- it has to set something to do the rationalization *later*.
456 ;; It actually puts another function on `post-command-hook'. This other
457 ;; function runs the rationalization and then removes itself from the hook.
458 ;; Is there a better way to accomplish this?
459 ;; (This ought to set some global variables so the work is done only for
460 ;; buffers with names similar to the deleted buffer. -MDE)
462 (defun uniquify-maybe-rerationalize-w/o-cb ()
463 "Re-rationalize buffer names, ignoring current buffer.
464 For use on `kill-buffer-hook'."
465 (if (and (cdr uniquify-managed)
466 uniquify-buffer-name-style
467 uniquify-after-kill-buffer-p)
468 (uniquify-rerationalize-w/o-cb uniquify-managed)))
470 ;; Ideally we'd like to add it buffer-locally, but that doesn't work
471 ;; because kill-buffer-hook is not permanent-local :-(
472 (add-hook 'kill-buffer-hook 'uniquify-maybe-rerationalize-w/o-cb)
474 (provide 'uniquify)
476 ;; arch-tag: e763faa3-56c9-4903-8eb8-26e1c45a0065
477 ;;; uniquify.el ends here