mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-23 07:19:15 +00:00
Avoid bogus abbreviated file names if HOME changes
* lisp/files.el (abbreviate-file-name): If HOME changes, ignore `abbreviated-home-dir'. (Bug#19657#20) * test/lisp/files-tests.el (files-test-abbreviated-home-dir): New.
This commit is contained in:
parent
8d450453fa
commit
92f0c4cd56
@ -1859,9 +1859,9 @@ home directory is a root directory) and removes automounter prefixes
|
|||||||
|
|
||||||
When this function is first called, it caches the user's home
|
When this function is first called, it caches the user's home
|
||||||
directory as a regexp in `abbreviated-home-dir', and reuses it
|
directory as a regexp in `abbreviated-home-dir', and reuses it
|
||||||
afterwards. Lisp programs that temporarily set the home directory
|
afterwards (so long as the home directory does not change;
|
||||||
to a different value should let-bind `abbreviated-home-dir' for
|
if you want to permanently change your home directory after having
|
||||||
the modified home directory to take effect."
|
started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)."
|
||||||
;; Get rid of the prefixes added by the automounter.
|
;; Get rid of the prefixes added by the automounter.
|
||||||
(save-match-data
|
(save-match-data
|
||||||
(if (and automount-dir-prefix
|
(if (and automount-dir-prefix
|
||||||
@ -1883,29 +1883,37 @@ the modified home directory to take effect."
|
|||||||
;; give time for directory-abbrev-alist to be set properly.
|
;; give time for directory-abbrev-alist to be set properly.
|
||||||
;; We include a slash at the end, to avoid spurious matches
|
;; We include a slash at the end, to avoid spurious matches
|
||||||
;; such as `/usr/foobar' when the home dir is `/usr/foo'.
|
;; such as `/usr/foobar' when the home dir is `/usr/foo'.
|
||||||
(or abbreviated-home-dir
|
(unless abbreviated-home-dir
|
||||||
(setq abbreviated-home-dir
|
(put 'abbreviated-home-dir 'home (expand-file-name "~"))
|
||||||
(let ((abbreviated-home-dir "$foo"))
|
(setq abbreviated-home-dir
|
||||||
(setq abbreviated-home-dir
|
(let ((abbreviated-home-dir "$foo"))
|
||||||
(concat "\\`"
|
(setq abbreviated-home-dir
|
||||||
(abbreviate-file-name (expand-file-name "~"))
|
(concat "\\`"
|
||||||
"\\(/\\|\\'\\)"))
|
(abbreviate-file-name
|
||||||
;; Depending on whether default-directory does or
|
(get 'abbreviated-home-dir 'home))
|
||||||
;; doesn't include non-ASCII characters, the value
|
"\\(/\\|\\'\\)"))
|
||||||
;; of abbreviated-home-dir could be multibyte or
|
;; Depending on whether default-directory does or
|
||||||
;; unibyte. In the latter case, we need to decode
|
;; doesn't include non-ASCII characters, the value
|
||||||
;; it. Note that this function is called for the
|
;; of abbreviated-home-dir could be multibyte or
|
||||||
;; first time (from startup.el) when
|
;; unibyte. In the latter case, we need to decode
|
||||||
;; locale-coding-system is already set up.
|
;; it. Note that this function is called for the
|
||||||
(if (multibyte-string-p abbreviated-home-dir)
|
;; first time (from startup.el) when
|
||||||
abbreviated-home-dir
|
;; locale-coding-system is already set up.
|
||||||
(decode-coding-string abbreviated-home-dir
|
(if (multibyte-string-p abbreviated-home-dir)
|
||||||
(if (eq system-type 'windows-nt)
|
abbreviated-home-dir
|
||||||
'utf-8
|
(decode-coding-string abbreviated-home-dir
|
||||||
locale-coding-system))))))
|
(if (eq system-type 'windows-nt)
|
||||||
|
'utf-8
|
||||||
|
locale-coding-system))))))
|
||||||
|
|
||||||
;; If FILENAME starts with the abbreviated homedir,
|
;; If FILENAME starts with the abbreviated homedir,
|
||||||
|
;; and ~ hasn't changed since abbreviated-home-dir was set,
|
||||||
;; make it start with `~' instead.
|
;; make it start with `~' instead.
|
||||||
|
;; If ~ has changed, we ignore abbreviated-home-dir rather than
|
||||||
|
;; invalidating it, on the assumption that a change in HOME
|
||||||
|
;; is likely temporary (eg for testing).
|
||||||
|
;; FIXME Is it even worth caching abbreviated-home-dir?
|
||||||
|
;; Ref: https://debbugs.gnu.org/19657#20
|
||||||
(if (and (string-match abbreviated-home-dir filename)
|
(if (and (string-match abbreviated-home-dir filename)
|
||||||
;; If the home dir is just /, don't change it.
|
;; If the home dir is just /, don't change it.
|
||||||
(not (and (= (match-end 0) 1)
|
(not (and (= (match-end 0) 1)
|
||||||
@ -1914,7 +1922,9 @@ the modified home directory to take effect."
|
|||||||
;; Novell Netware allows drive letters beyond `Z:'.
|
;; Novell Netware allows drive letters beyond `Z:'.
|
||||||
(not (and (memq system-type '(ms-dos windows-nt cygwin))
|
(not (and (memq system-type '(ms-dos windows-nt cygwin))
|
||||||
(save-match-data
|
(save-match-data
|
||||||
(string-match "^[a-zA-`]:/$" filename)))))
|
(string-match "^[a-zA-`]:/$" filename))))
|
||||||
|
(equal (get 'abbreviated-home-dir 'home)
|
||||||
|
(expand-file-name "~")))
|
||||||
(setq filename
|
(setq filename
|
||||||
(concat "~"
|
(concat "~"
|
||||||
(match-string 1 filename)
|
(match-string 1 filename)
|
||||||
|
@ -411,5 +411,19 @@ name (Bug#28412)."
|
|||||||
(should (file-directory-p (concat (file-name-as-directory dest2) "a")))
|
(should (file-directory-p (concat (file-name-as-directory dest2) "a")))
|
||||||
(delete-directory dir 'recursive)))
|
(delete-directory dir 'recursive)))
|
||||||
|
|
||||||
|
(ert-deftest files-test-abbreviated-home-dir ()
|
||||||
|
"Test that changing HOME does not confuse `abbreviate-file-name'.
|
||||||
|
See <https://debbugs.gnu.org/19657#20>."
|
||||||
|
(let* ((homedir temporary-file-directory)
|
||||||
|
(process-environment (cons (format "HOME=%s" homedir)
|
||||||
|
process-environment))
|
||||||
|
(abbreviated-home-dir nil)
|
||||||
|
(testfile (expand-file-name "foo" homedir))
|
||||||
|
(old (file-truename (abbreviate-file-name testfile)))
|
||||||
|
(process-environment (cons (format "HOME=%s"
|
||||||
|
(expand-file-name "bar" homedir))
|
||||||
|
process-environment)))
|
||||||
|
(should (equal old (file-truename (abbreviate-file-name testfile))))))
|
||||||
|
|
||||||
(provide 'files-tests)
|
(provide 'files-tests)
|
||||||
;;; files-tests.el ends here
|
;;; files-tests.el ends here
|
||||||
|
Loading…
Reference in New Issue
Block a user