- "Return name of file BUFFER is visiting, or nil if none.
-Works on dired buffers as well as ordinary file-visiting buffers,
-but no others."
- (or (buffer-file-name buffer)
- (and (featurep 'dired)
- (save-excursion
- (set-buffer buffer)
- (when (eq major-mode 'dired-mode) ; do nothing if not a dired buffer
- (if (boundp 'list-buffers-directory) ; XEmacs mightn't define this
- 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))))))))))
-
-(defun uniquify-fix-list-filename-lessp (fixlist1 fixlist2)
- (uniquify-filename-lessp
- (uniquify-fix-list-filename fixlist1
- ) (uniquify-fix-list-filename fixlist2)))
-
-;; This examines the filename components in reverse order.
-(defun uniquify-filename-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)
- (uniquify-filename-lessp
- (substring s1d 0 -1)
- (substring s2d 0 -1))))))))))
-
-;; Was named do-the-buffers-you-couldnt-rationalize
-(defun uniquify-unrationalized-buffer (item)
- (or (uniquify-cadddr item) nil)) ;maybe better in the future
-
-(defun uniquify-rationalize-a-list (fix-list depth)
- (let (conflicting-sublist
- (old-name "")
- proposed-name uniquify-possibly-resolvable)
- (while fix-list
- (let ((item (car fix-list)))
- (setq proposed-name (uniquify-get-proposed-name item depth))
- (if (not (equal proposed-name old-name))
- (progn
- (uniquify-rationalize-conflicting-sublist
- conflicting-sublist old-name depth)
- (setq conflicting-sublist nil)))
- (uniquify-push item conflicting-sublist)
- (setq old-name proposed-name))
- (setq fix-list (cdr fix-list)))
- (uniquify-rationalize-conflicting-sublist
- conflicting-sublist old-name depth)))
-
-(defun uniquify-get-proposed-name (item depth)
- (let (index
- (extra-string "")
- (n depth)
- (base (uniquify-fix-list-base item))
- (fn (uniquify-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)) fails for base = "".
- ;; Equivalently, we could have used
- ;; (apply 'substring ...
- ;; (and (not (string= "" base))
- ;; (list (- (length base)))))
- (- (length fn) (length base)))
- n (1- n)))
- (if (zerop n) (setq uniquify-possibly-resolvable t))
-
-
- ;; Distinguish directories by adding extra separator.
- (if (and uniquify-trailing-separator-p
- (file-directory-p fn)
- (not (string-equal base "")))
- (cond ((eq uniquify-buffer-name-style 'forward)
- (setq base (concat base "/")))
- ((eq uniquify-buffer-name-style 'reverse)
- (setq base (concat (or uniquify-separator "\\") base)))))
-
- ;; Trim trailing separator on directory part
- (if (and (not (string-equal extra-string ""))
- (or (eq uniquify-buffer-name-style 'post-forward)
- (eq uniquify-buffer-name-style 'post-forward-angle-brackets)))
- (setq extra-string (substring extra-string 0
- (- (length extra-string) 1))))
-
- (cond ((string-equal extra-string "")
- base)
- ((string-equal base "")
- extra-string)
- ((eq uniquify-buffer-name-style 'forward)
- (concat extra-string base))
- ((eq uniquify-buffer-name-style 'reverse)
- (concat base (uniquify-reverse-components extra-string)))
- ((eq uniquify-buffer-name-style 'post-forward)
- (concat base (or uniquify-separator "|") extra-string))
- ((eq uniquify-buffer-name-style 'post-forward-angle-brackets)
- (concat base "<" extra-string ">"))
- (t (error "Bad value for uniquify-buffer-name-style: %s"
- uniquify-buffer-name-style)))))
-
-
-;; Deal with conflicting-sublist, which is set by uniquify-rationalize-a-list.
-;; This is only called by uniquify-rationalize-a-list.
-(defun uniquify-rationalize-conflicting-sublist (conflicting-sublist old-name depth)
- (or (null conflicting-sublist)
- (and (null (cdr conflicting-sublist))
- (not (assoc old-name uniquify-non-file-buffer-names))
- (or (and (not (string= old-name ""))
- (uniquify-rename-buffer (car conflicting-sublist) old-name))
- t))
- (if uniquify-possibly-resolvable
- (uniquify-rationalize-a-list conflicting-sublist (1+ depth)))))
+ "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."
+ (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)
+ (uniquify-item-proposed item1)))
+
+(defun uniquify-rationalize-a-list (fix-list &optional depth)
+ (unless depth (setq depth uniquify-min-dir-content))
+ (let (conflicting-sublist ; all elements have the same proposed name
+ (old-proposed "")
+ proposed)
+ ;; Divide fix-list into items with same proposed names and pass them
+ ;; to uniquify-rationalize-conflicting-sublist.
+ (dolist (item (sort fix-list 'uniquify-item-greaterp))
+ (setq proposed (uniquify-item-proposed item))
+ (unless (equal proposed old-proposed)
+ (uniquify-rationalize-conflicting-sublist conflicting-sublist
+ old-proposed depth)
+ (setq conflicting-sublist nil))
+ (push item conflicting-sublist)
+ (setq old-proposed proposed))
+ (uniquify-rationalize-conflicting-sublist conflicting-sublist
+ old-proposed depth)))
+
+(defun uniquify-get-proposed-name (base dirname &optional depth)
+ (unless depth (setq depth uniquify-min-dir-content))
+ (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 (expand-file-name base dirname))
+ (not (string-equal base "")))
+ (cond ((eq uniquify-buffer-name-style 'forward)
+ (setq base (file-name-as-directory base)))
+ ;; (setq base (concat base "/")))
+ ((eq uniquify-buffer-name-style 'reverse)
+ (setq base (concat (or uniquify-separator "\\") base)))))
+
+ (let ((extra-string nil)
+ (n depth))
+ (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 dirname nil)) ;Could be `dirname' iso "".
+ file)
+ extra-string)))
+ (when (zerop n)
+ (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".
+ (push "" extra-string))
+ (setq uniquify-possibly-resolvable t))
+
+ (cond
+ ((null extra-string) base)
+ ((string-equal base "") ;Happens for dired buffers on the root directory.
+ (mapconcat 'identity extra-string "/"))
+ ((eq uniquify-buffer-name-style 'reverse)
+ (mapconcat 'identity
+ (cons base (nreverse extra-string))
+ (or uniquify-separator "\\")))
+ ((eq uniquify-buffer-name-style 'forward)
+ (mapconcat 'identity (nconc extra-string (list base))
+ "/"))
+ ((eq uniquify-buffer-name-style 'post-forward)
+ (concat base (or uniquify-separator "|")
+ (mapconcat 'identity extra-string "/")))
+ ((eq uniquify-buffer-name-style 'post-forward-angle-brackets)
+ (concat base "<" (mapconcat 'identity extra-string "/")
+ ">"))
+ (t (error "Bad value for uniquify-buffer-name-style: %s"
+ uniquify-buffer-name-style)))))
+
+
+;; Deal with conflicting-sublist, all of whose elements have identical
+;; "base" components.
+(defun uniquify-rationalize-conflicting-sublist (conf-list old-name depth)
+ (when conf-list
+ (if (or (cdr conf-list)
+ ;; Check that the proposed name doesn't conflict with some
+ ;; existing buffer.
+ (let ((buf (get-buffer old-name)))
+ (and buf (not (eq buf (uniquify-item-buffer (car conf-list)))))))
+ (when uniquify-possibly-resolvable
+ (setq uniquify-possibly-resolvable nil
+ depth (1+ depth))
+ (dolist (item conf-list)
+ (setf (uniquify-item-proposed item)
+ (uniquify-get-proposed-name
+ (uniquify-item-base item)
+ (uniquify-item-dirname item)
+ depth)))
+ (uniquify-rationalize-a-list conf-list depth))
+ (unless (string= old-name "")
+ (uniquify-rename-buffer (car conf-list) old-name)))))