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 Free Software Foundation, Inc.
   4
   5 ;; Author: Dick King <king@reasoning.com>
   6 ;; Maintainer: FSF
   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 ;; Add uniquify-ignore-buffers-re.
  74 ;;  Andre Srinivasan <andre@visigenic.com> 9 Sep 97
  75 ;; Add uniquify-list-buffers-directory-modes
  76 ;;   Stefan Monnier <monnier@cs.yale.edu> 17 Nov 2000
  77 ;; Algorithm change reduced consing when using lots of buffers
  78 ;;   Francesco Potortì <pot@gnu.org> (ideas by rms and monnier) 2001-07-18
  79
  80 ;; Valuable feedback was provided by
  81 ;; Paul Smith <psmith@baynetworks.com>,
  82 ;; Alastair Burt <burt@dfki.uni-kl.de>,
  83 ;; Bob Weiner <weiner@footloose.sps.mot.com>,
  84 ;; Albert L. Ting <alt@vlibs.com>,
  85 ;; gyro@reasoning.com,
  86 ;; Bryan O'Sullivan <bos@eng.sun.com>.
  87
  88
  89 ;;; Code:
  90
  91 (provide 'uniquify)
  92 (eval-when-compile (require 'cl))
  93
  94 ;;; User-visible variables
  95
  96 (defgroup uniquify nil
  97   "Unique buffer names dependent on file name"
  98   :group 'applications)
  99
 100
 101 (defcustom uniquify-buffer-name-style nil
 102   "*If non-nil, buffer names are uniquified with parts of directory name.
 103 The value determines the buffer name style and is one of `forward',
 104 `reverse', `post-forward', or `post-forward-angle-brackets'.
 105 For example, files `/foo/bar/mumble/name' and `/baz/quux/mumble/name'
 106 would have the following buffer names in the various styles:
 107   forward        bar/mumble/name  quux/mumble/name
 108   reverse        name\\mumble\\bar  name\\mumble\\quux
 109   post-forward   name|bar/mumble  name|quux/mumble
 110   post-forward-angle-brackets   name<bar/mumble>  name<quux/mumble>
 111   nil            name  name<2>"
 112   :type '(radio (const forward)
 113                 (const reverse)
 114                 (const post-forward)
 115                 (const post-forward-angle-brackets)
 116                 (const :tag "standard Emacs behavior (nil)" nil))
 117   :require 'uniquify
 118   :group 'uniquify)
 119
 120 (defcustom uniquify-after-kill-buffer-p nil
 121   "*If non-nil, rerationalize buffer names after a buffer has been killed.
 122 This can be dangerous if Emacs Lisp code is keeping track of buffers by their
 123 names (rather than keeping pointers to the buffers themselves)."
 124   :type 'boolean
 125   :group 'uniquify)
 126
 127 (defcustom uniquify-ask-about-buffer-names-p nil
 128   "*If non-nil, permit user to choose names for buffers with same base file.
 129 If the user chooses to name a buffer, uniquification is preempted and no
 130 other buffer names are changed."
 131   :type 'boolean
 132   :group 'uniquify)
 133
 134 (defcustom uniquify-ignore-buffers-re nil
 135   "*Regular expression matching buffer names that should not be uniquified.
 136 For instance, set this to \"^draft-[0-9]+$\" to avoid having uniquify rename
 137 draft buffers even if `uniquify-after-kill-buffer-p' is non-nil and the
 138 visited file name isn't the same as that of the buffer."
 139   :type '(choice (const :tag "Uniquify all buffers" nil) regexp)
 140   :group 'uniquify)
 141
 142 (defcustom uniquify-min-dir-content 0
 143   "*Minimum number of directory name components included in buffer name."
 144   :type 'integer
 145   :group 'uniquify)
 146
 147 (defcustom uniquify-separator nil
 148   "*String separator for buffer name components.
 149 When `uniquify-buffer-name-style' is `post-forward', separates
 150 base file name from directory part in buffer names (default \"|\").
 151 When `uniquify-buffer-name-style' is `reverse', separates all
 152 file name components (default \"\\\")."
 153   :type '(choice (const nil) string)
 154   :group 'uniquify)
 155
 156 (defcustom uniquify-trailing-separator-p nil
 157   "*If non-nil, add a file name separator to dired buffer names.
 158 If `uniquify-buffer-name-style' is `forward', add the separator at the end;
 159 if it is `reverse', add the separator at the beginning; otherwise, this
 160 variable is ignored."
 161   :type 'boolean
 162   :group 'uniquify)
 163
 164 (defvar uniquify-list-buffers-directory-modes '(dired-mode cvs-mode)
 165   "List of modes for which uniquify should obey `list-buffers-directory'.
 166 That means that when `buffer-file-name' is set to nil, `list-buffers-directory'
 167 contains the name of the directory which the buffer is visiting.")
 168
 169 ;;; Utilities
 170
 171 ;; For directories, return the last component, not the empty string.
 172 (defun uniquify-file-name-nondirectory (file-name)
 173   (file-name-nondirectory (directory-file-name file-name)))
 174
 175 ;; uniquify-fix-list data structure
 176 (defalias 'uniquify-fix-item-base 'car)
 177 (defalias 'uniquify-fix-item-filename 'cadr)
 178 (defsubst uniquify-fix-item-buffer (x) (car (cdr (cdr x))))
 179 (defsubst uniquify-fix-item-proposed (x) (nth 3 x))
 180 (defsubst uniquify-set-proposed (x p) (setcar (nthcdr 3 x) p))
 181
 182 ;; Internal variables used free
 183 (defvar uniquify-non-file-buffer-names nil)
 184 (defvar uniquify-possibly-resolvable nil)
 185
 186 ;;; Main entry point.
 187
 188 (defun uniquify-rationalize-file-buffer-names (&optional newbuffile newbuf)
 189   "Make file buffer names unique by adding segments from file name.
 190 If `uniquify-min-dir-content' > 0, always pulls that many
 191 file name elements.  Arguments cause only a subset of buffers to be renamed."
 192   (interactive)
 193   (let (fix-list
 194         uniquify-non-file-buffer-names
 195         (newbuffile-nd (and newbuffile
 196                             (uniquify-file-name-nondirectory newbuffile))))
 197     (dolist (buffer (buffer-list))
 198       (let ((bufname (buffer-name buffer))
 199             bfn rawname proposed)
 200         (if (and (not (and uniquify-ignore-buffers-re
 201                            (string-match uniquify-ignore-buffers-re
 202                                          bufname)))
 203                  (setq bfn (if (eq buffer newbuf)
 204                                (when newbuffile
 205                                  (expand-file-name
 206                                   (if (file-directory-p newbuffile)
 207                                       (directory-file-name newbuffile)
 208                                     newbuffile)))
 209                              (uniquify-buffer-file-name buffer)))
 210                  (setq rawname (uniquify-file-name-nondirectory bfn))
 211                  (or (not newbuffile)
 212                      (equal rawname newbuffile-nd))
 213                  (setq proposed (uniquify-get-proposed-name
 214                                  rawname bfn uniquify-min-dir-content)))
 215             (push (list rawname bfn buffer proposed) fix-list)
 216           (push (list bufname) uniquify-non-file-buffer-names))))
 217     ;; selects buffers whose names may need changing, and others that
 218     ;; may conflict, then bring conflicting names together
 219     (uniquify-rationalize-a-list fix-list uniquify-min-dir-content)))
 220
 221 ;; uniquify's version of buffer-file-name; result never contains trailing slash
 222 (defun uniquify-buffer-file-name (buffer)
 223   "Return name of file BUFFER is visiting, or nil if none.
 224 Works on ordinary file-visiting buffers and buffers whose mode is mentioned
 225 in `uniquify-list-buffers-directory-modes', otherwise returns nil."
 226   (or (buffer-file-name buffer)
 227       (with-current-buffer buffer
 228         (and
 229          (memq major-mode uniquify-list-buffers-directory-modes)
 230          (if (boundp 'list-buffers-directory) ; XEmacs mightn't define this
 231              (and list-buffers-directory
 232                   (directory-file-name list-buffers-directory))
 233            ;; don't use default-directory if dired-directory is nil
 234            (and dired-directory
 235                 (expand-file-name
 236                  (directory-file-name
 237                   (if (consp dired-directory)
 238                       (car dired-directory)
 239                     dired-directory)))))))))
 240
 241 (defun uniquify-item-greaterp (item1 item2)
 242   (string-lessp (uniquify-fix-item-proposed item2)
 243                 (uniquify-fix-item-proposed item1)))
 244
 245 (defun uniquify-rationalize-a-list (fix-list depth)
 246   (let (conflicting-sublist     ; all elements have the same proposed name
 247         (old-name "")
 248         proposed-name)
 249     (dolist (item (sort fix-list 'uniquify-item-greaterp))
 250       (setq proposed-name (uniquify-fix-item-proposed item))
 251       (unless (equal proposed-name old-name)
 252         (uniquify-rationalize-conflicting-sublist conflicting-sublist
 253                                                   old-name depth)
 254         (setq conflicting-sublist nil))
 255       (push item conflicting-sublist)
 256       (setq old-name proposed-name))
 257     (uniquify-rationalize-conflicting-sublist
 258      conflicting-sublist old-name depth)))
 259
 260 (defun uniquify-get-proposed-name (base filename depth)
 261   (let (index
 262         (extra-string "")
 263         (fn filename)
 264         (n depth))
 265     (while (and (> n 0)
 266                 (setq index (string-match
 267                              (concat "\\(^\\|/[^/]*\\)/"
 268                                      (regexp-quote extra-string)
 269                                      (regexp-quote base)
 270                                      "\\'")
 271                              fn)))
 272       (setq extra-string (substring fn
 273                                     (if (zerop index) 0 (1+ index))
 274                                     ;; (- (length base)) fails for base = "".
 275                                     ;; Equivalently, we could have used
 276                                     ;; (apply 'substring ...
 277                                     ;;        (and (not (string= "" base))
 278                                     ;;             (list (- (length base)))))
 279                                     (- (length fn) (length base)))
 280             n (1- n)))
 281     (if (zerop n) (setq uniquify-possibly-resolvable t))
 282
 283
 284     ;; Distinguish directories by adding extra separator.
 285     (if (and uniquify-trailing-separator-p
 286              (file-directory-p fn)
 287              (not (string-equal base "")))
 288         (cond ((eq uniquify-buffer-name-style 'forward)
 289                (setq base (concat base "/")))
 290               ((eq uniquify-buffer-name-style 'reverse)
 291                (setq base (concat (or uniquify-separator "\\") base)))))
 292
 293     ;; Trim trailing separator on directory part
 294     (if (and (not (string-equal extra-string ""))
 295              (or (eq uniquify-buffer-name-style 'post-forward)
 296                  (eq uniquify-buffer-name-style 'post-forward-angle-brackets)))
 297         (setq extra-string (substring extra-string 0
 298                                       (- (length extra-string) 1))))
 299
 300     (cond ((string-equal extra-string "")
 301            base)
 302           ((string-equal base "")
 303            extra-string)
 304           ((eq uniquify-buffer-name-style 'forward)
 305            (concat extra-string base))
 306           ((eq uniquify-buffer-name-style 'reverse)
 307            (concat base (uniquify-reverse-components extra-string)))
 308           ((eq uniquify-buffer-name-style 'post-forward)
 309            (concat base (or uniquify-separator "|") extra-string))
 310           ((eq uniquify-buffer-name-style 'post-forward-angle-brackets)
 311            (concat base "<" extra-string ">"))
 312           (t (error "Bad value for uniquify-buffer-name-style: %s"
 313                     uniquify-buffer-name-style)))))
 314
 315
 316 ;; Deal with conflicting-sublist, all of whose elements have identical
 317 ;; "base" components.
 318 (defun uniquify-rationalize-conflicting-sublist (conf-list old-name depth)
 319   (when conf-list
 320     (if (or (cdr conf-list)
 321             (assoc old-name uniquify-non-file-buffer-names))
 322         (when uniquify-possibly-resolvable
 323           (setq uniquify-possibly-resolvable nil
 324                 depth (1+ depth))
 325           (dolist (item conf-list)
 326             (uniquify-set-proposed
 327              item (uniquify-get-proposed-name
 328                    (uniquify-fix-item-base item)
 329                    (uniquify-fix-item-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-fix-item-buffer item)))
 338     (if (not (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