7 files changed, 78 insertions, 50 deletions

diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi
index 9195bc47efe..fa1f9e53165 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{/:}.
+@xref{Quoted 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 f701d683703..06466c9bba8 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
 
-@deffn Command make-symbolic-link filename newname &optional ok-if-already-exists
+@deffn 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
-@var{filename} @var{newname}}.  The @var{filename} argument
+@var{target} @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 02de66b355f..d53e0d25f78 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 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'"
diff --git a/src/fileio.c b/src/fileio.c
index fa694249cb7..bbd1a4ef69c 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 2ef1b553ab4..5103d2f21e6 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 ()