Don't recalculate the buffer basename inside uniquify
Previously, uniquify--create-file-buffer-advice would use the filename of the buffer to calculate what the buffer's basename should be. Now that gets passed in from create-file-buffer, which lets us fix several bugs: 1. before this patch, if a buffer happened to be named the same thing as directory in its default-directory, the buffer would get renamed with a directory separator according to uniquify-trailing-separator-p. 2. buffers with a leading space should get a leading |, as described by create-file-buffer's docstring; before this patch, uniquify would remove that leading |. * lisp/dired.el (dired-internal-noselect): Pass a directory name to create-file-buffer. * lisp/files.el (create-file-buffer): Do uniquify-trailing-separator-p handling if passed a directory filename. (bug#62732) * lisp/uniquify.el (uniquify-item): (uniquify-rationalize-file-buffer-names, uniquify-rationalize, uniquify-get-proposed-name, uniquify-rationalize-conflicting-sublist): Remove uniquify-trailing-separator-p handling. (uniquify--create-file-buffer-advice): Take new basename argument and use it, instead of recalculating the basename from the filename.
This commit is contained in:
Spencer Baugh
Stefan Monnier
parent
0cd519971d
commit
ee4cc106b8
4 changed files with 159 additions and 37 deletions
|
|
@ -1311,7 +1311,7 @@ The return value is the target column for the file names."
|
|||
;; Note that buffer already is in dired-mode, if found.
|
||||
(new-buffer-p (null buffer)))
|
||||
(or buffer
|
||||
(setq buffer (create-file-buffer (directory-file-name dirname))))
|
||||
(setq buffer (create-file-buffer dirname)))
|
||||
(set-buffer buffer)
|
||||
(if (not new-buffer-p) ; existing buffer ...
|
||||
(cond (switches ; ... but new switches
|
||||
|
|
|
|||
|
|
@ -2084,22 +2084,30 @@ killed."
|
|||
(kill-buffer obuf))))))
|
||||
|
||||
;; FIXME we really need to fold the uniquify stuff in here by default,
|
||||
;; not using advice, and add it to the doc string.
|
||||
(defun create-file-buffer (filename)
|
||||
"Create a suitably named buffer for visiting FILENAME, and return it.
|
||||
FILENAME (sans directory) is used unchanged if that name is free;
|
||||
otherwise a string <2> or <3> or ... is appended to get an unused name.
|
||||
otherwise the buffer is renamed according to
|
||||
`uniquify-buffer-name-style' to get an unused name.
|
||||
|
||||
Emacs treats buffers whose names begin with a space as internal buffers.
|
||||
To avoid confusion when visiting a file whose name begins with a space,
|
||||
this function prepends a \"|\" to the final result if necessary."
|
||||
(let* ((lastname (file-name-nondirectory filename))
|
||||
(lastname (if (string= lastname "")
|
||||
filename lastname))
|
||||
(buf (generate-new-buffer (if (string-prefix-p " " lastname)
|
||||
(concat "|" lastname)
|
||||
lastname))))
|
||||
(uniquify--create-file-buffer-advice buf filename)
|
||||
(let* ((lastname (file-name-nondirectory (directory-file-name filename)))
|
||||
(lastname (cond
|
||||
((not (and uniquify-trailing-separator-p
|
||||
(file-directory-p filename)))
|
||||
lastname)
|
||||
((eq uniquify-buffer-name-style 'forward)
|
||||
(file-name-as-directory lastname))
|
||||
((eq uniquify-buffer-name-style 'reverse)
|
||||
(concat (or uniquify-separator "\\") lastname))
|
||||
(t lastname)))
|
||||
(basename (if (string-prefix-p " " lastname)
|
||||
(concat "|" lastname)
|
||||
lastname))
|
||||
(buf (generate-new-buffer basename)))
|
||||
(uniquify--create-file-buffer-advice buf filename basename)
|
||||
buf))
|
||||
|
||||
(defvar abbreviated-home-dir nil
|
||||
|
|
|
|||
|
|
@ -174,8 +174,8 @@ contains the name of the directory which the buffer is visiting.")
|
|||
(cl-defstruct (uniquify-item
|
||||
(:constructor nil) (:copier nil)
|
||||
(:constructor uniquify-make-item
|
||||
(base dirname buffer &optional proposed original-dirname)))
|
||||
base dirname buffer proposed original-dirname)
|
||||
(base dirname buffer &optional proposed)))
|
||||
base dirname buffer proposed)
|
||||
|
||||
;; Internal variables used free
|
||||
(defvar uniquify-possibly-resolvable nil)
|
||||
|
|
@ -211,7 +211,7 @@ this rationalization."
|
|||
(when dirname
|
||||
(setq dirname (expand-file-name (directory-file-name dirname)))
|
||||
(let ((fix-list (list (uniquify-make-item base dirname newbuf
|
||||
nil dirname)))
|
||||
nil)))
|
||||
items)
|
||||
(dolist (buffer (buffer-list))
|
||||
(when (and (not (and uniquify-ignore-buffers-re
|
||||
|
|
@ -292,8 +292,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-dirname item)
|
||||
nil
|
||||
(uniquify-item-original-dirname item)))
|
||||
nil))
|
||||
(setq uniquify-managed fix-list)))
|
||||
;; Strip any shared last directory names of the dirname.
|
||||
(when (and (cdr fix-list) uniquify-strip-common-suffix)
|
||||
|
|
@ -316,8 +315,7 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
|
|||
(uniquify-item-dirname item))))
|
||||
(and f (directory-file-name f)))
|
||||
(uniquify-item-buffer item)
|
||||
(uniquify-item-proposed item)
|
||||
(uniquify-item-original-dirname 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.
|
||||
|
|
@ -345,21 +343,10 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
|
|||
(uniquify-rationalize-conflicting-sublist conflicting-sublist
|
||||
old-proposed depth)))
|
||||
|
||||
(defun uniquify-get-proposed-name (base dirname &optional depth
|
||||
original-dirname)
|
||||
(defun uniquify-get-proposed-name (base dirname &optional depth)
|
||||
(unless depth (setq depth uniquify-min-dir-content))
|
||||
(cl-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 original-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)
|
||||
|
|
@ -421,8 +408,7 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
|
|||
(uniquify-get-proposed-name
|
||||
(uniquify-item-base item)
|
||||
(uniquify-item-dirname item)
|
||||
depth
|
||||
(uniquify-item-original-dirname item))))
|
||||
depth)))
|
||||
(uniquify-rationalize-a-list conf-list depth))
|
||||
(unless (string= old-name "")
|
||||
(uniquify-rename-buffer (car conf-list) old-name)))))
|
||||
|
|
@ -492,15 +478,14 @@ For use on `kill-buffer-hook'."
|
|||
|
||||
|
||||
;; (advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice)
|
||||
(defun uniquify--create-file-buffer-advice (buf filename)
|
||||
(defun uniquify--create-file-buffer-advice (buf filename basename)
|
||||
;; BEWARE: This is called directly from `files.el'!
|
||||
"Uniquify buffer names with parts of directory name."
|
||||
(when uniquify-buffer-name-style
|
||||
(let ((filename (expand-file-name (directory-file-name filename))))
|
||||
(uniquify-rationalize-file-buffer-names
|
||||
(file-name-nondirectory filename)
|
||||
(file-name-directory filename)
|
||||
buf))))
|
||||
(uniquify-rationalize-file-buffer-names
|
||||
basename
|
||||
(file-name-directory (expand-file-name (directory-file-name filename)))
|
||||
buf)))
|
||||
|
||||
(defun uniquify-unload-function ()
|
||||
"Unload the uniquify library."
|
||||
|
|
|
|||
129
test/lisp/uniquify-tests.el
Normal file
129
test/lisp/uniquify-tests.el
Normal file
|
|
@ -0,0 +1,129 @@
|
|||
;;; uniquify-tests.el --- Tests for uniquify -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2023 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Spencer Baugh <sbaugh@janestreet.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; 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.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
|
||||
(ert-deftest uniquify-basic ()
|
||||
(let (bufs old-names)
|
||||
(cl-flet ((names-are (current-names &optional nosave)
|
||||
(should (equal (mapcar #'buffer-name bufs) current-names))
|
||||
(unless nosave (push current-names old-names))))
|
||||
(should (eq (get-buffer "z") nil))
|
||||
(push (find-file-noselect "a/b/z") bufs)
|
||||
(names-are '("z"))
|
||||
(push (find-file-noselect "a/b/c/z") bufs)
|
||||
(names-are '("z<c>" "z<b>"))
|
||||
(push (find-file-noselect "a/b/d/z") bufs)
|
||||
(names-are '("z<d>" "z<c>" "z<b>"))
|
||||
(push (find-file-noselect "e/b/z") bufs)
|
||||
(names-are '("z<e/b>" "z<d>" "z<c>" "z<a/b>"))
|
||||
;; buffers without a buffer-file-name don't get uniquified by uniquify
|
||||
(push (generate-new-buffer "z") bufs)
|
||||
(names-are '("z" "z<e/b>" "z<d>" "z<c>" "z<a/b>"))
|
||||
;; but they do get uniquified by the C code which uses <n>
|
||||
(push (generate-new-buffer "z") bufs)
|
||||
(names-are '("z<2>" "z" "z<e/b>" "z<d>" "z<c>" "z<a/b>"))
|
||||
(save-excursion
|
||||
;; uniquify will happily work with file-visiting buffers whose names don't match buffer-file-name
|
||||
(find-file "f/y")
|
||||
(push (current-buffer) bufs)
|
||||
(rename-buffer "z" t)
|
||||
(names-are '("z<f>" "z<2>" "z" "z<e/b>" "z<d>" "z<c>" "z<a/b>") 'nosave)
|
||||
;; somewhat confusing behavior results if a buffer is renamed to match an already-uniquified buffer
|
||||
(rename-buffer "z<a/b>" t)
|
||||
(names-are '("z<a/b><f>" "z<2>" "z" "z<e/b>" "z<d>" "z<c>" "z<a/b>") 'nosave))
|
||||
(while bufs
|
||||
(kill-buffer (pop bufs))
|
||||
(names-are (pop old-names) 'nosave)))))
|
||||
|
||||
(ert-deftest uniquify-dirs ()
|
||||
"Check strip-common-suffix and trailing-separator-p work together; bug#47132"
|
||||
(let* ((root (make-temp-file "emacs-uniquify-tests" 'dir))
|
||||
(a-path (file-name-concat root "a/x/y/dir"))
|
||||
(b-path (file-name-concat root "b/x/y/dir")))
|
||||
(make-directory a-path 'parents)
|
||||
(make-directory b-path 'parents)
|
||||
(let ((uniquify-buffer-name-style 'forward)
|
||||
(uniquify-strip-common-suffix t)
|
||||
(uniquify-trailing-separator-p nil))
|
||||
(let ((bufs (list (find-file-noselect a-path)
|
||||
(find-file-noselect b-path))))
|
||||
(should (equal (mapcar #'buffer-name bufs)
|
||||
'("a/dir" "b/dir")))
|
||||
(mapc #'kill-buffer bufs)))
|
||||
(let ((uniquify-buffer-name-style 'forward)
|
||||
(uniquify-strip-common-suffix nil)
|
||||
(uniquify-trailing-separator-p t))
|
||||
(let ((bufs (list (find-file-noselect a-path)
|
||||
(find-file-noselect b-path))))
|
||||
(should (equal (mapcar #'buffer-name bufs)
|
||||
'("a/x/y/dir/" "b/x/y/dir/")))
|
||||
(mapc #'kill-buffer bufs)))
|
||||
(let ((uniquify-buffer-name-style 'forward)
|
||||
(uniquify-strip-common-suffix t)
|
||||
(uniquify-trailing-separator-p t))
|
||||
(let ((bufs (list (find-file-noselect a-path)
|
||||
(find-file-noselect b-path))))
|
||||
(should (equal (mapcar #'buffer-name bufs)
|
||||
'("a/dir/" "b/dir/")))
|
||||
(mapc #'kill-buffer bufs)))))
|
||||
|
||||
(ert-deftest uniquify-rename-to-dir ()
|
||||
"Giving a buffer a name which matches a directory doesn't rename the buffer"
|
||||
(let ((uniquify-buffer-name-style 'forward)
|
||||
(uniquify-trailing-separator-p t))
|
||||
(save-excursion
|
||||
(find-file "../README")
|
||||
(rename-buffer "lisp" t)
|
||||
(should (equal (buffer-name) "lisp"))
|
||||
(kill-buffer))))
|
||||
|
||||
(ert-deftest uniquify-separator-style-reverse ()
|
||||
(let ((uniquify-buffer-name-style 'reverse)
|
||||
(uniquify-trailing-separator-p t))
|
||||
(save-excursion
|
||||
(should (file-directory-p "../lib-src"))
|
||||
(find-file "../lib-src")
|
||||
(should (equal (buffer-name) "\\lib-src"))
|
||||
(kill-buffer))))
|
||||
|
||||
(ert-deftest uniquify-separator-ignored ()
|
||||
"If uniquify-buffer-name-style isn't forward or reverse,
|
||||
uniquify-trailing-separator-p is ignored"
|
||||
(let ((uniquify-buffer-name-style 'post-forward-angle-brackets)
|
||||
(uniquify-trailing-separator-p t))
|
||||
(save-excursion
|
||||
(should (file-directory-p "../lib-src"))
|
||||
(find-file "../lib-src")
|
||||
(should (equal (buffer-name) "lib-src"))
|
||||
(kill-buffer))))
|
||||
|
||||
(ert-deftest uniquify-space-prefix ()
|
||||
"If a buffer starts with a space, | is added at the start"
|
||||
(save-excursion
|
||||
(find-file " foo")
|
||||
(should (equal (buffer-name) "| foo"))
|
||||
(kill-buffer)))
|
||||
|
||||
(provide 'uniquify-tests)
|
||||
;;; uniquify-tests.el ends here
|
||||
Loading…
Add table
Reference in a new issue