code.delx.au - gnu-emacs/blob - lisp/uniquify.el

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