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: Michael Ernst <mernst@theory.lcs.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, just load it; or add (require 'uniquify) to your .emacs.
  38 ;; To disable it after loading, set variable uniquify-buffer-name-style to nil.
  39 ;; For other options, see "User-visible variables", below.
  40
  41 ;; A version of uniquify.el that works under Emacs 18, Emacs 19, XEmacs,
  42 ;; and InfoDock is available from the maintainer.
  43
  44 ;; Doesn't correctly handle buffer names created by M-x write-file in Emacs 18.
  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
  72 ;; Valuable feedback was provided by
  73 ;; Paul Smith <psmith@baynetworks.com>,
  74 ;; Alastair Burt <burt@dfki.uni-kl.de>,
  75 ;; Bob Weiner <weiner@footloose.sps.mot.com>,
  76 ;; Albert L. Ting <alt@vlibs.com>,
  77 ;; gyro@reasoning.com,
  78 ;; Bryan O'Sullivan <bos@eng.sun.com>.
  79
  80
  81 ;;; Code:
  82
  83 (provide 'uniquify)
  84
  85 ;;; User-visible variables
  86
  87 (defvar uniquify-buffer-name-style 'post-forward
  88   "*If non-nil, buffer names are uniquified with parts of directory name.
  89 The value determines the buffer name style and is one of `forward',
  90 `reverse', `post-forward' (the default), or `post-forward-angle-brackets'.
  91 For example, files `/foo/bar/mumble/name' and `/baz/quux/mumble/name'
  92 would have the following buffer names in the various styles:
  93   forward        bar/mumble/name  quux/mumble/name
  94   reverse        name\\mumble\\bar  name\\mumble\\quux
  95   post-forward   name|bar/mumble  name|quux/mumble
  96   post-forward-angle-brackets   name<bar/mumble>  name<quux/mumble>
  97   nil            name  name<2>")
  98
  99 (defvar uniquify-after-kill-buffer-p nil
 100   "*If non-nil, rerationalize buffer names after a buffer has been killed.
 101 This can be dangerous if Emacs Lisp code is keeping track of buffers by their
 102 names (rather than keeping pointers to the buffers themselves).")
 103
 104 (defconst uniquify-ask-about-buffer-names-p nil
 105   "*If non-nil, permit user to choose names for buffers with same base file.
 106 If the user chooses to name a buffer, uniquification is preempted and no
 107 other buffer names are changed.")
 108
 109 (defvar uniquify-min-dir-content 0
 110   "*Minimum parts of directory name included in buffer name.")
 111
 112 (defvar uniquify-separator nil
 113   "*String separator for buffer name components.
 114 When `uniquify-buffer-name-style' is `post-forward', separates
 115 base file name from directory part in buffer names (default \"|\").
 116 When `uniquify-buffer-name-style' is `reverse', separates all
 117 file name components (default \"\\\").")
 118
 119 (defvar uniquify-trailing-separator-p nil
 120   "*If non-nil, add a file name separator to dired buffer names.
 121 If `uniquify-buffer-name-style' is `forward', add the separator at the end;
 122 if it is `reverse', add the separator at the beginning; otherwise, this
 123 variable is ignored.")
 124
 125
 126 ;;; Utilities
 127
 128 (defmacro uniquify-push (item list)
 129   (` (setq (, list) (cons (, item) (, list)))))
 130
 131 (defmacro uniquify-fix-list-base (a)
 132   (` (car (, a))))
 133
 134 (defmacro uniquify-fix-list-filename (a)
 135   (` (car (cdr (, a)))))
 136
 137 (defmacro uniquify-fix-list-buffer (a)
 138   (` (car (cdr (cdr (, a))))))
 139
 140 (defmacro uniquify-cadddr (a)
 141   (` (car (cdr (cdr (cdr (, a)))))))
 142
 143 ;; Internal variables used free
 144 (defvar uniquify-non-file-buffer-names nil)
 145 (defvar uniquify-possibly-resolvable nil)
 146
 147 ;;; Main entry point.
 148
 149 (defun uniquify-rationalize-file-buffer-names (&optional newbuffile newbuf)
 150   "Makes file buffer names unique by adding segments from file name.
 151 If `uniquify-min-dir-content' > 0, always pulls that many
 152 file name elements.  Arguments cause only a subset of buffers to be renamed."
 153   (interactive)
 154   (let (fix-list
 155         uniquify-non-file-buffer-names
 156         (depth uniquify-min-dir-content))
 157     (let ((buffers (buffer-list)))
 158       (while buffers
 159         (let* ((buffer (car buffers))
 160                (bfn (if (eq buffer newbuf)
 161                         (and newbuffile
 162                              (expand-file-name newbuffile))
 163                       (uniquify-buffer-file-name buffer)))
 164                (rawname (and bfn (file-name-nondirectory bfn)))
 165                (deserving (and rawname
 166                                (or (not newbuffile)
 167                                    (equal rawname
 168                                           (file-name-nondirectory newbuffile))))))
 169           (if deserving
 170               (uniquify-push (list rawname bfn buffer nil) fix-list)
 171             (uniquify-push (list (buffer-name buffer))
 172                            uniquify-non-file-buffer-names)))
 173         (setq buffers (cdr buffers))))
 174     ;; selects buffers whose names may need changing, and others that
 175     ;; may conflict.
 176     (setq fix-list
 177           (sort fix-list 'uniquify-fix-list-filename-lessp))
 178     ;; bringing conflicting names together
 179     (uniquify-rationalize-a-list fix-list depth)
 180     (mapcar 'uniquify-unrationalized-buffer fix-list)))
 181
 182 ;; uniquify's version of buffer-file-name
 183 (defun uniquify-buffer-file-name (buffer)
 184   "Return name of file BUFFER is visiting, or nil if none.
 185 Works on dired buffers as well as ordinary file-visiting buffers,
 186 but no others."
 187   (or (buffer-file-name buffer)
 188       (and (featurep 'dired)
 189       (save-excursion
 190         (set-buffer buffer)
 191              (and
 192               (eq major-mode 'dired-mode) ; do nothing if not a dired buffer
 193               (if (boundp 'list-buffers-directory) ; XEmacs mightn't define this
 194                   list-buffers-directory
 195                 ;; don't use default-directory if dired-directory is nil
 196                 (and dired-directory
 197                      (expand-file-name
 198                       (directory-file-name
 199                        (if (consp dired-directory)
 200                            (car dired-directory)
 201                          dired-directory))))))))))
 202
 203 (defun uniquify-fix-list-filename-lessp (fixlist1 fixlist2)
 204   (uniquify-filename-lessp
 205    (uniquify-fix-list-filename fixlist1) (uniquify-fix-list-filename fixlist2)))
 206
 207 ;; This examines the filename components in reverse order.
 208 (defun uniquify-filename-lessp (s1 s2)
 209   (let ((s1f (file-name-nondirectory s1))
 210         (s2f (file-name-nondirectory s2)))
 211     (and (not (equal s2f ""))
 212          (or (string-lessp s1f s2f)
 213              (and (equal s1f s2f)
 214                   (let ((s1d (file-name-directory s1))
 215                         (s2d (file-name-directory s2)))
 216                     (and (not (<= (length s2d) 1))
 217                          (or (<= (length s1d) 1)
 218                              (uniquify-filename-lessp
 219                               (substring s1d 0 -1)
 220                               (substring s2d 0 -1))))))))))
 221
 222 ;; Was named do-the-buffers-you-couldnt-rationalize
 223 (defun uniquify-unrationalized-buffer (item)
 224   (or (uniquify-cadddr item) nil))      ;maybe better in the future
 225
 226 (defun uniquify-rationalize-a-list (fix-list depth)
 227   (let (conflicting-sublist
 228         (old-name "")
 229         proposed-name uniquify-possibly-resolvable)
 230     (while fix-list
 231       (let ((item (car fix-list)))
 232         (setq proposed-name (uniquify-get-proposed-name item depth))
 233         (if (not (equal proposed-name old-name))
 234             (progn
 235               (uniquify-rationalize-conflicting-sublist
 236                conflicting-sublist old-name depth)
 237               (setq conflicting-sublist nil)))
 238         (uniquify-push item conflicting-sublist)
 239         (setq old-name proposed-name))
 240       (setq fix-list (cdr fix-list)))
 241     (uniquify-rationalize-conflicting-sublist
 242      conflicting-sublist old-name depth)))
 243
 244 (defun uniquify-get-proposed-name (item depth)
 245   (let (index
 246         (extra-string "")
 247         (n depth)
 248         (base (uniquify-fix-list-base item))
 249         (fn (uniquify-fix-list-filename item)))
 250     (while (and (> n 0)
 251                 (setq index (string-match
 252                              (concat "\\(^\\|/[^/]*\\)/"
 253                                      (regexp-quote extra-string)
 254                                      (regexp-quote base)
 255                                      "\\'")
 256                              fn)))
 257       (setq extra-string (substring fn
 258                                     (if (zerop index) 0 (1+ index))
 259                                     ;; (- (length base)) fails for base = "".
 260                                     ;; Equivalently, we could have used
 261                                     ;; (apply 'substring ...
 262                                     ;;        (and (not (string= "" base))
 263                                     ;;             (list (- (length base)))))
 264                                     (- (length fn) (length base)))
 265             n (1- n)))
 266     (if (zerop n) (setq uniquify-possibly-resolvable t))
 267
 268
 269     ;; Distinguish directories by adding extra separator.
 270     (if (and uniquify-trailing-separator-p
 271              (file-directory-p fn)
 272              (not (string-equal base "")))
 273         (cond ((eq uniquify-buffer-name-style 'forward)
 274                (setq base (concat base "/")))
 275               ((eq uniquify-buffer-name-style 'reverse)
 276                (setq base (concat (or uniquify-separator "\\") base)))))
 277
 278     ;; Trim trailing separator on directory part
 279     (if (and (not (string-equal extra-string ""))
 280              (or (eq uniquify-buffer-name-style 'post-forward)
 281                  (eq uniquify-buffer-name-style 'post-forward-angle-brackets)))
 282         (setq extra-string (substring extra-string 0
 283                                       (- (length extra-string) 1))))
 284
 285     (cond ((string-equal extra-string "")
 286            base)
 287           ((string-equal base "")
 288            extra-string)
 289           ((eq uniquify-buffer-name-style 'forward)
 290            (concat extra-string base))
 291           ((eq uniquify-buffer-name-style 'reverse)
 292            (concat base (uniquify-reverse-components extra-string)))
 293           ((eq uniquify-buffer-name-style 'post-forward)
 294            (concat base (or uniquify-separator "|") extra-string))
 295           ((eq uniquify-buffer-name-style 'post-forward-angle-brackets)
 296            (concat base "<" extra-string ">"))
 297           (t (error "Bad value for uniquify-buffer-name-style: %s"
 298                     uniquify-buffer-name-style)))))
 299
 300
 301 ;; Deal with conflicting-sublist, which is set by uniquify-rationalize-a-list.
 302 ;; This is only called by uniquify-rationalize-a-list.
 303 (defun uniquify-rationalize-conflicting-sublist (conflicting-sublist old-name depth)
 304   (or (null conflicting-sublist)
 305       (and (null (cdr conflicting-sublist))
 306            (not (assoc old-name uniquify-non-file-buffer-names))
 307            (or (and (not (string= old-name ""))
 308                     (uniquify-rename-buffer (car conflicting-sublist) old-name))
 309                t))
 310       (if uniquify-possibly-resolvable
 311           (uniquify-rationalize-a-list conflicting-sublist (1+ depth)))))
 312
 313 (defun uniquify-rename-buffer (item newname)
 314   (let ((buffer (uniquify-fix-list-buffer item)))
 315     (if (not (equal newname (buffer-name buffer)))
 316         (let ((unset (current-buffer))
 317               ;; avoid hooks on rename-buffer
 318               (uniquify-buffer-name-style nil))
 319           (set-buffer buffer)
 320           (rename-buffer newname)
 321           (set-buffer unset))))
 322   (rplaca (nthcdr 3 item) t))
 323
 324 (defun uniquify-reverse-components (instring)
 325   (let ((sofar '())
 326         (cursor 0)
 327         (len (length instring))
 328         (sep (or uniquify-separator "\\")))
 329     (while (< cursor len)
 330       (if (= (aref instring cursor) ?/)
 331           (setq sofar (cons sep sofar)
 332                 cursor (1+ cursor))
 333         (let ((first-slash (or (string-match "/" instring cursor) len)))
 334           (setq sofar (cons (substring instring cursor first-slash) sofar)
 335                 cursor first-slash))))
 336     (apply (function concat) sofar)))
 337
 338
 339 ;;; Hooks from the rest of Emacs
 340
 341 ;; Emacs 19 (Emacs or XEmacs)
 342
 343 ;; The logical place to put all this code is in generate-new-buffer-name.
 344 ;; It's written in C, so we would add a generate-new-buffer-name-function
 345 ;; which, if non-nil, would be called instead of the C.  One problem with
 346 ;; that is that generate-new-buffer-name takes a potential buffer name as
 347 ;; its argument -- not other information, such as what file the buffer will
 348 ;; visit.
 349
 350 ;; The below solution works because generate-new-buffer-name is called
 351 ;; only by rename-buffer (which, as of 19.29, is never called from C) and
 352 ;; generate-new-buffer, which is called only by Lisp functions
 353 ;; create-file-buffer and rename-uniquely.  Rename-uniquely generally
 354 ;; isn't used for buffers visiting files, so it's sufficient to hook
 355 ;; rename-buffer and create-file-buffer.  (Setting find-file-hooks isn't
 356 ;; sufficient.)
 357
 358 (defadvice rename-buffer (after rename-buffer-uniquify activate)
 359   "Uniquify buffer names with parts of directory name."
 360   (if (and uniquify-buffer-name-style
 361            ;; UNIQUE argument
 362            (ad-get-arg 1))
 363       (progn
 364         (if uniquify-after-kill-buffer-p
 365             ;; call with no argument; rationalize vs. old name as well as new
 366             (uniquify-rationalize-file-buffer-names)
 367           ;; call with argument: rationalize vs. new name only
 368           (uniquify-rationalize-file-buffer-names
 369            (uniquify-buffer-file-name (current-buffer)) (current-buffer)))
 370         (setq ad-return-value (buffer-name (current-buffer))))))
 371
 372 (defadvice create-file-buffer (after create-file-buffer-uniquify activate)
 373   "Uniquify buffer names with parts of directory name."
 374   (if uniquify-buffer-name-style
 375       (uniquify-rationalize-file-buffer-names (ad-get-arg 0) ad-return-value)))
 376
 377 ;; Buffer deletion
 378 ;; Rerationalize after a buffer is killed, to reduce coinciding buffer names.
 379 ;; This mechanism uses `kill-buffer-hook', which runs *before* deletion.
 380 ;; That means that the kill-buffer-hook function cannot just delete the
 381 ;; buffer -- it has to set something to do the rationalization *later*.
 382 ;; It actually puts another function on `post-command-hook'.  This other
 383 ;; function runs the rationalization and then removes itself from the hook.
 384 ;; Is there a better way to accomplish this?
 385 ;; (This ought to set some global variables so the work is done only for
 386 ;; buffers with names similar to the deleted buffer.  -MDE)
 387
 388 (defun delay-uniquify-rationalize-file-buffer-names ()
 389   "Add `delayed-uniquify-rationalize-file-buffer-names' to `post-command-hook'.
 390 For use on, eg, `kill-buffer-hook', to rationalize *after* buffer deletion."
 391   (if (and uniquify-buffer-name-style
 392            uniquify-after-kill-buffer-p)
 393       (add-hook 'post-command-hook
 394                 'delayed-uniquify-rationalize-file-buffer-names)))
 395
 396 (defun delayed-uniquify-rationalize-file-buffer-names ()
 397   "Rerationalize buffer names and remove self from `post-command-hook'.
 398 See also `delay-rationalize-file-buffer-names' for hook setter."
 399   (uniquify-rationalize-file-buffer-names)
 400   (remove-hook 'post-command-hook
 401                'delayed-uniquify-rationalize-file-buffer-names))
 402
 403 (add-hook 'kill-buffer-hook 'delay-uniquify-rationalize-file-buffer-names)
 404
 405 ;;; uniquify.el ends here