]> code.delx.au - gnu-emacs/blob - lisp/uniquify.el
Use uniquify-file-name-nondirectory throughout; documentation tweaks.
[gnu-emacs] / lisp / uniquify.el
1 ;;; uniquify.el --- unique buffer names dependent on file name
2
3 ;; Copyright (c) 1989, 1995, 1996, 1997 Free Software Foundation, Inc.
4
5 ;; Author: Dick King <king@reasoning.com>
6 ;; Maintainer: Michael Ernst <mernst@alum.mit.edu>
7 ;; Created: 15 May 86
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25
26 ;;; Commentary:
27
28 ;; Emacs's standard method for making buffer names unique adds <2>, <3>,
29 ;; etc. to the end of (all but one of) the buffers. This file replaces
30 ;; that behavior, for buffers visiting files and dired buffers, with a
31 ;; uniquification that adds parts of the file name until the buffer names
32 ;; are unique. For instance, buffers visiting /u/mernst/tmp/Makefile and
33 ;; /usr/projects/zaphod/Makefile would be named Makefile|tmp and
34 ;; Makefile|zaphod, respectively (instead of Makefile and Makefile<2>).
35 ;; Other buffer name styles are also available.
36
37 ;; To use this file, do (require 'uniquify)
38 ;; and set uniquify-buffer-name-style to one of its non-nil alternative values.
39
40 ;; For other options, see "User-visible variables", below.
41
42 ;; A version of uniquify.el that works under Emacs 18, Emacs 19, XEmacs,
43 ;; and InfoDock is available from the maintainer.
44
45 ;; Doesn't work under NT when backslash is used as a path separator (forward
46 ;; slash path separator works fine). To fix, check system-type against
47 ;; 'windows-nt, write a routine that breaks paths down into components.
48 ;; (Surprisingly, there isn't one built in.)
49
50 ;;; Change Log:
51
52 ;; Originally by Dick King <king@reasoning.com> 15 May 86
53 ;; Converted for Emacs 18 by Stephen Gildea <gildea@lcs.mit.edu>
54 ;; Make uniquify-min-dir-content 0 truly non-invasive. gildea 23 May 89
55 ;; Some cleanup. uniquify-min-dir-content default 0. gildea 01 Jun 89
56 ;; Don't rename to "". Michael Ernst <mernst@theory.lcs.mit.edu> 15 Jun 94
57 ;; Add kill-buffer-hook. Kenneth Manheimer <ken.manheimer@nist.gov> 09 May 95
58 ;; Add advice for rename-buffer and create-file-buffer, handle dired buffers,
59 ;; kill-buffer-rationalize-buffer-names-p, documentation. mernst 24 May 95
60 ;; Remove free variables, fix typos. mernst 5 Jun 95
61 ;; Efficiently support Emacs 19.27 & earlier. ken.manheimer, mernst 10 Jun 95
62 ;; Rename user options to "uniquify-...", add uniquify-reverse-dir-content-p,
63 ;; add uniquify-ask-about-buffer-names-p. king, mernst 13 Jun 95
64 ;; Prefix functions by "uniquify-..."; rename mnemonic-buffer-names to
65 ;; uniquify-buffer-name-style; add 'forward and 'post-forward-angle-brackets
66 ;; styles; remove uniquify-reverse-dir-content-p; add
67 ;; uniquify-trailing-separator-p. mernst 4 Aug 95
68 ;; Don't call expand-file-name on nil. mernst 7 Jan 96
69 ;; Check whether list-buffers-directory is bound. mernst 11 Oct 96
70 ;; Ignore non-file non-dired buffers. Colin Rafferty <craffert@ml.com> 3 Mar 97
71 ;; Use last component, not "", for file name of directories. mernst 27 Jun 97
72 ;; Use directory-file-name; code cleanup. mernst 6 Sep 97
73
74 ;; Valuable feedback was provided by
75 ;; Paul Smith <psmith@baynetworks.com>,
76 ;; Alastair Burt <burt@dfki.uni-kl.de>,
77 ;; Bob Weiner <weiner@footloose.sps.mot.com>,
78 ;; Albert L. Ting <alt@vlibs.com>,
79 ;; gyro@reasoning.com,
80 ;; Bryan O'Sullivan <bos@eng.sun.com>.
81
82
83 ;;; Code:
84
85 (provide 'uniquify)
86
87 ;;; User-visible variables
88
89 (defgroup uniquify nil
90 "Unique buffer names dependent on file name"
91 :group 'applications)
92
93
94 (defcustom uniquify-buffer-name-style nil
95 "*If non-nil, buffer names are uniquified with parts of directory name.
96 The value determines the buffer name style and is one of `forward',
97 `reverse', `post-forward' (the default), or `post-forward-angle-brackets'.
98 For example, files `/foo/bar/mumble/name' and `/baz/quux/mumble/name'
99 would have the following buffer names in the various styles:
100 forward bar/mumble/name quux/mumble/name
101 reverse name\\mumble\\bar name\\mumble\\quux
102 post-forward name|bar/mumble name|quux/mumble
103 post-forward-angle-brackets name<bar/mumble> name<quux/mumble>
104 nil name name<2>"
105 :type '(radio (const forward)
106 (const reverse)
107 (const post-forward)
108 (const post-forward-angle-brackets)
109 (const :tag "standard Emacs behavior (nil)" nil))
110 :group 'uniquify)
111
112 (defcustom uniquify-after-kill-buffer-p nil
113 "*If non-nil, rerationalize buffer names after a buffer has been killed.
114 This can be dangerous if Emacs Lisp code is keeping track of buffers by their
115 names (rather than keeping pointers to the buffers themselves)."
116 :type 'boolean
117 :group 'uniquify)
118
119 (defcustom uniquify-ask-about-buffer-names-p nil
120 "*If non-nil, permit user to choose names for buffers with same base file.
121 If the user chooses to name a buffer, uniquification is preempted and no
122 other buffer names are changed."
123 :type 'boolean
124 :group 'uniquify)
125
126 (defcustom uniquify-min-dir-content 0
127 "*Minimum number of directory name components included in buffer name."
128 :type 'integer
129 :group 'uniquify)
130
131 (defcustom uniquify-separator nil
132 "*String separator for buffer name components.
133 When `uniquify-buffer-name-style' is `post-forward', separates
134 base file name from directory part in buffer names (default \"|\").
135 When `uniquify-buffer-name-style' is `reverse', separates all
136 file name components (default \"\\\")."
137 :type '(choice (const nil) string)
138 :group 'uniquify)
139
140 (defcustom uniquify-trailing-separator-p nil
141 "*If non-nil, add a file name separator to dired buffer names.
142 If `uniquify-buffer-name-style' is `forward', add the separator at the end;
143 if it is `reverse', add the separator at the beginning; otherwise, this
144 variable is ignored."
145 :type 'boolean
146 :group 'uniquify)
147
148
149 ;;; Utilities
150
151 (defmacro uniquify-push (item list)
152 (` (setq (, list) (cons (, item) (, list)))))
153
154 ;; For directories, return the last component, not the empty string.
155 (defun uniquify-file-name-nondirectory (file-name)
156 (file-name-nondirectory (directory-file-name file-name)))
157
158 ;; uniquify-fix-list data structure
159 (defmacro uniquify-fix-item-base (a)
160 (` (car (, a))))
161 (defmacro uniquify-fix-item-filename (a)
162 (` (car (cdr (, a)))))
163 (defmacro uniquify-fix-item-buffer (a)
164 (` (car (cdr (cdr (, a))))))
165 ;; Not a macro: passed to mapcar.
166 (defun uniquify-fix-item-unrationalized-buffer (item)
167 (or (car (cdr (cdr (cdr item)))) nil)) ;maybe better in the future
168
169 (defun uniquify-fix-item-filename-lessp (fixlist1 fixlist2)
170 (uniquify-filename-lessp (uniquify-fix-item-filename fixlist1)
171 (uniquify-fix-item-filename fixlist2)))
172
173 ;; Internal variables used free
174 (defvar uniquify-non-file-buffer-names nil)
175 (defvar uniquify-possibly-resolvable nil)
176
177 ;;; Main entry point.
178
179 (defun uniquify-rationalize-file-buffer-names (&optional newbuffile newbuf)
180 "Makes file buffer names unique by adding segments from file name.
181 If `uniquify-min-dir-content' > 0, always pulls that many
182 file name elements. Arguments cause only a subset of buffers to be renamed."
183 (interactive)
184 (let (fix-list
185 uniquify-non-file-buffer-names)
186 (let ((buffers (buffer-list)))
187 (while buffers
188 (let* ((buffer (car buffers))
189 (bfn (if (eq buffer newbuf)
190 (and newbuffile
191 (expand-file-name
192 (if (file-directory-p newbuffile)
193 (directory-file-name newbuffile)
194 newbuffile)))
195 (uniquify-buffer-file-name buffer)))
196 (rawname (and bfn (uniquify-file-name-nondirectory bfn)))
197 (deserving (and rawname
198 (or (not newbuffile)
199 (equal rawname
200 (uniquify-file-name-nondirectory newbuffile))))))
201 (if deserving
202 (uniquify-push (list rawname bfn buffer nil) fix-list)
203 (uniquify-push (list (buffer-name buffer))
204 uniquify-non-file-buffer-names)))
205 (setq buffers (cdr buffers))))
206 ;; selects buffers whose names may need changing, and others that
207 ;; may conflict.
208 (setq fix-list
209 (sort fix-list 'uniquify-fix-item-filename-lessp))
210 ;; bringing conflicting names together
211 (uniquify-rationalize-a-list fix-list uniquify-min-dir-content)
212 (mapcar 'uniquify-fix-item-unrationalized-buffer fix-list)))
213
214 ;; uniquify's version of buffer-file-name; result never contains trailing slash
215 (defun uniquify-buffer-file-name (buffer)
216 "Return name of file BUFFER is visiting, or nil if none.
217 Works on dired buffers and ordinary file-visiting buffers, but no others."
218 (or (buffer-file-name buffer)
219 (and (featurep 'dired)
220 (save-excursion
221 (set-buffer buffer)
222 (and
223 (eq major-mode 'dired-mode) ; do nothing if not a dired buffer
224 (if (boundp 'list-buffers-directory) ; XEmacs mightn't define this
225 (and list-buffers-directory
226 (directory-file-name list-buffers-directory))
227 ;; don't use default-directory if dired-directory is nil
228 (and dired-directory
229 (expand-file-name
230 (directory-file-name
231 (if (consp dired-directory)
232 (car dired-directory)
233 dired-directory))))))))))
234
235 ;; This examines the filename components in reverse order.
236 (defun uniquify-filename-lessp (s1 s2)
237 (let ((s1f (uniquify-file-name-nondirectory s1))
238 (s2f (uniquify-file-name-nondirectory s2)))
239 (and (not (equal s2f ""))
240 (or (string-lessp s1f s2f)
241 (and (equal s1f s2f)
242 (let ((s1d (file-name-directory s1))
243 (s2d (file-name-directory s2)))
244 (and (not (<= (length s2d) 1))
245 (or (<= (length s1d) 1)
246 (uniquify-filename-lessp
247 (substring s1d 0 -1)
248 (substring s2d 0 -1))))))))))
249
250 (defun uniquify-rationalize-a-list (fix-list depth)
251 (let (conflicting-sublist ; all elements have the same proposed name
252 (old-name "")
253 proposed-name uniquify-possibly-resolvable)
254 (while fix-list
255 (let ((item (car fix-list)))
256 (setq proposed-name (uniquify-get-proposed-name item depth))
257 (if (not (equal proposed-name old-name))
258 (progn
259 (uniquify-rationalize-conflicting-sublist
260 conflicting-sublist old-name depth)
261 (setq conflicting-sublist nil)))
262 (uniquify-push item conflicting-sublist)
263 (setq old-name proposed-name))
264 (setq fix-list (cdr fix-list)))
265 (uniquify-rationalize-conflicting-sublist
266 conflicting-sublist old-name depth)))
267
268 (defun uniquify-get-proposed-name (item depth)
269 (let (index
270 (extra-string "")
271 (n depth)
272 (base (uniquify-fix-item-base item))
273 (fn (uniquify-fix-item-filename item)))
274 (while (and (> n 0)
275 (setq index (string-match
276 (concat "\\(^\\|/[^/]*\\)/"
277 (regexp-quote extra-string)
278 (regexp-quote base)
279 "\\'")
280 fn)))
281 (setq extra-string (substring fn
282 (if (zerop index) 0 (1+ index))
283 ;; (- (length base)) fails for base = "".
284 ;; Equivalently, we could have used
285 ;; (apply 'substring ...
286 ;; (and (not (string= "" base))
287 ;; (list (- (length base)))))
288 (- (length fn) (length base)))
289 n (1- n)))
290 (if (zerop n) (setq uniquify-possibly-resolvable t))
291
292
293 ;; Distinguish directories by adding extra separator.
294 (if (and uniquify-trailing-separator-p
295 (file-directory-p fn)
296 (not (string-equal base "")))
297 (cond ((eq uniquify-buffer-name-style 'forward)
298 (setq base (concat base "/")))
299 ((eq uniquify-buffer-name-style 'reverse)
300 (setq base (concat (or uniquify-separator "\\") base)))))
301
302 ;; Trim trailing separator on directory part
303 (if (and (not (string-equal extra-string ""))
304 (or (eq uniquify-buffer-name-style 'post-forward)
305 (eq uniquify-buffer-name-style 'post-forward-angle-brackets)))
306 (setq extra-string (substring extra-string 0
307 (- (length extra-string) 1))))
308
309 (cond ((string-equal extra-string "")
310 base)
311 ((string-equal base "")
312 extra-string)
313 ((eq uniquify-buffer-name-style 'forward)
314 (concat extra-string base))
315 ((eq uniquify-buffer-name-style 'reverse)
316 (concat base (uniquify-reverse-components extra-string)))
317 ((eq uniquify-buffer-name-style 'post-forward)
318 (concat base (or uniquify-separator "|") extra-string))
319 ((eq uniquify-buffer-name-style 'post-forward-angle-brackets)
320 (concat base "<" extra-string ">"))
321 (t (error "Bad value for uniquify-buffer-name-style: %s"
322 uniquify-buffer-name-style)))))
323
324
325 ;; Deal with conflicting-sublist, all of whose elements have identical
326 ;; "base" components.
327 (defun uniquify-rationalize-conflicting-sublist (conflicting-sublist old-name depth)
328 (or (null conflicting-sublist)
329 (and (null (cdr conflicting-sublist))
330 (not (assoc old-name uniquify-non-file-buffer-names))
331 (or (and (not (string= old-name ""))
332 (uniquify-rename-buffer (car conflicting-sublist) old-name))
333 t))
334 (if uniquify-possibly-resolvable
335 (uniquify-rationalize-a-list conflicting-sublist (1+ depth)))))
336
337 (defun uniquify-rename-buffer (item newname)
338 (let ((buffer (uniquify-fix-item-buffer item)))
339 (if (not (equal newname (buffer-name buffer)))
340 (let ((unset (current-buffer))
341 ;; avoid hooks on rename-buffer
342 (uniquify-buffer-name-style nil))
343 (set-buffer buffer)
344 (rename-buffer newname)
345 (set-buffer unset))))
346 (rplaca (nthcdr 3 item) t))
347
348 (defun uniquify-reverse-components (instring)
349 (let ((sofar '())
350 (cursor 0)
351 (len (length instring))
352 (sep (or uniquify-separator "\\")))
353 (while (< cursor len)
354 (if (= (aref instring cursor) ?/)
355 (setq sofar (cons sep sofar)
356 cursor (1+ cursor))
357 (let ((first-slash (or (string-match "/" instring cursor) len)))
358 (setq sofar (cons (substring instring cursor first-slash) sofar)
359 cursor first-slash))))
360 (apply (function concat) sofar)))
361
362
363 ;;; Hooks from the rest of Emacs
364
365 ;; The logical place to put all this code is in generate-new-buffer-name.
366 ;; It's written in C, so we would add a generate-new-buffer-name-function
367 ;; which, if non-nil, would be called instead of the C. One problem with
368 ;; that is that generate-new-buffer-name takes a potential buffer name as
369 ;; its argument -- not other information, such as what file the buffer will
370 ;; visit.
371
372 ;; The below solution works because generate-new-buffer-name is called
373 ;; only by rename-buffer (which, as of 19.29, is never called from C) and
374 ;; generate-new-buffer, which is called only by Lisp functions
375 ;; create-file-buffer and rename-uniquely. Rename-uniquely generally
376 ;; isn't used for buffers visiting files, so it's sufficient to hook
377 ;; rename-buffer and create-file-buffer. (Setting find-file-hooks isn't
378 ;; sufficient.)
379
380 (defadvice rename-buffer (after rename-buffer-uniquify activate)
381 "Uniquify buffer names with parts of directory name."
382 (if (and uniquify-buffer-name-style
383 ;; UNIQUE argument
384 (ad-get-arg 1))
385 (progn
386 (if uniquify-after-kill-buffer-p
387 ;; call with no argument; rationalize vs. old name as well as new
388 (uniquify-rationalize-file-buffer-names)
389 ;; call with argument: rationalize vs. new name only
390 (uniquify-rationalize-file-buffer-names
391 (uniquify-buffer-file-name (current-buffer)) (current-buffer)))
392 (setq ad-return-value (buffer-name (current-buffer))))))
393
394 (defadvice create-file-buffer (after create-file-buffer-uniquify activate)
395 "Uniquify buffer names with parts of directory name."
396 (if uniquify-buffer-name-style
397 (uniquify-rationalize-file-buffer-names (ad-get-arg 0) ad-return-value)))
398
399 ;; Buffer deletion
400 ;; Rerationalize after a buffer is killed, to reduce coinciding buffer names.
401 ;; This mechanism uses `kill-buffer-hook', which runs *before* deletion.
402 ;; That means that the kill-buffer-hook function cannot just delete the
403 ;; buffer -- it has to set something to do the rationalization *later*.
404 ;; It actually puts another function on `post-command-hook'. This other
405 ;; function runs the rationalization and then removes itself from the hook.
406 ;; Is there a better way to accomplish this?
407 ;; (This ought to set some global variables so the work is done only for
408 ;; buffers with names similar to the deleted buffer. -MDE)
409
410 (defun delay-uniquify-rationalize-file-buffer-names ()
411 "Add `delayed-uniquify-rationalize-file-buffer-names' to `post-command-hook'.
412 For use on, eg, `kill-buffer-hook', to rationalize *after* buffer deletion."
413 (if (and uniquify-buffer-name-style
414 uniquify-after-kill-buffer-p)
415 (add-hook 'post-command-hook
416 'delayed-uniquify-rationalize-file-buffer-names)))
417
418 (defun delayed-uniquify-rationalize-file-buffer-names ()
419 "Rerationalize buffer names and remove self from `post-command-hook'.
420 See also `delay-rationalize-file-buffer-names' for hook setter."
421 (uniquify-rationalize-file-buffer-names)
422 (remove-hook 'post-command-hook
423 'delayed-uniquify-rationalize-file-buffer-names))
424
425 (add-hook 'kill-buffer-hook 'delay-uniquify-rationalize-file-buffer-names)
426
427 ;;; uniquify.el ends here