From 8663a872a53f13948096a95ada92e3ac099eee5e Mon Sep 17 00:00:00 2001 From: Jim Porter Date: Sun, 14 Nov 2021 22:41:30 -0800 Subject: [PATCH 2/2] Support abbreviating home directory of Tramp filenames * lisp/files.el (directory-abbrev-make-regexp): (directory-abbrev-apply): New functions. (abbreviate-file-name): Check for file name handler. * lisp/tramp.el (tramp-sh-handle-abbreviate-file-name): New function. * lisp/files.el (file-name-non-special): * lisp/net/tramp.el (tramp-file-name-for-operation): * lisp/net/tramp-sh.el (tramp-sh-file-name-handler-alist): * lisp/net/tramp-smb.el (tramp-smb-file-name-handler-alist): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-file-name-handler-alist): Add 'abbreviate-file-name'. * test/lisp/net/tramp-tests.el (tramp-test07-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 | 11 +++ lisp/files.el | 143 ++++++++++++++++++----------------- lisp/net/tramp-sh.el | 3 +- lisp/net/tramp-smb.el | 3 +- lisp/net/tramp-sudoedit.el | 3 +- lisp/net/tramp.el | 19 +++++ test/lisp/net/tramp-tests.el | 25 ++++++ 8 files changed, 140 insertions(+), 74 deletions(-) diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index d93770a0d2..4b114ba111 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -3308,8 +3308,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}, @@ -3368,7 +3368,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 c362e56cee..1738910cbc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -497,6 +497,14 @@ The newly created buffer will be displayed via 'display-buffer', which can be customized through the usual mechanism of 'display-buffer-alist' and friends. +** Tramp + +--- +*** Tramp supports abbreviating remote home directories now. +When calling 'abbreviate-file-name' on a Tramp filename, the result +will abbreviate the user's home directory, for example by abbreviating +"/ssh:user@host:/home/user" to "/ssh:user@host:~". + * New Modes and Packages in Emacs 29.1 @@ -632,6 +640,9 @@ This convenience function is useful when writing code that parses files at run-time, and allows Lisp programs to re-parse files only when they have changed. ++++ +** 'abbreviate-file-name' now respects magic file name handlers. + --- ** New function 'font-has-char-p'. This can be used to check whether a specific font has a glyph for a diff --git a/lisp/files.el b/lisp/files.el index 3490d0428a..49bf06bfc1 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -68,6 +68,31 @@ directory-abbrev-alist :group 'abbrev :group 'find-file) +(defun directory-abbrev-make-regexp (directory) + "Create a regexp to match DIRECTORY for `directory-abbrev-alist'." + (let ((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 directory) "\\(/\\|\\'\\)"))) + ;; The value of regexp could be multibyte or unibyte. In the + ;; latter case, we need to decode it. + (if (multibyte-string-p regexp) + regexp + (decode-coding-string regexp + (if (eq system-type 'windows-nt) + 'utf-8 + locale-coding-system))))) + +(defun directory-abbrev-apply (filename) + "Apply the abbreviations in `directory-abbrev-alist' to FILENAME. +Note that when calling this, you should set `case-fold-search' as +appropriate for the filesystem used for FILENAME." + (dolist (dir-abbrev directory-abbrev-alist filename) + (when (string-match (car dir-abbrev) filename) + (setq filename (concat (cdr dir-abbrev) + (substring filename (match-end 0))))))) + (defcustom make-backup-files t "Non-nil means make a backup of a file the first time it is saved. This can be done by renaming the file or by copying. @@ -2015,73 +2040,54 @@ 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. + (setq filename (directory-abbrev-apply filename)) + + ;; 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. + (unless abbreviated-home-dir + (put 'abbreviated-home-dir 'home (expand-file-name "~")) + (setq abbreviated-home-dir + (directory-abbrev-make-regexp + (let ((abbreviated-home-dir "\\`\\'.")) ;Impossible regexp. + (abbreviate-file-name + (get 'abbreviated-home-dir 'home)))))) + + ;; 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). @@ -7836,10 +7842,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 c61025a86b..b83569f3de 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -942,7 +942,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-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) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 0b25164902..24119539db 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -222,7 +222,8 @@ tramp-smb-actions-set-acl ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-smb-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-smb-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-smb-handle-copy-directory) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 7cf0ea451d..c91bced656 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -63,7 +63,8 @@ tramp-sudoedit-sudo-actions ;;;###tramp-autoload (defconst tramp-sudoedit-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-sudoedit-handle-add-name-to-file) (byte-compiler-base-file-name . ignore) (copy-directory . tramp-handle-copy-directory) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 876bbb2c54..9d4fa485b5 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2495,6 +2495,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)) @@ -3275,6 +3277,23 @@ tramp-handle-file-local-copy-hook (defvar tramp-handle-write-region-hook nil "Normal hook to be run at the end of `tramp-*-handle-write-region'.") +(defun tramp-handle-abbreviate-file-name (filename) + "Like `abbreviate-file-name' for Tramp files." + (let* ((case-fold-search (file-name-case-insensitive-p filename)) + (home-dir + (with-parsed-tramp-file-name filename nil + (with-tramp-connection-property v "home-directory" + (directory-abbrev-apply (expand-file-name + (tramp-make-tramp-file-name v "~"))))))) + ;; If any elt of directory-abbrev-alist matches this name, + ;; abbreviate accordingly. + (setq filename (directory-abbrev-apply filename)) + (if (string-match (directory-abbrev-make-regexp home-dir) filename) + (with-parsed-tramp-file-name filename nil + (tramp-make-tramp-file-name + v (concat "~" (substring filename (match-beginning 1))))) + filename))) + (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." (setq filename (file-truename filename)) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 52c6159dc1..698d18b528 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2289,6 +2289,31 @@ tramp-test06-directory-file-name (should (string-equal (file-name-directory file) file)) (should (string-equal (file-name-nondirectory file) ""))))))) +(ert-deftest tramp-test07-abbreviate-file-name () + "Check that Tramp abbreviates file names correctly." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-emacs29-p)) + + (let* ((remote-host (file-remote-p tramp-test-temporary-file-directory)) + (home-dir (expand-file-name (concat remote-host "~")))) + ;; Check home-dir abbreviation. + (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) + (concat remote-host "~/foo/bar"))) + (should (equal (abbreviate-file-name (concat remote-host + "/nowhere/special")) + (concat remote-host "/nowhere/special"))) + ;; Check `directory-abbrev-alist' abbreviation. + (let ((directory-abbrev-alist + `((,(concat "\\`" (regexp-quote home-dir) "/foo") + . ,(concat home-dir "/f")) + (,(concat "\\`" (regexp-quote remote-host) "/nowhere") + . ,(concat remote-host "/nw"))))) + (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) + (concat remote-host "~/f/bar"))) + (should (equal (abbreviate-file-name (concat remote-host + "/nowhere/special")) + (concat remote-host "/nw/special")))))) + (ert-deftest tramp-test07-file-exists-p () "Check `file-exist-p', `write-region' and `delete-file'." (skip-unless (tramp--test-enabled)) -- 2.25.1