From e8001d4c27e1e33c83b9994aac4d5fc3feada2da Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sat, 26 Aug 2017 18:36:38 -0700 Subject: [PATCH] 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 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 @@ -1227,6 +1227,30 @@ that does not process CRLF. For example, it defaults to utf-8-unix 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. 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 () -- 2.39.2