bug#16984: dired-do-rename susceptible to .../~/... hijack

[npostavs@users.sourceforge.net]

[-- Attachment #1: Type: text/plain, Size: 927 bytes --]

Eli Zaretskii <eliz@gnu.org> writes:

>> From: npostavs@users.sourceforge.net
>> Cc: 16984@debbugs.gnu.org,  Eli Zaretskii <eliz@gnu.org>,  jidanni@jidanni.org
>> Date: Thu, 08 Dec 2016 09:39:35 -0500
>> 
>>     (defun minibuffer-maybe-quote-filename (filename)
>>       "Protect FILENAME from `substitute-in-file-name', as needed.
>>     Useful to give the user default values that won't be substituted."
>>       (let ((local (file-remote-p filename 'localname)))
>>         (if (and (not (string-prefix-p "/:" local))
>>                  (file-name-absolute-p filename)
>>                  (string-match-p "/~" local))
>>             (tramp-quote-name filename)
>>           (minibuffer--double-dollars filename))))
>
> Is the argument guaranteed to come from expand-file-name?  If not, it
> should also accept file names matching "\~" on MS platforms.

I think it does, but I'm not entirely sure.  Better safe than sorry?


[-- Attachment #2: patch --]
[-- Type: text/plain, Size: 5482 bytes --]

From 1fc91a2a9fe7f9f0118edc047080718d11659c3f Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Thu, 27 Oct 2016 22:17:11 -0400
Subject: [PATCH v5] Quote filenames containing '~' in prompts

When in a directory named '~', the default value given by
`read-file-name' should be quoted by prepending '/:', in order to
prevent it from being interpreted as referring to the $HOME
directory (Bug#16984).

* lisp/minibuffer.el (minibuffer-maybe-quote-filename): New function.
(completion--sifn-requote, read-file-name-default): Use it instead of
`minibuffer--double-dollars'.
* test/lisp/files-tests.el (files-test-read-file-in-~): Test it.
---
 lisp/minibuffer.el       | 25 ++++++++++++++++++-------
 test/lisp/files-tests.el | 23 +++++++++++++++++++++++
 2 files changed, 41 insertions(+), 7 deletions(-)

diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 175189c..576b804 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -2251,6 +2251,17 @@ minibuffer--double-dollars
   (replace-regexp-in-string "\\$" (lambda (dollar) (concat dollar dollar))
                             str))
 
+(defun minibuffer-maybe-quote-filename (filename)
+  "Protect FILENAME from `substitute-in-file-name', as needed.
+Useful to give the user default values that won't be substituted."
+  (if (and (not (file-name-quoted-p filename))
+           (file-name-absolute-p filename)
+           (string-match-p (if (memq system-type '(windows-nt ms-dos))
+                               "[/\\\\]~" "/~")
+                           (file-local-name filename)))
+      (file-name-quote filename)
+    (minibuffer--double-dollars filename)))
+
 (defun completion--make-envvar-table ()
   (mapcar (lambda (enventry)
             (substring enventry 0 (string-match-p "=" enventry)))
@@ -2420,7 +2431,7 @@ completion--sifn-requote
                                    (substitute-in-file-name
                                     (substring qstr 0 (1- qpos)))))
         (setq qpos (1- qpos)))
-      (cons qpos #'minibuffer--double-dollars))))
+      (cons qpos #'minibuffer-maybe-quote-filename))))
 
 (defalias 'completion--file-name-table
   (completion-table-with-quoting #'completion-file-name-table
@@ -2596,10 +2607,10 @@ read-file-name-default
   (let ((insdef (cond
                  ((and insert-default-directory (stringp dir))
                   (if initial
-                      (cons (minibuffer--double-dollars (concat dir initial))
-                            (length (minibuffer--double-dollars dir)))
-                    (minibuffer--double-dollars dir)))
-                 (initial (cons (minibuffer--double-dollars initial) 0)))))
+                      (cons (minibuffer-maybe-quote-filename (concat dir initial))
+                            (length (minibuffer-maybe-quote-filename dir)))
+                    (minibuffer-maybe-quote-filename dir)))
+                 (initial (cons (minibuffer-maybe-quote-filename initial) 0)))))
 
     (let ((completion-ignore-case read-file-name-completion-ignore-case)
           (minibuffer-completing-file-name t)
@@ -2693,7 +2704,7 @@ read-file-name-default
             ;; with what we will actually return.  As an exception,
             ;; if that's the same as the second item in
             ;; file-name-history, it's really a repeat (Bug#4657).
-            (let ((val1 (minibuffer--double-dollars val)))
+            (let ((val1 (minibuffer-maybe-quote-filename val)))
               (if history-delete-duplicates
                   (setcdr file-name-history
                           (delete val1 (cdr file-name-history))))
@@ -2703,7 +2714,7 @@ read-file-name-default
           (if add-to-history
               ;; Add the value to the history--but not if it matches
               ;; the last value already there.
-              (let ((val1 (minibuffer--double-dollars val)))
+              (let ((val1 (minibuffer-maybe-quote-filename val)))
                 (unless (and (consp file-name-history)
                              (equal (car file-name-history) val1))
                   (setq file-name-history
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index 80d5e5b..f4ccd5c 100644
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -220,5 +220,28 @@ files-test-bug-18141-file
     (should-not yes-or-no-p-prompts)
     (should (equal kill-emacs-args '(nil)))))
 
+(ert-deftest files-test-read-file-in-~ ()
+  "Test file prompting in directory named '~'.
+If we are in a directory named '~', the default value should not
+be $HOME."
+  (cl-letf (((symbol-function 'completing-read)
+             (lambda (_prompt _coll &optional _pred _req init _hist def _)
+               (or def init)))
+            (dir (make-temp-file "read-file-name-test" t)))
+    (unwind-protect
+        (let ((subdir (expand-file-name "./~/")))
+          (make-directory subdir t)
+          (with-temp-buffer
+            (setq default-directory subdir)
+            (should-not (equal
+                         (expand-file-name (read-file-name "File: "))
+                         (expand-file-name "~/")))
+            ;; Don't overquote either!
+            (setq default-directory (concat "/:" subdir))
+            (should-not (equal
+                         (expand-file-name (read-file-name "File: "))
+                         (concat "/:/:" subdir)))))
+      (delete-directory dir 'recursive))))
+
 (provide 'files-tests)
 ;;; files-tests.el ends here
-- 
2.9.3