gildea@BBN.COM (Stephen Gildea) (06/08/89)
Uniquify is a package that allows your buffers to have intelligent
names if you are editting more than one file with the same name. The
package uses the name of the enclosing directory or directories to
generate unique buffer names.
The version posted here causes no modifications at all to non-conflicting
buffer names when minimum-buffer-name-dir-content is 0, which was also
changed to be the default. It also cleans up some of the cruft in the
previous version.
< Stephen
;;; uniquify.el Unique buffer names in a rational way
;;; Time stamp <89/06/05 11:50:27 gildea>
;;; Copyright (c) 1989 Free Software Foundation, Inc.
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 1 as
;;; published by the Free Software Foundation.
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;; This file is not part of GNU Emacs.
;;; Doesn't correctly handle new buffer names created by M-x write-file
;;; Originally by Dick King <king@kestrel> 15 May 86
;;; Converted for Emacs 18 by Stephen Gildea <gildea@bbn.com>
;;; Make minimum-buffer-name-dir-content 0 truly non-invasive gildea 23 May 89
;;; Some cleanup. minimum-buffer-name-dir-content default 0 gildea 01 Jun 89
(provide 'uniquify)
(defvar mnemonic-buffer-names t
"*If non-nil, uniquifies buffer names with parts of directory name.")
(defvar minimum-buffer-name-dir-content 0
"*Minimum parts of directory pathname included in buffer name.")
(defmacro uniquify-push (item list)
(` (setq (, list) (cons (, item) (, list)))))
(defmacro fix-list-base (a)
(` (car (, a))))
(defmacro fix-list-filename (a)
(` (car (cdr (, a)))))
(defmacro fix-list-buffer (a)
(` (car (cdr (cdr (, a))))))
(defmacro uniquify-cadddr (a)
(` (car (cdr (cdr (cdr (, a)))))))
;;; Main entry point.
(defun rationalize-file-buffer-names (&optional newbuffile newbuf)
"Makes file buffer names unique by adding segments from pathname.
If minimum-buffer-name-dir-content > 0, always pulls that many
pathname elements. Arguments cause only a subset of buffers to be renamed."
(interactive)
(let (fix-list
non-file-buffer-names
(depth minimum-buffer-name-dir-content))
(mapcar 'distribute-buffer-name-stuff (buffer-list))
;; selects buffers whose names may need changing, and others that
;; may conflict.
(setq fix-list
(sort fix-list 'backward-filename-string-lessp-fix-list-filename))
;; bringing conflicting names together
(rationalize-a-list fix-list depth)
(mapcar 'do-the-buffers-you-couldnt-rationalize fix-list)))
(defun distribute-buffer-name-stuff (buffer)
;; Sets the free variables fix-list and non-file-buffer-names.
;; Uses free variables newbuffile and newbuf.
(let* ((bfn (if (eq buffer newbuf)
(expand-file-name newbuffile)
(buffer-file-name buffer)))
(rawname (and bfn (file-name-nondirectory bfn)))
(deserving (and rawname
(or (not newbuffile)
(equal rawname
(file-name-nondirectory newbuffile))))))
(if deserving
(uniquify-push (list rawname bfn buffer nil) fix-list)
(uniquify-push (list (buffer-name buffer)) non-file-buffer-names))))
(defun backward-filename-string-lessp-fix-list-filename (s1 s2)
(backward-filename-string-lessp
(fix-list-filename s1) (fix-list-filename s2)))
(defun backward-filename-string-lessp (s1 s2)
(let ((s1f (file-name-nondirectory s1))
(s2f (file-name-nondirectory s2)))
(and (not (equal s2f ""))
(or (string-lessp s1f s2f)
(and (equal s1f s2f)
(let ((s1d (file-name-directory s1))
(s2d (file-name-directory s2)))
(and (not (<= (length s2d) 1))
(or (<= (length s1d) 1)
(backward-filename-string-lessp
(substring s1d 0 -1)
(substring s2d 0 -1))))))))))
(defun do-the-buffers-you-couldnt-rationalize (item)
(or (uniquify-cadddr item) nil)) ;maybe better in the future
(defun rationalize-a-list (fix-list depth)
(let (conflicting-sublist
(old-name "")
proposed-name possibly-resolvable)
(mapcar 'go-through-an-item-on-fix-list fix-list)
(flush-fix-list)))
(defun go-through-an-item-on-fix-list (item)
(setq proposed-name (get-proposed-name))
(if (not (equal proposed-name old-name))
(flush-fix-list))
(uniquify-push item conflicting-sublist)
(setq old-name proposed-name))
(defun get-proposed-name ()
(let (index (extra-string "") (n depth)
(base (fix-list-base item)) (fn (fix-list-filename item)))
(while (and (> n 0)
(setq index (string-match
(concat "/[^/]*/"
(regexp-quote extra-string)
(regexp-quote base)
"\\'")
fn)))
(setq extra-string (substring fn
(if (zerop index) 0 (1+ index))
(- (length base)))
n (1- n)))
(if (zerop n) (setq possibly-resolvable t))
(if (string-equal extra-string "")
base
(concat base "|" extra-string))))
(defun flush-fix-list ()
(or (null conflicting-sublist)
(and (null (cdr conflicting-sublist))
(not (assoc old-name non-file-buffer-names))
(or (rename-the-buffer (car conflicting-sublist) old-name)
t))
(if possibly-resolvable
(rationalize-a-list conflicting-sublist (1+ depth))))
(setq conflicting-sublist nil))
(defun rename-the-buffer (item newname)
(let ((buffer (fix-list-buffer item)))
(if (not (equal newname (buffer-name buffer)))
(let ((unset (current-buffer)))
(set-buffer buffer)
(rename-buffer newname)
(set-buffer unset))))
(rplaca (nthcdr 3 item) t))
;;; Hooks from the rest of Emacs
(defun create-file-buffer (filename) ;from files.el
"Creates a suitably named buffer for visiting FILENAME, and returns it."
(let ((base (file-name-nondirectory filename)))
(let ((buf (generate-new-buffer base)))
(if mnemonic-buffer-names
(rationalize-file-buffer-names filename buf))
buf)))
(defun dired-find-buffer (dirname) ;from dired.el
(let ((blist (buffer-list))
found)
(while blist
(save-excursion
(set-buffer (car blist))
(if (and (eq major-mode 'dired-mode)
(equal dired-directory dirname))
(setq found (car blist)
blist nil)
(setq blist (cdr blist)))))
(or found
(progn (if (string-match "/$" dirname)
(setq dirname (substring dirname 0 -1)))
(create-file-buffer (if mnemonic-buffer-names
dirname
(file-name-nondirectory dirname)))))))