Path: utzoo!utgpu!jarvis.csri.toronto.edu!mailrus!tut.cis.ohio-state.edu!BBN.COM!gildea
From: gildea@BBN.COM (Stephen Gildea)
Newsgroups: gnu.emacs
Subject: Re: small problem in dired mode
Message-ID: <8905050527.AA15716@life.ai.mit.edu>
Date: 5 May 89 05:25:22 GMT
Sender: daemon@tut.cis.ohio-state.edu
Distribution: gnu
Organization: BBN Communications Corporation, Cambridge, Massachusetts
Lines: 164


    Date: 4 May 89 19:58:50 GMT
    From: Michael Bergman <spdcc!m2c!bergman@bu-cs.bu.edu>
                                                               ... is
    there a way to tell gnuemacs to show the full path in the mode line
    instead of just the buffer name, or to make the buffer name include
    the full path?

Here is a dandy package I got from Dick King a few years ago called uniquify.
It puts as much of the directory information as necessary into the buffer
name to make it unique.  Much nicer than filex<1>, filex<2>, etc.

 < Stephen


; uniquify.el
;
;;; From Dick King <king@kestrel> 15 May 86
;;; This file is not part of GNU Emacs.

(provide 'uniquify)

(defvar mnemonic-buffer-names t
  "*If non-nil, uniquifies buffer names with parts of directory name")

(defvar minimum-buffer-name-dir-content 1
  "*Minimum parts of directory pathname included in buffer name")

(defmacro push (item list)
  (` (setq (, list) (cons (, item) (, list)))))

(defmacro cadr (a)
  (` (car (cdr (, a)))))

(defmacro caddr (a)
  (` (cadr (cdr (, a)))))

(defmacro cadddr (a)
  (` (caddr (cdr (, a)))))


(defun distribute-buffer-name-stuff (buffer)
  (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 (push (list rawname bfn buffer nil)
			fix-list)
      (push (list (buffer-name buffer)) non-file-buffer-names))))

(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 backward-filename-string-lessp-cadr (s1 s2)
  (backward-filename-string-lessp (cadr s1) (cadr s2)))

(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-cadr))
    ;; bringing conflicting names together
    (rationalize-a-list fix-list depth)
    (mapcar 'do-the-buffers-you-couldnt-rationalize fix-list)))

(defun do-the-buffers-you-couldnt-rationalize (item)
  (or (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))      
  (push item conflicting-sublist)
  (setq old-name proposed-name))

(defun get-proposed-name ()
  (let (index (extra-string "") (n depth)
	      (base (car item)) (fn (cadr 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))
    (concat base "|" extra-string)))

(defun rename-the-buffer (item newname)
  (let ((buffer (caddr 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))

(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 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)))))))