From 1722432f502c62866eeb2f1b69f95bc3fe016c77 Mon Sep 17 00:00:00 2001 From: Jim Porter Date: Sat, 6 Nov 2021 17:19:29 -0700 Subject: [PATCH 2/3] Support abbreviating home directory of Tramp filenames * lisp/files.el (abbreviate-file-name): Check for file name handler. (file-name-non-special): * lisp/net/tramp.el (tramp-file-name-for-operation): * lisp/net/tramp-sh.el (tramp-sh-file-name-handler-alist): Add 'abbreviate-file-name'. (tramp-sh-handle-abbreviate-file-name): New function. * test/lisp/net/tramp-tests.el (tramp-test46-abbreviate-file-name): New test. * doc/lispref/files.texi (Magic File Names): Mention 'abbreviate-file-name' in the list of magic file name handlers. * etc/NEWS: Announce the change. --- doc/lispref/files.texi | 7 +- etc/NEWS | 7 ++ lisp/files.el | 139 ++++++++++++++++++----------------- lisp/net/tramp-sh.el | 40 +++++++++- lisp/net/tramp.el | 2 + test/lisp/net/tramp-tests.el | 37 ++++++++-- 6 files changed, 155 insertions(+), 77 deletions(-) diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index ddc1d05c1c..9c50341b49 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -3295,8 +3295,8 @@ Magic File Names @ifnottex @noindent -@code{access-file}, @code{add-name-to-file}, -@code{byte-compiler-base-file-name},@* +@code{abbreviate-file-name}, @code{access-file}, +@code{add-name-to-file}, @code{byte-compiler-base-file-name},@* @code{copy-directory}, @code{copy-file}, @code{delete-directory}, @code{delete-file}, @code{diff-latest-backup-file}, @@ -3355,7 +3355,8 @@ Magic File Names @iftex @noindent @flushleft -@code{access-file}, @code{add-name-to-file}, +@code{abbreviate-file-name}, @code{access-file}, +@code{add-name-to-file}, @code{byte-com@discretionary{}{}{}piler-base-file-name}, @code{copy-directory}, @code{copy-file}, @code{delete-directory}, @code{delete-file}, diff --git a/etc/NEWS b/etc/NEWS index 78c848126a..07861ceee5 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -361,6 +361,13 @@ the buffer will take you to that directory. This is a convenience function to extract the field data from 'exif-parse-file' and 'exif-parse-buffer'. +** Tramp + ++++ +*** Tramp supports abbreviating remote home directories now. +When calling 'abbreviate-file-name' on a Tramp filename, the result +will abbreviate the home directory to "~". + * New Modes and Packages in Emacs 29.1 diff --git a/lisp/files.el b/lisp/files.el index 3af9730326..bb88b3c524 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -2013,73 +2013,75 @@ abbreviate-file-name started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)." ;; Get rid of the prefixes added by the automounter. (save-match-data ;FIXME: Why? - (if (and automount-dir-prefix - (string-match automount-dir-prefix filename) - (file-exists-p (file-name-directory - (substring filename (1- (match-end 0)))))) - (setq filename (substring filename (1- (match-end 0))))) - ;; Avoid treating /home/foo as /home/Foo during `~' substitution. - (let ((case-fold-search (file-name-case-insensitive-p filename))) - ;; If any elt of directory-abbrev-alist matches this name, - ;; abbreviate accordingly. - (dolist (dir-abbrev directory-abbrev-alist) - (if (string-match (car dir-abbrev) filename) - (setq filename - (concat (cdr dir-abbrev) - (substring filename (match-end 0)))))) - ;; Compute and save the abbreviated homedir name. - ;; We defer computing this until the first time it's needed, to - ;; give time for directory-abbrev-alist to be set properly. - ;; We include a slash at the end, to avoid spurious matches - ;; such as `/usr/foobar' when the home dir is `/usr/foo'. - (unless abbreviated-home-dir - (put 'abbreviated-home-dir 'home (expand-file-name "~")) - (setq abbreviated-home-dir - (let* ((abbreviated-home-dir "\\`\\'.") ;Impossible regexp. - (regexp - (concat "\\`" - (regexp-quote - (abbreviate-file-name - (get 'abbreviated-home-dir 'home))) - "\\(/\\|\\'\\)"))) - ;; Depending on whether default-directory does or - ;; doesn't include non-ASCII characters, the value - ;; of abbreviated-home-dir could be multibyte or - ;; unibyte. In the latter case, we need to decode - ;; it. Note that this function is called for the - ;; first time (from startup.el) when - ;; locale-coding-system is already set up. - (if (multibyte-string-p regexp) - regexp - (decode-coding-string regexp - (if (eq system-type 'windows-nt) - 'utf-8 - locale-coding-system)))))) - - ;; If FILENAME starts with the abbreviated homedir, - ;; and ~ hasn't changed since abbreviated-home-dir was set, - ;; make it start with `~' instead. - ;; If ~ has changed, we ignore abbreviated-home-dir rather than - ;; invalidating it, on the assumption that a change in HOME - ;; is likely temporary (eg for testing). - ;; FIXME Is it even worth caching abbreviated-home-dir? - ;; Ref: https://debbugs.gnu.org/19657#20 - (let (mb1) - (if (and (string-match abbreviated-home-dir filename) - (setq mb1 (match-beginning 1)) - ;; If the home dir is just /, don't change it. - (not (and (= (match-end 0) 1) - (= (aref filename 0) ?/))) - ;; MS-DOS root directories can come with a drive letter; - ;; Novell Netware allows drive letters beyond `Z:'. - (not (and (memq system-type '(ms-dos windows-nt cygwin)) - (string-match "\\`[a-zA-`]:/\\'" filename))) - (equal (get 'abbreviated-home-dir 'home) - (expand-file-name "~"))) - (setq filename - (concat "~" - (substring filename mb1)))) - filename)))) + (if-let* ((handler (find-file-name-handler filename 'abbreviate-file-name))) + (funcall handler 'abbreviate-file-name filename) + (if (and automount-dir-prefix + (string-match automount-dir-prefix filename) + (file-exists-p (file-name-directory + (substring filename (1- (match-end 0)))))) + (setq filename (substring filename (1- (match-end 0))))) + ;; Avoid treating /home/foo as /home/Foo during `~' substitution. + (let ((case-fold-search (file-name-case-insensitive-p filename))) + ;; If any elt of directory-abbrev-alist matches this name, + ;; abbreviate accordingly. + (dolist (dir-abbrev directory-abbrev-alist) + (if (string-match (car dir-abbrev) filename) + (setq filename + (concat (cdr dir-abbrev) + (substring filename (match-end 0)))))) + ;; Compute and save the abbreviated homedir name. + ;; We defer computing this until the first time it's needed, to + ;; give time for directory-abbrev-alist to be set properly. + ;; We include a slash at the end, to avoid spurious matches + ;; such as `/usr/foobar' when the home dir is `/usr/foo'. + (unless abbreviated-home-dir + (put 'abbreviated-home-dir 'home (expand-file-name "~")) + (setq abbreviated-home-dir + (let* ((abbreviated-home-dir "\\`\\'.") ;Impossible regexp. + (regexp + (concat "\\`" + (regexp-quote + (abbreviate-file-name + (get 'abbreviated-home-dir 'home))) + "\\(/\\|\\'\\)"))) + ;; Depending on whether default-directory does or + ;; doesn't include non-ASCII characters, the value + ;; of abbreviated-home-dir could be multibyte or + ;; unibyte. In the latter case, we need to decode + ;; it. Note that this function is called for the + ;; first time (from startup.el) when + ;; locale-coding-system is already set up. + (if (multibyte-string-p regexp) + regexp + (decode-coding-string regexp + (if (eq system-type 'windows-nt) + 'utf-8 + locale-coding-system)))))) + + ;; If FILENAME starts with the abbreviated homedir, + ;; and ~ hasn't changed since abbreviated-home-dir was set, + ;; make it start with `~' instead. + ;; If ~ has changed, we ignore abbreviated-home-dir rather than + ;; invalidating it, on the assumption that a change in HOME + ;; is likely temporary (eg for testing). + ;; FIXME Is it even worth caching abbreviated-home-dir? + ;; Ref: https://debbugs.gnu.org/19657#20 + (let (mb1) + (if (and (string-match abbreviated-home-dir filename) + (setq mb1 (match-beginning 1)) + ;; If the home dir is just /, don't change it. + (not (and (= (match-end 0) 1) + (= (aref filename 0) ?/))) + ;; MS-DOS root directories can come with a drive letter; + ;; Novell Netware allows drive letters beyond `Z:'. + (not (and (memq system-type '(ms-dos windows-nt cygwin)) + (string-match "\\`[a-zA-`]:/\\'" filename))) + (equal (get 'abbreviated-home-dir 'home) + (expand-file-name "~"))) + (setq filename + (concat "~" + (substring filename mb1)))) + filename))))) (defun find-buffer-visiting (filename &optional predicate) "Return the buffer visiting file FILENAME (a string). @@ -7811,10 +7813,11 @@ file-name-non-special ;; Get a list of the indices of the args that are file names. (file-arg-indices (cdr (or (assq operation - '(;; The first seven are special because they + '(;; The first eight are special because they ;; return a file name. We want to include ;; the /: in the return value. So just ;; avoid stripping it in the first place. + (abbreviate-file-name) (directory-file-name) (expand-file-name) (file-name-as-directory) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 6292190940..1151cd2ae8 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -940,7 +940,8 @@ tramp-vc-registered-read-file-names ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sh-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-sh-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-sh-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-sh-handle-copy-directory) @@ -1798,6 +1799,43 @@ tramp-sh-handle-file-name-all-completions (push (buffer-substring (point) (point-at-eol)) result))) result)))))) +(defun tramp-sh-handle-abbreviate-file-name (filename) + "Like `abbreviate-file-name' for Tramp files." + (let (home-dir) + (with-parsed-tramp-file-name filename nil + (setq home-dir (tramp-sh-handle-expand-file-name + (tramp-make-tramp-file-name v "~")))) + ;; If any elt of directory-abbrev-alist matches this name or the + ;; home dir, abbreviate accordingly. + (dolist (dir-abbrev directory-abbrev-alist) + (when (string-match (car dir-abbrev) filename) + (setq filename + (concat (cdr dir-abbrev) + (substring filename (match-end 0))))) + (when (string-match (car dir-abbrev) home-dir) + (setq home-dir + (concat (cdr dir-abbrev) + (substring home-dir (match-end 0)))))) + (let* ((home-dir-regexp + ;; We include a slash at the end, to avoid spurious + ;; matches such as `/usr/foobar' when the home dir is + ;; `/usr/foo'. + (concat "\\`" (regexp-quote home-dir) "\\(/\\|\\'\\)")) + (home-dir-regexp + ;; The value of home-dir-regexp could be multibyte or + ;; unibyte. In the latter case, we need to decode it. + (if (multibyte-string-p home-dir-regexp) + home-dir-regexp + (decode-coding-string home-dir-regexp + (if (eq system-type 'windows-nt) + 'utf-8 + locale-coding-system))))) + (if (string-match home-dir-regexp filename) + (with-parsed-tramp-file-name filename nil + (tramp-make-tramp-file-name + v (concat "~" (substring filename (match-beginning 1))))) + filename)))) + ;; cp, mv and ln (defun tramp-sh-handle-add-name-to-file diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index b152584c1f..740cb23ebe 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2493,6 +2493,8 @@ tramp-file-name-for-operation file-system-info ;; Emacs 28+ only. file-locked-p lock-file make-lock-file-name unlock-file + ;; Emacs 29+ only. + abbreviate-file-name ;; Tramp internal magic file name function. tramp-set-file-uid-gid)) (if (file-name-absolute-p (nth 0 args)) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 3d6ce963ee..5eea00c41e 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -6122,6 +6122,12 @@ tramp--test-emacs28-p variables, so we check the Emacs version directly." (>= emacs-major-version 28)) +(defun tramp--test-emacs29-p () + "Check for Emacs version >= 29.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 29)) + (defun tramp--test-adb-p () "Check, whether the remote host runs Android. This requires restrictions of file name syntax." @@ -7031,8 +7037,29 @@ tramp-test45-dired-compress-dir (should (string= tmp-name (dired-get-filename))) (delete-directory tmp-name))) +(ert-deftest tramp-test46-abbreviate-file-name () + "Check that Tramp abbreviates file names correctly." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-emacs29-p)) + + (let ((home-dir (expand-file-name "/mock:localhost:~"))) + ;; Check home-dir abbreviation. + (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) + "/mock:localhost:~/foo/bar")) + (should (equal (abbreviate-file-name "/mock:localhost:/nowhere/special") + "/mock:localhost:/nowhere/special")) + ;; Check `directory-abbrev-alist' abbreviation. + (let ((directory-abbrev-alist + `((,(concat "\\`" (regexp-quote home-dir) "/foo") + . ,(concat home-dir "/f")) + ("\\`/mock:localhost:/nowhere" . "/mock:localhost:/nw")))) + (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) + "/mock:localhost:~/f/bar")) + (should (equal (abbreviate-file-name "/mock:localhost:/nowhere/special") + "/mock:localhost:/nw/special"))))) + ;; This test is inspired by Bug#29163. -(ert-deftest tramp-test46-auto-load () +(ert-deftest tramp-test47-auto-load () "Check that Tramp autoloads properly." ;; If we use another syntax but `default', Tramp is already loaded ;; due to the `tramp-change-syntax' call. @@ -7057,7 +7084,7 @@ tramp-test46-auto-load (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test46-delay-load () +(ert-deftest tramp-test47-delay-load () "Check that Tramp is loaded lazily, only when needed." ;; The autoloaded Tramp objects are different since Emacs 26.1. We ;; cannot test older Emacsen, therefore. @@ -7090,7 +7117,7 @@ tramp-test46-delay-load (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument (format code tm))))))))) -(ert-deftest tramp-test46-recursive-load () +(ert-deftest tramp-test47-recursive-load () "Check that Tramp does not fail due to recursive load." (skip-unless (tramp--test-enabled)) @@ -7114,7 +7141,7 @@ tramp-test46-recursive-load (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code)))))))) -(ert-deftest tramp-test46-remote-load-path () +(ert-deftest tramp-test47-remote-load-path () "Check that Tramp autoloads its packages with remote `load-path'." ;; The autoloaded Tramp objects are different since Emacs 26.1. We ;; cannot test older Emacsen, therefore. @@ -7143,7 +7170,7 @@ tramp-test46-remote-load-path (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test47-unload () +(ert-deftest tramp-test48-unload () "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) -- 2.25.1