Do not munge contents of local symbolic links

This lets Emacs deal with arbitrary local symlinks without
mishandling their contents (Bug#28156).  For example,
(progn (shell-command "ln -fs '~' 'x'") (rename-file "x" "/tmp/x"))
now consistently creates a symbolic link from '/tmp/x' to '~'.
Formerly, it did that only if the working directory was on the
same filesystem as /tmp; otherwise, it expanded the '~' to
the user's home directory.
* lisp/dired.el (dired-get-filename): Use files--name-absolute-system-p
instead of rolling our own code.
* lisp/files.el (files--name-absolute-system-p): New function.
(file-truename, file-chase-links): Use it to avoid mishandling
symlink contents that begin with ~.
(copy-directory, move-file-to-trash):
Use concat rather than expand-file-name, to avoid mishandling
symlink contents that begin with ~.
* src/fileio.c (Fmake_symbolic_link): Do not expand leading "~" in the
target unless interactive.  Strip leading "/:" if interactive.
(emacs_readlinkat): Do not prepend "/:" to the link target if
it starts with "/" and contains ":" before NUL.
* test/src/fileio-tests.el (try-link): Rename from try-char,
and accept a string instead of a char.  All uses changed.
(fileio-tests--symlink-failure): Also test leading ~, and "/:",
to test the new behavior.

2 files changed, 22 insertions, 14 deletions

diff --git a/lisp/dired.el b/lisp/dired.el
index 0455f3d1378..ff62183f091 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -2332,10 +2332,7 @@ Otherwise, an error occurs in these cases."
           (if (and enable-multibyte-characters
                    (not (multibyte-string-p file)))
               (setq file (string-to-multibyte file)))))
-    (and file (file-name-absolute-p file)
-         ;; A relative file name can start with ~.
-         ;; Don't treat it as absolute in this context.
-         (not (eq (aref file 0) ?~))
+    (and file (files--name-absolute-system-p file)
          (setq already-absolute t))
     (cond
      ((null file)
diff --git a/lisp/files.el b/lisp/files.el
index ca3b055d7a6..872fc46e87a 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -1146,6 +1146,13 @@ accessible."
         (funcall handler 'file-local-copy file)
       nil)))
 
+(defun files--name-absolute-system-p (file)
+  "Return non-nil if FILE is an absolute name to the operating system.
+This is like `file-name-absolute-p', except that it returns nil for
+names beginning with `~'."
+  (and (file-name-absolute-p file)
+       (not (eq (aref file 0) ?~))))
+
 (defun file-truename (filename &optional counter prev-dirs)
   "Return the truename of FILENAME.
 If FILENAME is not absolute, first expands it against `default-directory'.
@@ -1247,9 +1254,9 @@ containing it, until no links are left at any level.
                     ;; since target might look like foo/../bar where foo
                     ;; is itself a link.  Instead, we handle . and .. above.
                     (setq filename
-                          (if (file-name-absolute-p target)
-                              target
-                            (concat dir target))
+                          (concat (if (files--name-absolute-system-p target)
+                                      "/:" dir)
+                                  target)
                           done nil)
                   ;; No, we are done!
                   (setq done t))))))))
@@ -1284,7 +1291,10 @@ it means chase no more than that many links and then stop."
                  (directory-file-name (file-name-directory newname))))
           ;; Now find the parent of that dir.
           (setq newname (file-name-directory newname)))
-        (setq newname (expand-file-name tem (file-name-directory newname)))
+        (setq newname (concat (if (files--name-absolute-system-p tem)
+                                  "/:"
+                                (file-name-directory newname))
+                              tem))
         (setq count (1+ count))))
     newname))
 
@@ -5504,10 +5514,10 @@ directly into NEWNAME instead."
             ;; If NEWNAME is an existing directory and COPY-CONTENTS
             ;; is nil, copy into NEWNAME/[DIRECTORY-BASENAME].
             ((not copy-contents)
-             (setq newname (expand-file-name
+             (setq newname (concat
+                            (file-name-as-directory newname)
                             (file-name-nondirectory
-                             (directory-file-name directory))
-                            newname))
+                             (directory-file-name directory))))
              (and (file-exists-p newname)
                   (not (file-directory-p newname))
                   (error "Cannot overwrite non-directory %s with a directory"
@@ -5519,7 +5529,8 @@ directly into NEWNAME instead."
                ;; We do not want to copy "." and "..".
                (directory-files directory 'full
                                 directory-files-no-dot-files-regexp))
-        (let ((target (expand-file-name (file-name-nondirectory file) newname))
+        (let ((target (concat (file-name-as-directory newname)
+                              (file-name-nondirectory file)))
               (filetype (car (file-attributes file))))
           (cond
            ((eq filetype t)       ; Directory but not a symlink.
@@ -7149,8 +7160,8 @@ Otherwise, trash FILENAME using the freedesktop.org conventions,
          ;; If `trash-directory' is non-nil, move the file there.
          (let* ((trash-dir   (expand-file-name trash-directory))
                 (fn          (directory-file-name (expand-file-name filename)))
-                (new-fn      (expand-file-name (file-name-nondirectory fn)
-                                               trash-dir)))
+                (new-fn      (concat (file-name-as-directory trash-dir)
+                                     (file-name-nondirectory fn))))
            ;; We can't trash a parent directory of trash-directory.
            (if (string-prefix-p fn trash-dir)
                (error "Trash directory `%s' is a subdirectory of `%s'"