Mercurial > hg > xemacs-beta

comparison lisp/utils/uniquify.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents ec9a17fef872
children 360340f9fd5f
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; uniquify.el --- unique buffer names dependent on file name 1 ;;; uniquify.el --- unique buffer names dependent on file name
2 2
3 ;; Copyright (c) 1989, 1995, 1996, 1997 Free Software Foundation, Inc. 3 ;; Copyright (c) 1989, 1995 Free Software Foundation, Inc.
4 4
5 ;; Author: Dick King <king@reasoning.com> 5 ;; Author: Dick King <king@reasoning.com>
6 ;; Maintainer: Michael Ernst <mernst@theory.lcs.mit.edu> 6 ;; Maintainer: Michael Ernst <mernst@theory.lcs.mit.edu>
7 ;; Created: 15 May 86 7 ;; Created: 15 May 86
8 ;; Time-stamp: <97/03/03 17:16:23 mernst>
9 8
10 ;; This file is part of GNU Emacs. 9 ;; This file is part of GNU Emacs.
11 10
12 ;; GNU Emacs is free software; you can redistribute it and/or modify 11 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by 12 ;; it under the terms of the GNU General Public License as published by
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details. 19 ;; GNU General Public License for more details.
21 20
22 ;; You should have received a copy of the GNU General Public License 21 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to 22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25 25
26 ;;; Commentary: 26 ;;; Commentary:
27 27
28 ;; Emacs's standard method for making buffer names unique adds <2>, <3>, 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 29 ;; etc. to the end of (all but one of) the buffers. This file replaces
32 ;; are unique. For instance, buffers visiting /u/mernst/tmp/Makefile and 32 ;; are unique. For instance, buffers visiting /u/mernst/tmp/Makefile and
33 ;; /usr/projects/zaphod/Makefile would be named Makefile|tmp and 33 ;; /usr/projects/zaphod/Makefile would be named Makefile|tmp and
34 ;; Makefile|zaphod, respectively (instead of Makefile and Makefile<2>). 34 ;; Makefile|zaphod, respectively (instead of Makefile and Makefile<2>).
35 ;; Other buffer name styles are also available. 35 ;; Other buffer name styles are also available.
36 36
37 ;; To use this file, just load it; or add (require 'uniquify) to your .emacs. 37 ;; To use this file, just load it.
38 ;; To disable it after loading, set variable uniquify-buffer-name-style to nil. 38 ;; To disable it after loading, set variable uniquify-buffer-name-style to nil.
39 ;; For other options, see "User-visible variables", below. 39 ;; For other options, see "User-visible variables", below.
40 40
41 ;; uniquify.el works under Emacs 18, Emacs 19, XEmacs, and InfoDock. 41 ;; A version of uniquify.el that works under Emacs 18, Emacs 19, XEmacs,
42 42 ;; and InfoDock is available from the maintainer.
43 ;; Doesn't correctly handle buffer names created by M-x write-file in Emacs 18.
44 ;; Doesn't work under NT when backslash is used as a path separator (forward
45 ;; slash path separator works fine). To fix, check system-type against
46 ;; 'windows-nt, write a routine that breaks paths down into components.
47 ;; (Surprisingly, there isn't one built in.)
48 43
49 ;;; Change Log: 44 ;;; Change Log:
50 45
51 ;; Originally by Dick King <king@reasoning.com> 15 May 86 46 ;; Originally by Dick King <king@reasoning.com> 15 May 86
52 ;; Converted for Emacs 18 by Stephen Gildea <gildea@lcs.mit.edu> 47 ;; Converted for Emacs 18 by Stephen Gildea <gildea@lcs.mit.edu>
62 ;; add uniquify-ask-about-buffer-names-p. king, mernst 13 Jun 95 57 ;; add uniquify-ask-about-buffer-names-p. king, mernst 13 Jun 95
63 ;; Prefix functions by "uniquify-..."; rename mnemonic-buffer-names to 58 ;; Prefix functions by "uniquify-..."; rename mnemonic-buffer-names to
64 ;; uniquify-buffer-name-style; add 'forward and 'post-forward-angle-brackets 59 ;; uniquify-buffer-name-style; add 'forward and 'post-forward-angle-brackets
65 ;; styles; remove uniquify-reverse-dir-content-p; add 60 ;; styles; remove uniquify-reverse-dir-content-p; add
66 ;; uniquify-trailing-separator-p. mernst 4 Aug 95 61 ;; uniquify-trailing-separator-p. mernst 4 Aug 95
67 ;; Don't call expand-file-name on nil. mernst 7 Jan 96
68 ;; Check whether list-buffers-directory is bound. mernst 11 Oct 96
69 ;; Ignore non-file non-dired buffers. Colin Rafferty <craffert@ml.com> 3 Mar 97
70 62
71 ;; Valuable feedback was provided by 63 ;; Valuable feedback was provided by
72 ;; Paul Smith <psmith@baynetworks.com>, 64 ;; Paul Smith <psmith@baynetworks.com>,
73 ;; Alastair Burt <burt@dfki.uni-kl.de>, 65 ;; Alastair Burt <burt@dfki.uni-kl.de>,
74 ;; Bob Weiner <weiner@footloose.sps.mot.com>, 66 ;; Bob Weiner <weiner@footloose.sps.mot.com>,
75 ;; Albert L. Ting <alt@vlibs.com>, 67 ;; Albert L. Ting <alt@vlibs.com>,
76 ;; gyro@reasoning.com, 68 ;; gyro@reasoning.com.
77 ;; Bryan O'Sullivan <bos@eng.sun.com>.
78 69
79 70
80 ;;; Code: 71 ;;; Code:
81 72
82 (provide 'uniquify) 73 (provide 'uniquify)
155 (depth uniquify-min-dir-content)) 146 (depth uniquify-min-dir-content))
156 (let ((buffers (buffer-list))) 147 (let ((buffers (buffer-list)))
157 (while buffers 148 (while buffers
158 (let* ((buffer (car buffers)) 149 (let* ((buffer (car buffers))
159 (bfn (if (eq buffer newbuf) 150 (bfn (if (eq buffer newbuf)
160 (and newbuffile 151 (and newbuffile
161 (expand-file-name newbuffile)) 152 (expand-file-name newbuffile))
162 (uniquify-buffer-file-name buffer))) 153 (uniquify-buffer-file-name buffer)))
163 (rawname (and bfn (file-name-nondirectory bfn))) 154 (rawname (and bfn (file-name-nondirectory bfn)))
164 (deserving (and rawname 155 (deserving (and rawname
165 (or (not newbuffile) 156 (or (not newbuffile)
166 (equal rawname 157 (equal rawname
179 (mapcar 'uniquify-unrationalized-buffer fix-list))) 170 (mapcar 'uniquify-unrationalized-buffer fix-list)))
180 171
181 ;; uniquify's version of buffer-file-name 172 ;; uniquify's version of buffer-file-name
182 (defun uniquify-buffer-file-name (buffer) 173 (defun uniquify-buffer-file-name (buffer)
183 "Return name of file BUFFER is visiting, or nil if none. 174 "Return name of file BUFFER is visiting, or nil if none.
184 Works on dired buffers as well as ordinary file-visiting buffers, 175 Works on dired buffers as well as ordinary file-visiting buffers."
185 but no others."
186 (or (buffer-file-name buffer) 176 (or (buffer-file-name buffer)
187 (and (featurep 'dired) 177 (save-excursion
188 (save-excursion 178 (set-buffer buffer)
189 (set-buffer buffer) 179 list-buffers-directory)))
190 (and
191 (eq major-mode 'dired-mode) ; do nothing if not a dired buffer
192 (if (boundp 'list-buffers-directory) ; XEmacs mightn't define this
193 list-buffers-directory
194 ;; don't use default-directory if dired-directory is nil
195 (and dired-directory
196 (expand-file-name
197 (directory-file-name
198 (if (consp dired-directory)
199 (car dired-directory)
200 dired-directory))))))))))
201 180
202 (defun uniquify-fix-list-filename-lessp (fixlist1 fixlist2) 181 (defun uniquify-fix-list-filename-lessp (fixlist1 fixlist2)
203 (uniquify-filename-lessp 182 (uniquify-filename-lessp
204 (uniquify-fix-list-filename fixlist1) (uniquify-fix-list-filename fixlist2))) 183 (uniquify-fix-list-filename fixlist1) (uniquify-fix-list-filename fixlist2)))
205 184
335 (apply (function concat) sofar))) 314 (apply (function concat) sofar)))
336 315
337 316
338 ;;; Hooks from the rest of Emacs 317 ;;; Hooks from the rest of Emacs
339 318
340 (cond 319 ;; Emacs 19 (Emacs or XEmacs)
341 ((string-match "^19" emacs-version) 320
342 ;; Emacs 19 (Emacs or XEmacs) 321 ;; The logical place to put all this code is in generate-new-buffer-name.
343 322 ;; It's written in C, so we would add a generate-new-buffer-name-function
344 ;; The logical place to put all this code is in generate-new-buffer-name. 323 ;; which, if non-nil, would be called instead of the C. One problem with
345 ;; It's written in C, so we would add a generate-new-buffer-name-function 324 ;; that is that generate-new-buffer-name takes a potential buffer name as
346 ;; which, if non-nil, would be called instead of the C. One problem with 325 ;; its argument -- not other information, such as what file the buffer will
347 ;; that is that generate-new-buffer-name takes a potential buffer name as 326 ;; visit.
348 ;; its argument -- not other information, such as what file the buffer will 327
349 ;; visit. 328 ;; The below solution works because generate-new-buffer-name is called
350 329 ;; only by rename-buffer (which, as of 19.29, is never called from C) and
351 ;; The below solution works because generate-new-buffer-name is called 330 ;; generate-new-buffer, which is called only by Lisp functions
352 ;; only by rename-buffer (which, as of 19.29, is never called from C) and 331 ;; create-file-buffer and rename-uniquely. Rename-uniquely generally
353 ;; generate-new-buffer, which is called only by Lisp functions 332 ;; isn't used for buffers visiting files, so it's sufficient to hook
354 ;; create-file-buffer and rename-uniquely. Rename-uniquely generally 333 ;; rename-buffer and create-file-buffer. (Setting find-file-hooks isn't
355 ;; isn't used for buffers visiting files, so it's sufficient to hook 334 ;; sufficient.)
356 ;; rename-buffer and create-file-buffer. (Setting find-file-hooks isn't 335
357 ;; sufficient.) 336 (defadvice rename-buffer (after rename-buffer-uniquify activate)
358 337 "Uniquify buffer names with parts of directory name."
359 (defadvice rename-buffer (after rename-buffer-uniquify activate) 338 (if (and uniquify-buffer-name-style
360 "Uniquify buffer names with parts of directory name." 339 ;; UNIQUE argument
361 (if (and uniquify-buffer-name-style 340 (ad-get-arg 1))
362 ;; UNIQUE argument 341 (progn
363 (ad-get-arg 1)) 342 (if uniquify-after-kill-buffer-p
364 (progn 343 ;; call with no argument; rationalize vs. old name as well as new
365 (if uniquify-after-kill-buffer-p 344 (uniquify-rationalize-file-buffer-names)
366 ;; call with no argument; rationalize vs. old name as well as new 345 ;; call with argument: rationalize vs. new name only
367 (uniquify-rationalize-file-buffer-names) 346 (uniquify-rationalize-file-buffer-names
368 ;; call with argument: rationalize vs. new name only 347 (uniquify-buffer-file-name (current-buffer)) (current-buffer)))
369 (uniquify-rationalize-file-buffer-names 348 (setq ad-return-value (buffer-name (current-buffer))))))
370 (uniquify-buffer-file-name (current-buffer)) (current-buffer))) 349
371 (setq ad-return-value (buffer-name (current-buffer)))))) 350 (defadvice create-file-buffer (after create-file-buffer-uniquify activate)
372 351 "Uniquify buffer names with parts of directory name."
373 (defadvice create-file-buffer (after create-file-buffer-uniquify activate) 352 (if uniquify-buffer-name-style
374 "Uniquify buffer names with parts of directory name." 353 (uniquify-rationalize-file-buffer-names (ad-get-arg 0) ad-return-value)))
375 (if uniquify-buffer-name-style 354
376 (uniquify-rationalize-file-buffer-names (ad-get-arg 0) ad-return-value))) 355 ;; Buffer deletion
377 356 ;; Rerationalize after a buffer is killed, to reduce coinciding buffer names.
378 ;; Buffer deletion 357 ;; This mechanism uses `kill-buffer-hook', which runs *before* deletion.
379 ;; Rerationalize after a buffer is killed, to reduce coinciding buffer names. 358 ;; That means that the kill-buffer-hook function cannot just delete the
380 ;; This mechanism uses `kill-buffer-hook', which runs *before* deletion. 359 ;; buffer -- it has to set something to do the rationalization *later*.
381 ;; That means that the kill-buffer-hook function cannot just delete the 360 ;; It actually puts another function on `post-command-hook'. This other
382 ;; buffer -- it has to set something to do the rationalization *later*. 361 ;; function runs the rationalization and then removes itself from the hook.
383 ;; It actually puts another function on `post-command-hook'. This other 362 ;; Is there a better way to accomplish this?
384 ;; function runs the rationalization and then removes itself from the hook. 363 ;; (This ought to set some global variables so the work is done only for
385 ;; Is there a better way to accomplish this? 364 ;; buffers with names similar to the deleted buffer. -MDE)
386 ;; (This ought to set some global variables so the work is done only for 365
387 ;; buffers with names similar to the deleted buffer. -MDE) 366 (defun delay-uniquify-rationalize-file-buffer-names ()
388 367 "Add `delayed-uniquify-rationalize-file-buffer-names' to `post-command-hook'.
389 (cond
390 ((or (not (string-lessp emacs-version "19.28"))
391 (and (string-match "XEmacs" emacs-version)
392 (not (string-lessp emacs-version "19.12"))))
393 ;; Emacs 19.28 or later, or XEmacs (19.12 or later; is that necessary?)
394 (defun delay-uniquify-rationalize-file-buffer-names ()
395 "Add `delayed-uniquify-rationalize-file-buffer-names' to `post-command-hook'.
396 For use on, eg, `kill-buffer-hook', to rationalize *after* buffer deletion." 368 For use on, eg, `kill-buffer-hook', to rationalize *after* buffer deletion."
397 (if (and uniquify-buffer-name-style 369 (if (and uniquify-buffer-name-style
398 uniquify-after-kill-buffer-p) 370 uniquify-after-kill-buffer-p)
399 (add-hook 'post-command-hook 371 (add-hook 'post-command-hook
400 'delayed-uniquify-rationalize-file-buffer-names))) 372 'delayed-uniquify-rationalize-file-buffer-names)))
401 (defun delayed-uniquify-rationalize-file-buffer-names () 373
402 "Rerationalize buffer names and remove self from `post-command-hook'. 374 (defun delayed-uniquify-rationalize-file-buffer-names ()
375 "Rerationalize buffer names and remove self from `post-command-hook'.
403 See also `delay-rationalize-file-buffer-names' for hook setter." 376 See also `delay-rationalize-file-buffer-names' for hook setter."
404 (uniquify-rationalize-file-buffer-names) 377 (uniquify-rationalize-file-buffer-names)
405 (remove-hook 'post-command-hook 378 (remove-hook 'post-command-hook
406 'delayed-uniquify-rationalize-file-buffer-names)) 379 'delayed-uniquify-rationalize-file-buffer-names))
407 380
408 (add-hook 'kill-buffer-hook 'delay-uniquify-rationalize-file-buffer-names)) 381 (add-hook 'kill-buffer-hook 'delay-uniquify-rationalize-file-buffer-names)
409 (t
410 ;; GNU Emacs 19.01 through 19.27
411 ;; Before version 19.28, {pre,post}-command-hook was unable to set itself.
412
413 (defvar uniquify-post-command-p nil
414 "Set to trigger re-rationalization of buffer names by function on
415 `post-command-hook'. Used by kill-buffer-rationalization mechanism.")
416
417 (defun uniquify-post-command-rerationalization ()
418 "Set variable so buffer names may be rationalized by `post-command-hook'.
419
420 See variables `uniquify-post-command-p', `uniquify-buffer-name-style', and
421 `uniquify-after-kill-buffer-p'."
422 (if (and uniquify-buffer-name-style
423 uniquify-after-kill-buffer-p)
424 (setq uniquify-post-command-p
425 ;; Set the buffer name, so, once the delimiter character
426 ;; is parameterized, we could selectively rationalize just
427 ;; related buffer names.
428 (cons (buffer-name) uniquify-post-command-p))))
429 (defun uniquify-rationalize-after-buffer-kill ()
430 "Via `post-command-hook', rerationalize buffer names after kill-buffer.
431
432 Checks `uniquify-post-command-p', which should be set by
433 `uniquify-post-command-rerationalization' function on `kill-buffer-hook'."
434 (if uniquify-post-command-p
435 (progn (if (and uniquify-buffer-name-style
436 uniquify-after-kill-buffer-p)
437 (uniquify-rationalize-file-buffer-names))
438 (setq uniquify-post-command-p nil))))
439
440 (add-hook 'kill-buffer-hook 'uniquify-post-command-rerationalization)
441 (add-hook 'post-command-hook 'uniquify-rationalize-after-buffer-kill))
442 ))
443 (t
444 ;; Emacs 18: redefine create-file-buffer and dired-find-buffer.
445
446 ;; Since advice.el can run in Emacs 18 as well as Emacs 19, we could use
447 ;; advice here, too, if it is available; but it's not worth it, since
448 ;; Emacs 18 is obsolescent anyway.
449
450 (defun create-file-buffer (filename) ;from files.el
451 "Create a suitably named buffer for visiting FILENAME, and return it."
452 (let ((base (file-name-nondirectory filename)))
453 (if (string= base "")
454 (setq base filename))
455 (if (and (get-buffer base)
456 uniquify-ask-about-buffer-names-p)
457 (get-buffer-create
458 (let ((tem (read-string (format
459 "Buffer name \"%s\" is in use; type a new name, or Return to clobber: "
460 base))))
461 (if (equal tem "") base tem)))
462 (let ((buf (generate-new-buffer base)))
463 (if uniquify-buffer-name-style
464 (uniquify-rationalize-file-buffer-names filename buf))
465 buf))))
466
467 (defun dired-find-buffer (dirname) ;from dired.el
468 (let ((blist (buffer-list))
469 found)
470 (while blist
471 (save-excursion
472 (set-buffer (car blist))
473 (if (and (eq major-mode 'dired-mode)
474 (equal dired-directory dirname))
475 (setq found (car blist)
476 blist nil)
477 (setq blist (cdr blist)))))
478 (or found
479 (progn (if (string-match "/$" dirname)
480 (setq dirname (substring dirname 0 -1)))
481 (create-file-buffer (if uniquify-buffer-name-style
482 dirname
483 (file-name-nondirectory dirname)))))))))
484 382
485 ;;; uniquify.el ends here 383 ;;; uniquify.el ends here
384