X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/df05087018f21bd5053c1ee21bf1dd7a45118d85..f875b154b4dbaf7901c6bff923581197c1cf8ab5:/lisp/uniquify.el

diff --git a/lisp/uniquify.el b/lisp/uniquify.el
index 33dfe72ae7..24b49a983a 100644
--- a/lisp/uniquify.el
+++ b/lisp/uniquify.el
@@ -1,6 +1,7 @@
 ;;; uniquify.el --- unique buffer names dependent on file name
 
-;; Copyright (c) 1989, 1995, 1996, 1997, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1995, 1996, 1997, 2001, 2002, 2003,
+;;   2004, 2005, 2006 Free Software Foundation, Inc.
 
 ;; Author: Dick King <king@reasoning.com>
 ;; Maintainer: FSF
@@ -21,8 +22,8 @@
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Commentary:
 
@@ -89,7 +90,7 @@
 ;;; User-visible variables
 
 (defgroup uniquify nil
-  "Unique buffer names dependent on file name"
+  "Unique buffer names dependent on file name."
   :group 'applications)
 
 
@@ -112,10 +113,8 @@ would have the following buffer names in the various styles:
   :require 'uniquify
   :group 'uniquify)
 
-(defcustom uniquify-after-kill-buffer-p nil
-  "*If non-nil, rerationalize buffer names after a buffer has been killed.
-This can be dangerous if Emacs Lisp code is keeping track of buffers by their
-names (rather than keeping pointers to the buffers themselves)."
+(defcustom uniquify-after-kill-buffer-p t
+  "If non-nil, rerationalize buffer names after a buffer has been killed."
   :type 'boolean
   :group 'uniquify)
 
@@ -127,7 +126,7 @@ other buffer names are changed."
   :group 'uniquify)
 
 ;; The default value matches certain Gnus buffers.
-(defcustom uniquify-ignore-buffers-re "^\\*\\(un\\)?sent "
+(defcustom uniquify-ignore-buffers-re nil
   "*Regular expression matching buffer names that should not be uniquified.
 For instance, set this to \"^draft-[0-9]+$\" to avoid having uniquify rename
 draft buffers even if `uniquify-after-kill-buffer-p' is non-nil and the
@@ -157,6 +156,16 @@ variable is ignored."
   :type 'boolean
   :group 'uniquify)
 
+(defcustom uniquify-strip-common-suffix
+  ;; Using it when uniquify-min-dir-content>0 doesn't make much sense.
+  (eq 0 uniquify-min-dir-content)
+  "If non-nil, strip common directory suffixes of conflicting files.
+E.g. if you open /a1/b/c/d and /a2/b/c/d, the buffer names will say
+\"d|a1\" and \"d|a2\" instead of \"d|a1/b/c\" and \"d|a2/b/c\".
+This can be handy when you have deep parallel hierarchies."
+  :type 'boolean
+  :group 'uniquify)
+
 (defvar uniquify-list-buffers-directory-modes '(dired-mode cvs-mode)
   "List of modes for which uniquify should obey `list-buffers-directory'.
 That means that when `buffer-file-name' is set to nil, `list-buffers-directory'
@@ -164,69 +173,133 @@ contains the name of the directory which the buffer is visiting.")
 
 ;;; Utilities
 
-;; For directories, return the last component, not the empty string.
-(defun uniquify-file-name-nondirectory (file-name)
-  (file-name-nondirectory (directory-file-name file-name)))
-
 ;; uniquify-fix-list data structure
 (defstruct (uniquify-item
 	    (:constructor nil) (:copier nil)
-	    (:constructor uniquify-make-item (base filename buffer proposed)))
-  base filename buffer proposed)
+	    (:constructor uniquify-make-item
+	     (base dirname buffer &optional proposed)))
+  base dirname buffer proposed)
 
 ;; Internal variables used free
 (defvar uniquify-possibly-resolvable nil)
 
+(defvar uniquify-managed nil
+  "Non-nil if the name of this buffer is managed by uniquify.
+It actually holds the list of `uniquify-item's corresponding to the conflict.")
+(make-variable-buffer-local 'uniquify-managed)
+(put 'uniquify-managed 'permanent-local t)
+
 ;;; Main entry point.
 
-(defun uniquify-rationalize-file-buffer-names (&optional newbuffile newbuf)
+(defun uniquify-rationalize-file-buffer-names (base dirname newbuf)
   "Make file buffer names unique by adding segments from file name.
 If `uniquify-min-dir-content' > 0, always pulls that many
 file name elements.
-Arguments NEWBUFFILE and NEWBUF cause only a subset of buffers to be renamed."
-  (interactive)
-  (let (fix-list
-	(newbuffile-nd (and newbuffile
-			    (uniquify-file-name-nondirectory newbuffile))))
-    (dolist (buffer (buffer-list))
-      (let ((bufname (buffer-name buffer))
-	    bfn rawname proposed)
-	(if (and (not (and uniquify-ignore-buffers-re
-			   (string-match uniquify-ignore-buffers-re
-					 bufname)))
-		 (setq bfn (if (eq buffer newbuf)
-			       (when newbuffile
-				 (expand-file-name
-				  (directory-file-name newbuffile)))
-			     (uniquify-buffer-file-name buffer)))
-		 (setq rawname (uniquify-file-name-nondirectory bfn))
-		 (or (not newbuffile)
-		     (equal rawname newbuffile-nd))
-		 (setq proposed (uniquify-get-proposed-name rawname bfn)))
-	    (push (uniquify-make-item rawname bfn buffer proposed) fix-list))))
-    ;; selects buffers whose names may need changing, and others that
-    ;; may conflict, then bring conflicting names together
-    (uniquify-rationalize-a-list fix-list)))
+Arguments BASE, DIRNAME, and NEWBUF specify the new buffer that causes
+this rationalization."
+  (interactive
+   (list (if uniquify-managed
+	     (uniquify-item-base (car uniquify-managed)) (buffer-name))
+	 (uniquify-buffer-file-name (current-buffer))
+	 (current-buffer)))
+  ;; Make sure we don't get confused by outdated uniquify-managed info in
+  ;; this buffer.
+  (with-current-buffer newbuf (setq uniquify-managed nil))
+  (when dirname
+    (setq dirname (expand-file-name (directory-file-name dirname)))
+    (let ((fix-list (list (uniquify-make-item base dirname newbuf)))
+	  items)
+      (dolist (buffer (buffer-list))
+	(when (and (not (and uniquify-ignore-buffers-re
+			     (string-match uniquify-ignore-buffers-re
+					   (buffer-name buffer))))
+		   ;; Only try to rename buffers we actually manage.
+		   (setq items (buffer-local-value 'uniquify-managed buffer))
+		   (equal base (uniquify-item-base (car items)))
+		   ;; Don't re-add stuff we already have.  Actually this
+		   ;; whole `and' test should only match at most once.
+		   (not (memq (car items) fix-list)))
+	  (unless (cdr items)
+	    ;; If there was no conflict, the buffer-name is equal to the
+	    ;; base-name and we may have missed a rename-buffer because
+	    ;; of code like in set-visited-file-name:
+	    ;; (or (string= new-name (buffer-name)) (rename-buffer new-name t))
+	    ;; So we need to refresh the dirname of the uniquify-item.
+	    (setf (uniquify-item-dirname (car items))
+		  (uniquify-buffer-file-name
+		   (uniquify-item-buffer (car items))))
+	    ;; This shouldn't happen, but maybe there's no dirname any more.
+	    (unless (uniquify-item-dirname (car items))
+	      (with-current-buffer (uniquify-item-buffer (car items))
+		(setq uniquify-managed nil))
+	      (setq items nil)))
+	  (setq fix-list (append fix-list items))))
+      ;; selects buffers whose names may need changing, and others that
+      ;; may conflict, then bring conflicting names together
+      (uniquify-rationalize fix-list))))
 
 ;; uniquify's version of buffer-file-name; result never contains trailing slash
 (defun uniquify-buffer-file-name (buffer)
-  "Return name of file BUFFER is visiting, or nil if none.
+  "Return name of directory, file BUFFER is visiting, or nil if none.
 Works on ordinary file-visiting buffers and buffers whose mode is mentioned
 in `uniquify-list-buffers-directory-modes', otherwise returns nil."
-  (or (buffer-file-name buffer)
-      (with-current-buffer buffer
-	(and
-	 (memq major-mode uniquify-list-buffers-directory-modes)
-	 (if (boundp 'list-buffers-directory) ; XEmacs mightn't define this
-	     (and list-buffers-directory
-		  (directory-file-name list-buffers-directory))
-	   ;; don't use default-directory if dired-directory is nil
-	   (and dired-directory
-		(expand-file-name
-		 (directory-file-name
-		  (if (consp dired-directory)
-		      (car dired-directory)
-		    dired-directory)))))))))
+  (with-current-buffer buffer
+    (let ((filename
+	   (or buffer-file-name
+	       (if (memq major-mode uniquify-list-buffers-directory-modes)
+		   list-buffers-directory))))
+      (when filename
+	(directory-file-name
+	 (file-name-directory
+	  (expand-file-name
+	   (directory-file-name filename))))))))
+
+(defun uniquify-rerationalize-w/o-cb (fix-list)
+  "Re-rationalize the buffers in FIX-LIST, but ignoring current-buffer."
+  (let ((new-fix-list nil))
+    (dolist (item fix-list)
+      (let ((buf (uniquify-item-buffer item)))
+	(unless (or (eq buf (current-buffer)) (not (buffer-live-p buf)))
+	  (push item new-fix-list))))
+    (when new-fix-list
+      (uniquify-rationalize new-fix-list))))
+
+(defun uniquify-rationalize (fix-list)
+  ;; Set up uniquify to re-rationalize after killing/renaming
+  ;; if there is a conflict.
+  (dolist (item fix-list)
+    (with-current-buffer (uniquify-item-buffer item)
+      ;; Refresh the dirnames and proposed names.
+      (setf (uniquify-item-proposed item)
+	    (uniquify-get-proposed-name (uniquify-item-base item)
+					(uniquify-item-dirname item)))
+      (setq uniquify-managed fix-list)))
+  ;; Strip any shared last directory names of the dirname.
+  (when (and (cdr fix-list) uniquify-strip-common-suffix)
+    (let ((strip t))
+      (while (let* ((base (file-name-nondirectory
+			   (uniquify-item-dirname (car fix-list))))
+		    (items fix-list))
+	       (when (> (length base) 0)
+		 (while (and strip items)
+		   (unless (equal base (file-name-nondirectory
+					(uniquify-item-dirname (pop items))))
+		     (setq strip nil)))
+		 strip))
+	;; It's all the same => strip.
+	(dolist (item (prog1 fix-list (setq fix-list nil)))
+	  ;; Create new items because the old ones are kept (with the true
+	  ;; `dirname') for later rerationalizing.
+	  (push (uniquify-make-item (uniquify-item-base item)
+				    (let ((f (file-name-directory
+					      (uniquify-item-dirname item))))
+				      (and f (directory-file-name f)))
+				    (uniquify-item-buffer item)
+				    (uniquify-item-proposed item))
+		fix-list)))))
+  ;; If uniquify-min-dir-content is 0, this will end up just
+  ;; passing fix-list to uniquify-rationalize-conflicting-sublist.
+  (uniquify-rationalize-a-list fix-list))
 
 (defun uniquify-item-greaterp (item1 item2)
   (string-lessp (uniquify-item-proposed item2)
@@ -250,14 +323,13 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
     (uniquify-rationalize-conflicting-sublist conflicting-sublist
 					      old-proposed depth)))
 
-(defun uniquify-get-proposed-name (base filename &optional depth)
+(defun uniquify-get-proposed-name (base dirname &optional depth)
   (unless depth (setq depth uniquify-min-dir-content))
-  (assert (equal base (uniquify-file-name-nondirectory filename)))
-  (assert (equal (directory-file-name filename) filename))
+  (assert (equal (directory-file-name dirname) dirname))  ;No trailing slash.
 
   ;; Distinguish directories by adding extra separator.
   (if (and uniquify-trailing-separator-p
-	   (file-directory-p filename)
+	   (file-directory-p (expand-file-name base dirname))
 	   (not (string-equal base "")))
       (cond ((eq uniquify-buffer-name-style 'forward)
 	     (setq base (file-name-as-directory base)))
@@ -267,20 +339,18 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
 
   (let ((extra-string nil)
 	(n depth))
-    (while (and (> n 0) filename
-		(setq filename (file-name-directory filename))
-		(setq filename (directory-file-name filename)))
-      (let ((file (file-name-nondirectory filename)))
+    (while (and (> n 0) dirname)
+      (let ((file (file-name-nondirectory dirname)))
+	(when (setq dirname (file-name-directory dirname))
+	  (setq dirname (directory-file-name dirname)))
 	(setq n (1- n))
 	(push (if (zerop (length file)) ;nil or "".
-		  (prog1 "" (setq filename nil)) ;Could be `filename' iso "".
+		  (prog1 "" (setq dirname nil)) ;Could be `dirname' iso "".
 		file)
 	      extra-string)))
     (when (zerop n)
-      (if (and filename extra-string
-	       (setq filename (file-name-directory filename))
-	       (equal filename
-		      (file-name-directory (directory-file-name filename))))
+      (if (and dirname extra-string
+	       (equal dirname (file-name-directory dirname)))
 	  ;; We're just before the root.  Let's add the leading / already.
 	  ;; With "/a/b"+"/c/d/b" this leads to "/a/b" and "d/b" but with
 	  ;; "/a/b"+"/c/a/b" this leads to "/a/b" and "a/b".
@@ -324,7 +394,7 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
 	    (setf (uniquify-item-proposed item)
 		  (uniquify-get-proposed-name
 		   (uniquify-item-base item)
-		   (uniquify-item-filename item)
+		   (uniquify-item-dirname item)
 		   depth)))
 	  (uniquify-rationalize-a-list conf-list depth))
       (unless (string= old-name "")
@@ -336,7 +406,7 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
     (unless (equal newname (buffer-name buffer))
       (with-current-buffer buffer
 	(let ((uniquify-buffer-name-style nil))	;Avoid hooks on rename-buffer.
-	  ;; Pass the `unique' arg, just in case.
+	  ;; Pass the `unique' arg, so the advice doesn't mark it as unmanaged.
 	  (rename-buffer newname t))))))
 
 ;;; Hooks from the rest of Emacs
@@ -358,22 +428,25 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
 
 (defadvice rename-buffer (after rename-buffer-uniquify activate)
   "Uniquify buffer names with parts of directory name."
-  (if (and uniquify-buffer-name-style
-	   ;; UNIQUE argument
-	   (ad-get-arg 1))
-      (progn
-	(if uniquify-after-kill-buffer-p
-	    ;; call with no argument; rationalize vs. old name as well as new
-	    (uniquify-rationalize-file-buffer-names)
-	  ;; call with argument: rationalize vs. new name only
-	  (uniquify-rationalize-file-buffer-names
-	   (uniquify-buffer-file-name (current-buffer)) (current-buffer)))
-	(setq ad-return-value (buffer-name (current-buffer))))))
+  (uniquify-maybe-rerationalize-w/o-cb)
+  (if (null (ad-get-arg 1))		; no UNIQUE argument.
+      ;; Mark this buffer so it won't be renamed by uniquify.
+      (setq uniquify-managed nil)
+    (when uniquify-buffer-name-style
+      ;; Rerationalize w.r.t the new name.
+      (uniquify-rationalize-file-buffer-names
+       (ad-get-arg 0)
+       (uniquify-buffer-file-name (current-buffer))
+       (current-buffer))
+      (setq ad-return-value (buffer-name (current-buffer))))))
 
 (defadvice create-file-buffer (after create-file-buffer-uniquify activate)
   "Uniquify buffer names with parts of directory name."
   (if uniquify-buffer-name-style
-      (uniquify-rationalize-file-buffer-names (ad-get-arg 0) ad-return-value)))
+      (let ((filename (expand-file-name (directory-file-name (ad-get-arg 0)))))
+	(uniquify-rationalize-file-buffer-names
+	 (file-name-nondirectory filename)
+	 (file-name-directory filename) ad-return-value))))
 
 ;; Buffer deletion
 ;; Rerationalize after a buffer is killed, to reduce coinciding buffer names.
@@ -386,26 +459,19 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
 ;; (This ought to set some global variables so the work is done only for
 ;; buffers with names similar to the deleted buffer.  -MDE)
 
-(defun uniquify-delay-rationalize-file-buffer-names ()
-  "Add `delayed-uniquify-rationalize-file-buffer-names' to `post-command-hook'.
-For use on, eg, `kill-buffer-hook', to rationalize *after* buffer deletion."
-  (if (and uniquify-buffer-name-style
-	   uniquify-after-kill-buffer-p
-	   ;; Rationalizing is costly, so don't do it for temp buffers.
-	   (uniquify-buffer-file-name (current-buffer)))
-      (add-hook 'post-command-hook
-		'uniquify-delayed-rationalize-file-buffer-names)))
-
-(defun uniquify-delayed-rationalize-file-buffer-names ()
-  "Rerationalize buffer names and remove self from `post-command-hook'.
-See also `delay-rationalize-file-buffer-names' for hook setter."
-  (uniquify-rationalize-file-buffer-names)
-  (remove-hook 'post-command-hook
-	       'uniquify-delayed-rationalize-file-buffer-names))
+(defun uniquify-maybe-rerationalize-w/o-cb ()
+  "Re-rationalize buffer names, ignoring current buffer.
+For use on `kill-buffer-hook'."
+  (if (and (cdr uniquify-managed)
+	   uniquify-buffer-name-style
+	   uniquify-after-kill-buffer-p)
+      (uniquify-rerationalize-w/o-cb uniquify-managed)))
 
 ;; Ideally we'd like to add it buffer-locally, but that doesn't work
 ;; because kill-buffer-hook is not permanent-local :-(
-(add-hook 'kill-buffer-hook 'uniquify-delay-rationalize-file-buffer-names)
+(add-hook 'kill-buffer-hook 'uniquify-maybe-rerationalize-w/o-cb)
 
 (provide 'uniquify)
+
+;; arch-tag: e763faa3-56c9-4903-8eb8-26e1c45a0065
 ;;; uniquify.el ends here