master bf505a6 1/2: Support abbreviating home directory of Tramp filenames

[Michael Albinus]

branch: master
commit bf505a63f98ed61934a8fb81ec65c96859606b6e
Author: Jim Porter <jporterbugs@gmail.com>
Commit: Michael Albinus <michael.albinus@gmx.de>

    Support abbreviating home directory of Tramp filenames
    
    * doc/lispref/files.texi (Magic File Names): Mention
    'abbreviate-file-name' in the list of magic file name handlers.
    
    * etc/NEWS: Announce the change.
    
    * 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'.
    
    * lisp/files.el (directory-abbrev-make-regexp):
    (directory-abbrev-apply): New functions.
    (abbreviate-file-name): Check for file name handler.
    
    * test/lisp/net/tramp-tests.el (tramp-test07-abbreviate-file-name):
    New test.
---
 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 d93770a..4b114ba 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -3308,8 +3308,8 @@ first, before handlers for jobs such as remote file 
access.
 
 @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 @@ first, before handlers for jobs such as remote file 
access.
 @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 312fc18..0a19dca 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 3490d04..49bf06b 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -68,6 +68,31 @@ a regexp matching the name it is linked to."
   :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 @@ if you want to permanently change your home directory 
after having
 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 @@ only these files will be asked to be saved."
        ;; 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 c61025a..b83569f 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -942,7 +942,8 @@ Format specifiers \"%s\" are replaced before the script is 
used.")
 ;; 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 0b25164..2411953 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -222,7 +222,8 @@ See `tramp-actions-before-shell' for more info.")
 ;; 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 7cf0ea4..c91bced 100644
--- a/lisp/net/tramp-sudoedit.el
+++ b/lisp/net/tramp-sudoedit.el
@@ -63,7 +63,8 @@ See `tramp-actions-before-shell' for more info.")
 
 ;;;###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 5fcf7f9..d314df7 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -2495,6 +2495,8 @@ Must be handled by the callers."
              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))
@@ -3282,6 +3284,23 @@ User is always nil."
 (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 52c6159..698d18b 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -2289,6 +2289,31 @@ This checks also `file-name-as-directory', 
`file-name-directory',
          (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))