[Emacs-diffs] master e8001d4: Do not munge contents of local symbolic links

[Paul Eggert]

branch: master
commit e8001d4c27e1e33c83b9994aac4d5fc3feada2da
Author: Paul Eggert <address@hidden>
Commit: Paul Eggert <address@hidden>

    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.
---
 doc/emacs/files.texi     |  8 ++++++--
 doc/lispref/files.texi   | 11 +++++++----
 etc/NEWS                 | 24 ++++++++++++++++++++++++
 lisp/dired.el            |  5 +----
 lisp/files.el            | 31 +++++++++++++++++++++----------
 src/fileio.c             | 28 +++++++++-------------------
 test/src/fileio-tests.el | 21 ++++++++++-----------
 7 files changed, 78 insertions(+), 50 deletions(-)

diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi
index 9195bc4..fa1f9e5 100644
--- a/doc/emacs/files.texi
+++ b/doc/emacs/files.texi
@@ -1611,8 +1611,12 @@ attempts to open file @var{new} will refer to whatever 
file is named
 @var{target} at the time the opening is done, or will get an error if
 the name @var{target} is nonexistent at that time.  This command does
 not expand the argument @var{target}, so that it allows you to specify
-a relative name as the target of the link.  On MS-Windows, this
-command works only on MS Windows Vista and later.  On remote systems,
+a relative name as the target of the link.  However, this command
+does expand leading @samp{~} in @var{target} so that you can easily
+specify home directories, and strips leading @samp{/:} so that you can
+specify relative names beginning with literal @samp{~} or @samp{/:}.
address@hidden File Names}.  On MS-Windows, this command works only on
+MS Windows Vista and later.  When @var{new} is remote,
 it works depending on the system type.
 
 @node Misc File Ops
diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index f701d68..06466c9 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -1726,14 +1726,17 @@ default file permissions (see 
@code{set-default-file-modes} below), if
 SELinux context are not copied over in either case.
 @end deffn
 
address@hidden Command make-symbolic-link filename newname &optional 
ok-if-already-exists
address@hidden Command make-symbolic-link target newname &optional 
ok-if-already-exists
 @pindex ln
 @kindex file-already-exists
-This command makes a symbolic link to @var{filename}, named
+This command makes a symbolic link to @var{target}, named
 @var{newname}.  This is like the shell command @samp{ln -s
address@hidden @var{newname}}.  The @var{filename} argument
address@hidden @var{newname}}.  The @var{target} argument
 is treated only as a string; it need not name an existing file.
-If @var{filename} is a relative file name, the resulting symbolic link
+If @var{ok-if-already-exists} is an integer, indicating interactive
+use, then leading @samp{~} is expanded and leading @samp{/:} is
+stripped in the @var{target} string.
+If @var{target} is a relative file name, the resulting symbolic link
 is interpreted relative to the directory containing the symbolic link.
 @xref{Relative File Names}.
 
diff --git a/etc/NEWS b/etc/NEWS
index 02de66b..d53e0d2 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1228,6 +1228,30 @@ instead of to utf-8.  Before this change, Emacs would 
sometimes
 mishandle file names containing these control characters.
 
 +++
+** 'file-attributes', 'file-symlink-p' and 'make-symbolic-link' no
+longer quietly mutate the target of a local symbolic link, so that
+Emacs can access and copy them reliably regardless of their contents.
+The following changes are involved.
+
+*** 'file-attributes' and 'file-symlink-p' no longer prepend "/:" to
+symbolic links whose targets begin with "/" and contain ":".  For
+example, if a symbolic link "x" has a target "/y:z", (file-symlink-p
+"x") now returns "/y:z" rather than "/:/y:z".
+
+*** 'make-symbolic-link' no longer looks for file name handlers when
+creating a local symbolic link.  For example, (make-symbolic-link
+"/y:z" "x") now creates a symlink to "/y:z" instead of failing.
+
+*** 'make-symbolic-link' now expands a link target with leading "~"
+only when the optional third arg is an integer, as when invoked
+interactively.  For example, (make-symbolic-link "~y" "x") now creates
+a link with target the literal string "~y"; to get the old behavior,
+use (make-symbolic-link (expand-file-name "~y") "x").  To avoid this
+expansion in interactive use, you can now prefix the link target with
+"/:".  For example, (make-symbolic-link "/:~y" "x" 1) now creates a
+link to literal "~y".
+
++++
 ** Module functions are now implemented slightly differently; in
 particular, the function 'internal--module-call' has been removed.
 Code that depends on undocumented internals of the module system might
diff --git a/lisp/dired.el b/lisp/dired.el
index 0455f3d..ff62183 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 ca3b055..872fc46 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'"
diff --git a/src/fileio.c b/src/fileio.c
index fa69424..bbd1a4e 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -2413,7 +2413,8 @@ DEFUN ("make-symbolic-link", Fmake_symbolic_link, 
Smake_symbolic_link, 2, 3,
 Both args must be strings.
 Signal a `file-already-exists' error if a file LINKNAME already exists
 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
-An integer third arg means request confirmation if LINKNAME already exists.
+An integer third arg means request confirmation if LINKNAME already
+exists, and expand leading "~" or strip leading "/:" in TARGET.
 This happens for interactive use with M-x.  */)
   (Lisp_Object target, Lisp_Object linkname, Lisp_Object ok_if_already_exists)
 {
@@ -2421,21 +2422,15 @@ This happens for interactive use with M-x.  */)
   Lisp_Object encoded_target, encoded_linkname;
 
   CHECK_STRING (target);
-  /* If the link target has a ~, we must expand it to get
-     a truly valid file name.  Otherwise, do not expand;
-     we want to permit links to relative file names.  */
-  if (SREF (target, 0) == '~')
-    target = Fexpand_file_name (target, Qnil);
-
+  if (INTEGERP (ok_if_already_exists))
+    {
+      if (SREF (target, 0) == '~')
+       target = Fexpand_file_name (target, Qnil);
+      else if (SREF (target, 0) == '/' && SREF (target, 1) == ':')
+       target = Fsubstring_no_properties (target, make_number (2), Qnil);
+    }
   linkname = expand_cp_target (target, linkname);
 
-  /* If the file name has special constructs in it,
-     call the corresponding file handler.  */
-  handler = Ffind_file_name_handler (target, Qmake_symbolic_link);
-  if (!NILP (handler))
-    return call4 (handler, Qmake_symbolic_link, target,
-                 linkname, ok_if_already_exists);
-
   /* If the new link name has special constructs in it,
      call the corresponding file handler.  */
   handler = Ffind_file_name_handler (linkname, Qmake_symbolic_link);
@@ -2633,11 +2628,6 @@ emacs_readlinkat (int fd, char const *filename)
     return Qnil;
 
   val = build_unibyte_string (buf);
-  if (buf[0] == '/' && strchr (buf, ':'))
-    {
-      AUTO_STRING (slash_colon, "/:");
-      val = concat2 (slash_colon, val);
-    }
   if (buf != readlink_buf)
     xfree (buf);
   val = DECODE_FILE (val);
diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el
index 2ef1b55..5103d2f 100644
--- a/test/src/fileio-tests.el
+++ b/test/src/fileio-tests.el
@@ -19,14 +19,13 @@
 
 (require 'ert)
 
-(defun try-char (char link)
-  (let ((target (string char)))
-    (make-symbolic-link target link)
-    (let* ((read-link (file-symlink-p link))
-           (failure (unless (string-equal target read-link)
-                      (list 'string-equal target read-link))))
-      (delete-file link)
-      failure)))
+(defun try-link (target link)
+  (make-symbolic-link target link)
+  (let* ((read-link (file-symlink-p link))
+         (failure (unless (string-equal target read-link)
+                    (list 'string-equal target read-link))))
+    (delete-file link)
+    failure))
 
 (defun fileio-tests--symlink-failure ()
   (let* ((dir (make-temp-file "fileio" t))
@@ -36,9 +35,9 @@
               (char 0))
           (while (and (not failure) (< char 127))
             (setq char (1+ char))
-            (unless (= char ?~)
-              (setq failure (try-char char link))))
-          failure)
+            (setq failure (try-link (string char) link)))
+          (or failure
+              (try-link "/:" link)))
       (delete-directory dir t))))
 
 (ert-deftest fileio-tests--odd-symlink-chars ()