mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-27 07:37:33 +00:00
Code Issues Releases Activity

Make ange-ftp fit for tramp-tests

Browse Source 
* lisp/net/ange-ftp.el (ange-ftp-repaint-minibuffer): Use empty message.
(ange-ftp-quote-string): Unquote the string.
(ange-ftp-substitute-in-file-name, ange-ftp-access-file)
(ange-ftp-copy-directory, ange-ftp-make-symbolic-link)
(ange-ftp-add-name-to-file): New defuns.  Set 'ange-ftp property.
(ange-ftp-real-substitute-in-file-name)
(ange-ftp-real-copy-directory): New defuns.
(ange-ftp-file-name-as-directory): Care about `non-essential'.
(ange-ftp-file-attributes): Handle ID-STRING.
(ange-ftp-copy-file-internal, ange-ftp-rename-file)
(ange-ftp-make-directory): Improve error handling.
(ange-ftp-insert-directory): Initialize SWITCHES if they are nil.

* test/lisp/net/tramp-tests.el (ange-ftp-make-backup-files): Declare.
(tramp-test39-make-nearby-temp-file, tramp--test-ange-ftp-p): New defun.
(tramp-test05-expand-file-name-relative)
(tramp-test06-directory-file-name, tramp-test10-write-region)
(tramp-test11-copy-file, tramp-test12-rename-file)
(tramp-test17-insert-directory)
(tramp-test26-file-name-completion)
(tramp-test37-make-auto-save-file-name)
(tramp-test38-find-backup-file-name)
(tramp--test-special-characters): Use it.
This commit is contained in:
Michael Albinus 2019-11-07 12:03:19 +01:00
parent ddb797cf4c
commit 4ab7800126
2 changed files with 241 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
lisp/net/ange-ftp.el
View File

@ -1463,7 +1463,7 @@ only return the directory part of FILE."
(defun ange-ftp-repaint-minibuffer ()
"Clear any existing minibuffer message; let the minibuffer contents show."
(message nil))
(message ""))
;; Return the name of the buffer that collects output from the ftp process
;; connected to the given HOST and USER pair.
@ -1512,8 +1512,10 @@ then kill the related FTP process."
;; and that by doubling it. But experiment says UNIX-style kind of
;; quoting is correct when talking to ftp on GNU/Linux systems, and
;; W32-style kind of quoting on, yes, W32 systems.
;; STRING could be a quoted file name, we unquote it. It is
;; unlikely, that other strings but file names look alike.
(if (stringp string)
(shell-quote-argument string)
(shell-quote-argument (file-name-unquote string))
""))
(defun ange-ftp-barf-if-not-directory (directory)
@ -3144,6 +3146,12 @@ logged in as user USER and cd'd to directory DIR."
(ange-ftp-real-expand-file-name name "/"))
((ange-ftp-canonize-filename
(concat (file-name-as-directory default) name))))))
(defun ange-ftp-substitute-in-file-name (filename)
"Documented as `substitute-in-file-name'."
(if (file-name-quoted-p filename)
filename
(ange-ftp-real-substitute-in-file-name filename)))
;;; These are problems--they are currently not enabled.
@ -3156,7 +3164,7 @@ system TYPE.")
"Documented as `file-name-as-directory'."
(let ((parsed (ange-ftp-ftp-name name)))
(if parsed
(if (string-equal (nth 2 parsed) "")
(if (and non-essential (string-equal (nth 2 parsed) ""))
name
(funcall (or (cdr (assq
(ange-ftp-host-type (car parsed))
@ -3392,6 +3400,11 @@ system TYPE.")
t)))
(ange-ftp-real-file-exists-p name)))
(defun ange-ftp-access-file (filename string)
(unless (file-readable-p (file-truename filename))
(signal
'file-missing (list "%s: No such file or directory %s" string filename))))
(defun ange-ftp-file-directory-p (name)
(setq name (expand-file-name name))
(if (ange-ftp-ftp-name name)
@ -3465,8 +3478,10 @@ system TYPE.")
(file-name-directory file))
dirp) ;0 file type
-1 ;1 link count
-1 ;2 uid
-1 ;3 gid
(if (eq id-format 'string)
"nobody" -1) ;2 uid
(if (eq id-format 'string)
"nobody" -1) ;3 gid
'(0 0) ;4 atime
(ange-ftp-file-modtime file) ;5 mtime
'(0 0) ;6 ctime
@ -3613,6 +3628,16 @@ so return the size on the remote host exactly. See RFC 3659."
absname querystring)))
(signal 'file-already-exists (list absname))))))
(defun ange-ftp-copy-directory
(directory newname &optional keep-date parents copy-contents)
;; `copy-directory' creates `newname' before running this check. So
;; we do it ourselves.
(unless (file-exists-p directory)
(signal 'file-missing (list "No such file or directory" directory)))
;; We must do it file-wise.
(ange-ftp-real-copy-directory
directory newname keep-date parents copy-contents))
;; async local copy commented out for now since I don't seem to get
;; the process sentinel called for some processes.
;;
@ -3662,6 +3687,12 @@ so return the size on the remote host exactly. See RFC 3659."
(signal 'file-missing
(list "Copy file" "No such file or directory" filename)))
(and (not ok-if-already-exists) (file-exists-p newname)
(signal 'file-already-exists (list newname)))
(and (file-directory-p newname) (not (directory-name-p newname))
(signal 'file-error (list "File is a directory %s" newname)))
;; canonicalize newname if a directory.
(if (file-directory-p newname)
(setq newname (expand-file-name (file-name-nondirectory filename) newname)))
@ -3929,6 +3960,11 @@ E.g.,
(defun ange-ftp-rename-file (filename newname &optional ok-if-already-exists)
(interactive "fRename file: \nFRename %s to file: \np")
(or (file-exists-p filename)
(signal 'file-missing
(list "Copy file" "No such file or directory" filename)))
(setq filename (expand-file-name filename))
(setq newname (expand-file-name newname))
(let* ((f-parsed (ange-ftp-ftp-name filename))
@ -4093,7 +4129,9 @@ directory, so that Emacs will know its current contents."
(ange-ftp-make-directory parent parents))))
(if (file-exists-p dir)
(unless parents
(error "Cannot make directory %s: file already exists" dir))
(signal
'file-already-exists
(list "Cannot make directory: file already exists" dir)))
(let ((parsed (ange-ftp-ftp-name dir)))
(if parsed
(let* ((host (nth 0 parsed))
@ -4206,7 +4244,7 @@ directory, so that Emacs will know its current contents."
(while (and tryfiles (not copy))
(catch 'ftp-error
(let ((ange-ftp-waiting-flag t))
(condition-case _error
(condition-case nil
(setq copy (ange-ftp-file-local-copy (car tryfiles)))
(ftp-error nil))))
(setq tryfiles (cdr tryfiles)))
@ -4389,6 +4427,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(put 'file-name-as-directory 'ange-ftp 'ange-ftp-file-name-as-directory)
(put 'directory-file-name 'ange-ftp 'ange-ftp-directory-file-name)
(put 'expand-file-name 'ange-ftp 'ange-ftp-expand-file-name)
(put 'substitute-in-file-name 'ange-ftp 'ange-ftp-substitute-in-file-name)
(put 'make-directory 'ange-ftp 'ange-ftp-make-directory)
(put 'delete-directory 'ange-ftp 'ange-ftp-delete-directory)
(put 'insert-file-contents 'ange-ftp 'ange-ftp-insert-file-contents)
@ -4403,11 +4442,13 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p)
(put 'file-symlink-p 'ange-ftp 'ange-ftp-file-symlink-p)
(put 'file-regular-p 'ange-ftp 'ange-ftp-file-regular-p)
(put 'access-file 'ange-ftp 'ange-ftp-access-file)
(put 'delete-file 'ange-ftp 'ange-ftp-delete-file)
(put 'verify-visited-file-modtime 'ange-ftp
'ange-ftp-verify-visited-file-modtime)
(put 'file-exists-p 'ange-ftp 'ange-ftp-file-exists-p)
(put 'write-region 'ange-ftp 'ange-ftp-write-region)
(put 'copy-directory 'ange-ftp 'ange-ftp-copy-directory)
(put 'copy-file 'ange-ftp 'ange-ftp-copy-file)
(put 'rename-file 'ange-ftp 'ange-ftp-rename-file)
(put 'file-attributes 'ange-ftp 'ange-ftp-file-attributes)
@ -4425,6 +4466,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(put 'load 'ange-ftp 'ange-ftp-load)
(put 'find-backup-file-name 'ange-ftp 'ange-ftp-find-backup-file-name)
(put 'set-file-modes 'ange-ftp 'ange-ftp-set-file-modes)
(put 'make-symbolic-link 'ange-ftp 'ange-ftp-make-symbolic-link)
(put 'add-name-to-file 'ange-ftp 'ange-ftp-add-name-to-file)
;; Turn off truename processing to save time.
;; Treat each name as its own truename.
@ -4439,7 +4482,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
;; This returns nil for any file name as argument.
(put 'vc-registered 'ange-ftp 'null)
;; We can handle process-file in a restricted way (just for chown).
;; We can handle `process-file' in a restricted way (just for chown).
;; Nothing possible for `start-file-process'.
(put 'exec-path 'ange-ftp 'ignore)
(put 'make-process 'ange-ftp 'ignore)
@ -4473,6 +4516,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(ange-ftp-run-real-handler 'directory-file-name args))
(defun ange-ftp-real-expand-file-name (&rest args)
(ange-ftp-run-real-handler 'expand-file-name args))
(defun ange-ftp-real-substitute-in-file-name (&rest args)
(ange-ftp-run-real-handler 'substitute-in-file-name args))
(defun ange-ftp-real-make-directory (&rest args)
(ange-ftp-run-real-handler 'make-directory args))
(defun ange-ftp-real-delete-directory (&rest args)
@ -4507,6 +4552,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(ange-ftp-run-real-handler 'write-region args))
(defun ange-ftp-real-backup-buffer (&rest args)
(ange-ftp-run-real-handler 'backup-buffer args))
(defun ange-ftp-real-copy-directory (&rest args)
(ange-ftp-run-real-handler 'copy-directory args))
(defun ange-ftp-real-copy-file (&rest args)
(ange-ftp-run-real-handler 'copy-file args))
(defun ange-ftp-real-rename-file (&rest args)
@ -4552,6 +4599,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
;; because some FTP servers react to "ls foo" by listing the symlink foo
;; rather than the directory it points to. Now that ange-ftp-ls uses
;; "cd foo; ls" instead, this is not necessary any more.
;; SWITCHES cannot be nil or the empty string.
(unless switches (setq switches "--"))
(let ((beg (point))
(end (point-marker)))
(set-marker-insertion-type end t)
@ -4693,6 +4742,33 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(defun ange-ftp-set-file-modes (filename mode)
(ange-ftp-call-chmod (list (format "%o" mode) filename)))
(defun ange-ftp-make-symbolic-link (&rest _arguments)
(signal 'file-error (list "make-symbolic-link not supported")))
(defun ange-ftp-add-name-to-file
(filename newname &optional ok-if-already-exists)
(let ((f-parsed (ange-ftp-ftp-name filename))
(n-parsed (ange-ftp-ftp-name newname)))
(unless (and (string-equal (nth 0 f-parsed) (nth 0 n-parsed))
(string-equal (nth 1 f-parsed) (nth 1 n-parsed)))
(signal
'file-error
(list "add-name-to-file: only implemented for same user, same host")))
;; Do the 'confirm if exists' thing.
(when (file-exists-p newname)
;; What to do?
(if (or (null ok-if-already-exists) ; not allowed to exist
(and (numberp ok-if-already-exists)
(not (yes-or-no-p
(format
"File %s already exists; make it a link anyway? "
(nth 2 n-parsed))))))
(signal 'file-already-exists (list newname))
(delete-file newname)))
(copy-file
filename newname 'ok-if-already-exists 'keep-time
'preserve-uid-gid 'preserve-permissions)))
;; This is turned off because it has nothing properly to do
;; with dired. It could be reasonable to adapt this to

281
test/lisp/net/tramp-tests.el
View File

@ -57,6 +57,7 @@
(declare-function tramp-method-out-of-band-p "tramp-sh")
(declare-function tramp-smb-get-localname "tramp-smb")
(declare-function tramp-time-diff "tramp")
(defvar ange-ftp-make-backup-files)
(defvar auto-save-file-name-transforms)
(defvar tramp-connection-properties)
(defvar tramp-copy-size-limit)
@ -264,7 +265,7 @@ properly. BODY shall not contain a timeout."
;; No newline or linefeed.
(should-not (tramp-tramp-file-p "/method::file\nname"))
(should-not (tramp-tramp-file-p "/method::file\rname"))
;; Ange-ftp syntax.
;; Ange-FTP syntax.
(should-not (tramp-tramp-file-p "/host:"))
(should-not (tramp-tramp-file-p "/user@host:"))
(should-not (tramp-tramp-file-p "/1.2.3.4:"))
@ -398,7 +399,7 @@ properly. BODY shall not contain a timeout."
;; No strings.
(should-not (tramp-tramp-file-p nil))
(should-not (tramp-tramp-file-p 'symbol))
;; Ange-ftp syntax.
;; Ange-FTP syntax.
(should-not (tramp-tramp-file-p "/host:"))
(should-not (tramp-tramp-file-p "/user@host:"))
(should-not (tramp-tramp-file-p "/1.2.3.4:"))
@ -2065,7 +2066,8 @@ properly. BODY shall not contain a timeout."
(skip-unless (tramp--test-enabled))
;; These are the methods the test doesn't fail.
(when (or (tramp--test-adb-p) (tramp--test-gvfs-p) (tramp--test-rclone-p)
(when (or (tramp--test-adb-p) (tramp--test-ange-ftp-p) (tramp--test-gvfs-p)
(tramp--test-rclone-p)
(tramp-smb-file-name-p tramp-test-temporary-file-directory))
(setf (ert-test-expected-result-type
(ert-get-test 'tramp-test05-expand-file-name-relative))
@ -2150,7 +2152,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(string-equal
(file-name-as-directory file)
(if (tramp-completion-mode-p)
file (concat file "./"))))
file (concat file (if (tramp--test-ange-ftp-p) "/" "./")))))
(should (string-equal (file-name-directory file) file))
(should (string-equal (file-name-nondirectory file) "")))))))
@ -2255,18 +2257,19 @@ This checks also `file-name-as-directory', `file-name-directory',
(should (string-equal (buffer-string) "foo")))
;; Append.
(with-temp-buffer
(insert "bla")
(write-region nil nil tmp-name 'append))
(with-temp-buffer
(insert-file-contents tmp-name)
(should (string-equal (buffer-string) "foobla")))
(with-temp-buffer
(insert "baz")
(write-region nil nil tmp-name 3))
(with-temp-buffer
(insert-file-contents tmp-name)
(should (string-equal (buffer-string) "foobaz")))
(unless (tramp--test-ange-ftp-p)
(with-temp-buffer
(insert "bla")
(write-region nil nil tmp-name 'append))
(with-temp-buffer
(insert-file-contents tmp-name)
(should (string-equal (buffer-string) "foobla")))
(with-temp-buffer
(insert "baz")
(write-region nil nil tmp-name 3))
(with-temp-buffer
(insert-file-contents tmp-name)
(should (string-equal (buffer-string) "foobaz"))))
;; Write string.
(write-region "foo" nil tmp-name)
@ -2286,7 +2289,8 @@ This checks also `file-name-as-directory', `file-name-directory',
;; Macro `ert-with-message-capture' was introduced in Emacs 26.1.
(with-no-warnings (when (symbol-plist 'ert-with-message-capture)
(let ((tramp-message-show-message t))
(dolist (noninteractive '(nil t))
(dolist
(noninteractive (unless (tramp--test-ange-ftp-p) '(nil t)))
(dolist (visit '(nil t "string" no-message))
(ert-with-message-capture tramp--test-messages
(write-region "foo" nil tmp-name nil visit)
@ -2300,12 +2304,16 @@ This checks also `file-name-as-directory', `file-name-directory',
tramp--test-messages))))))))
;; Do not overwrite if excluded.
(cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t)))
(cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t))
;; Ange-FTP.
((symbol-function 'yes-or-no-p) (lambda (_prompt) t)))
(write-region "foo" nil tmp-name nil nil nil 'mustbenew))
;; `mustbenew' is passed to Tramp since Emacs 26.1.
(when (tramp--test-emacs26-p)
(should-error
(cl-letf (((symbol-function 'y-or-n-p) 'ignore))
(cl-letf (((symbol-function 'y-or-n-p) 'ignore)
;; Ange-FTP.
((symbol-function 'yes-or-no-p) 'ignore))
(write-region "foo" nil tmp-name nil nil nil 'mustbenew))
:type 'file-already-exists)
(should-error
@ -2394,7 +2402,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(unwind-protect
;; FIXME: This fails on my QNAP server, see
;; /share/Web/owncloud/data/owncloud.log
(unless (tramp--test-nextcloud-p)
(unless (or (tramp--test-ange-ftp-p) (tramp--test-nextcloud-p))
(write-region "foo" nil source)
(should (file-exists-p source))
(make-directory target)
@ -2420,7 +2428,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(unwind-protect
;; FIXME: This fails on my QNAP server, see
;; /share/Web/owncloud/data/owncloud.log
(unless (tramp--test-nextcloud-p)
(unless (or (tramp--test-ange-ftp-p) (tramp--test-nextcloud-p))
(make-directory source)
(should (file-directory-p source))
(write-region "foo" nil (expand-file-name "foo" source))
@ -2443,7 +2451,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(unwind-protect
;; FIXME: This fails on my QNAP server, see
;; /share/Web/owncloud/data/owncloud.log
(unless (tramp--test-nextcloud-p)
(unless (or (tramp--test-ange-ftp-p) (tramp--test-nextcloud-p))
(make-directory source)
(should (file-directory-p source))
(write-region "foo" nil (expand-file-name "foo" source))
@ -2538,7 +2546,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(unwind-protect
;; FIXME: This fails on my QNAP server, see
;; /share/Web/owncloud/data/owncloud.log
(unless (tramp--test-nextcloud-p)
(unless (or (tramp--test-ange-ftp-p) (tramp--test-nextcloud-p))
(make-directory source)
(should (file-directory-p source))
(write-region "foo" nil (expand-file-name "foo" source))
@ -2562,7 +2570,7 @@ This checks also `file-name-as-directory', `file-name-directory',
(unwind-protect
;; FIXME: This fails on my QNAP server, see
;; /share/Web/owncloud/data/owncloud.log
(unless (tramp--test-nextcloud-p)
(unless (or (tramp--test-ange-ftp-p) (tramp--test-nextcloud-p))
(make-directory source)
(should (file-directory-p source))
(write-region "foo" nil (expand-file-name "foo" source))
@ -2810,6 +2818,10 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(ert-deftest tramp-test17-insert-directory ()
"Check `insert-directory'."
(skip-unless (tramp--test-enabled))
;; Ange-FTP is very special. It does not include the header line
;; (this is performed by `dired'). If FULL is nil, it shows just
;; one file. So we refrain from testing.
(skip-unless (not (tramp--test-ange-ftp-p)))
(dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((tmp-name1
@ -3928,9 +3940,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should (equal (file-name-completion "foo" tmp-name) t))
(should (equal (file-name-completion "b" tmp-name) "bo"))
(should-not (file-name-completion "a" tmp-name))
(should
(equal
(file-name-completion "b" tmp-name #'file-directory-p) "boz/"))
;; Ange-FTP does not support predicates.
(unless (tramp--test-ange-ftp-p)
(should
(equal
(file-name-completion "b" tmp-name #'file-directory-p)
"boz/")))
(should
(equal (file-name-all-completions "fo" tmp-name) '("foo")))
(should
@ -3940,14 +3955,17 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should-not (file-name-all-completions "a" tmp-name))
;; `completion-regexp-list' restricts the completion to
;; files which match all expressions in this list.
(let ((completion-regexp-list
`(,directory-files-no-dot-files-regexp "b")))
(should
(equal (file-name-completion "" tmp-name) "bo"))
(should
(equal
(sort (file-name-all-completions "" tmp-name) #'string-lessp)
'("bold" "boz/"))))
;; Ange-FTP does not complete "".
(unless (tramp--test-ange-ftp-p)
(let ((completion-regexp-list
`(,directory-files-no-dot-files-regexp "b")))
(should
(equal (file-name-completion "" tmp-name) "bo"))
(should
(equal
(sort
(file-name-all-completions "" tmp-name) #'string-lessp)
'("bold" "boz/")))))
;; `file-name-completion' ignores file names that end in
;; any string in `completion-ignored-extensions'.
(let ((completion-ignored-extensions '(".ext")))
@ -4881,49 +4899,52 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
tramp-test-temporary-file-directory))))))
;; Use default `tramp-auto-save-directory' mechanism.
(let ((tramp-auto-save-directory tmp-name2))
(with-temp-buffer
(setq buffer-file-name tmp-name1)
(should
(string-equal
(make-auto-save-file-name)
;; This is taken from Tramp.
(expand-file-name
(format
"#%s#"
(tramp-subst-strs-in-string
'(("_" . "|")
("/" . "_a")
(":" . "_b")
("|" . "__")
("[" . "_l")
("]" . "_r"))
(tramp-compat-file-name-unquote tmp-name1)))
tmp-name2)))
(should (file-directory-p tmp-name2))))
;; Ange-FTP doesn't care.
(unless (tramp--test-ange-ftp-p)
(let ((tramp-auto-save-directory tmp-name2))
(with-temp-buffer
(setq buffer-file-name tmp-name1)
(should
(string-equal
(make-auto-save-file-name)
;; This is taken from Tramp.
(expand-file-name
(format
"#%s#"
(tramp-subst-strs-in-string
'(("_" . "|")
("/" . "_a")
(":" . "_b")
("|" . "__")
("[" . "_l")
("]" . "_r"))
(tramp-compat-file-name-unquote tmp-name1)))
tmp-name2)))
(should (file-directory-p tmp-name2)))))
;; Relative file names shall work, too.
(let ((tramp-auto-save-directory "."))
(with-temp-buffer
(setq buffer-file-name tmp-name1
default-directory tmp-name2)
(should
(string-equal
(make-auto-save-file-name)
;; This is taken from Tramp.
(expand-file-name
(format
"#%s#"
(tramp-subst-strs-in-string
'(("_" . "|")
("/" . "_a")
(":" . "_b")
("|" . "__")
("[" . "_l")
("]" . "_r"))
(tramp-compat-file-name-unquote tmp-name1)))
tmp-name2)))
(should (file-directory-p tmp-name2)))))
;; Relative file names shall work, too. Ange-FTP doesn't care.
(unless (tramp--test-ange-ftp-p)
(let ((tramp-auto-save-directory "."))
(with-temp-buffer
(setq buffer-file-name tmp-name1
default-directory tmp-name2)
(should
(string-equal
(make-auto-save-file-name)
;; This is taken from Tramp.
(expand-file-name
(format
"#%s#"
(tramp-subst-strs-in-string
'(("_" . "|")
("/" . "_a")
(":" . "_b")
("|" . "__")
("[" . "_l")
("]" . "_r"))
(tramp-compat-file-name-unquote tmp-name1)))
tmp-name2)))
(should (file-directory-p tmp-name2))))))
;; Cleanup.
(ignore-errors (delete-file tmp-name1))
@ -4936,6 +4957,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted))
(ange-ftp-make-backup-files t)
;; These settings are not used by Tramp, so we ignore them.
version-control delete-old-versions
(kept-old-versions (default-toplevel-value 'kept-old-versions))
@ -4983,58 +5005,61 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(ignore-errors (delete-directory tmp-name2 'recursive)))
(unwind-protect
;; Map `tramp-backup-directory-alist'.
(let ((tramp-backup-directory-alist `(("." . ,tmp-name2)))
backup-directory-alist)
(should
(equal
(find-backup-file-name tmp-name1)
(list
(funcall
(if quoted #'tramp-compat-file-name-quote #'identity)
(expand-file-name
(format
"%s~"
;; This is taken from `make-backup-file-name-1'. We
;; call `convert-standard-filename', because on MS
;; Windows the (local) colons must be replaced by
;; exclamation marks.
(subst-char-in-string
?/ ?!
(replace-regexp-in-string
"!" "!!" (convert-standard-filename tmp-name1))))
tmp-name2)))))
;; The backup directory is created.
(should (file-directory-p tmp-name2)))
;; Map `tramp-backup-directory-alist'. Ange-FTP doesn't care.
(unless (tramp--test-ange-ftp-p)
(let ((tramp-backup-directory-alist `(("." . ,tmp-name2)))
backup-directory-alist)
(should
(equal
(find-backup-file-name tmp-name1)
(list
(funcall
(if quoted #'tramp-compat-file-name-quote #'identity)
(expand-file-name
(format
"%s~"
;; This is taken from `make-backup-file-name-1'.
;; We call `convert-standard-filename', because on
;; MS Windows the (local) colons must be replaced
;; by exclamation marks.
(subst-char-in-string
?/ ?!
(replace-regexp-in-string
"!" "!!" (convert-standard-filename tmp-name1))))
tmp-name2)))))
;; The backup directory is created.
(should (file-directory-p tmp-name2))))
;; Cleanup.
(ignore-errors (delete-directory tmp-name2 'recursive)))
(unwind-protect
;; Map `tramp-backup-directory-alist' with local file name.
(let ((tramp-backup-directory-alist
`(("." . ,(file-remote-p tmp-name2 'localname))))
backup-directory-alist)
(should
(equal
(find-backup-file-name tmp-name1)
(list
(funcall
(if quoted #'tramp-compat-file-name-quote #'identity)
(expand-file-name
(format
"%s~"
;; This is taken from `make-backup-file-name-1'. We
;; call `convert-standard-filename', because on MS
;; Windows the (local) colons must be replaced by
;; exclamation marks.
(subst-char-in-string
?/ ?!
(replace-regexp-in-string
"!" "!!" (convert-standard-filename tmp-name1))))
tmp-name2)))))
;; The backup directory is created.
(should (file-directory-p tmp-name2)))
;; Ange-FTP doesn't care.
(unless (tramp--test-ange-ftp-p)
(let ((tramp-backup-directory-alist
`(("." . ,(file-remote-p tmp-name2 'localname))))
backup-directory-alist)
(should
(equal
(find-backup-file-name tmp-name1)
(list
(funcall
(if quoted #'tramp-compat-file-name-quote #'identity)
(expand-file-name
(format
"%s~"
;; This is taken from `make-backup-file-name-1'.
;; We call `convert-standard-filename', because on
;; MS Windows the (local) colons must be replaced
;; by exclamation marks.
(subst-char-in-string
?/ ?!
(replace-regexp-in-string
"!" "!!" (convert-standard-filename tmp-name1))))
tmp-name2)))))
;; The backup directory is created.
(should (file-directory-p tmp-name2))))
;; Cleanup.
(ignore-errors (delete-directory tmp-name2 'recursive))))))
@ -5043,6 +5068,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(ert-deftest tramp-test39-make-nearby-temp-file ()
"Check `make-nearby-temp-file' and `temporary-file-directory'."
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-ange-ftp-p)))
;; Since Emacs 26.1.
(skip-unless
(and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory)))
@ -5099,6 +5125,12 @@ variables, so we check the Emacs version directly."
This requires restrictions of file name syntax."
(tramp-adb-file-name-p tramp-test-temporary-file-directory))
(defun tramp--test-ange-ftp-p ()
"Check, whether Ange-FTP is used."
(eq
(tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory)
'tramp-ftp-file-name-handler))
(defun tramp--test-docker-p ()
"Check, whether the docker method is used.
This does not support some special file names."
@ -5373,7 +5405,8 @@ This requires restrictions of file name syntax."
;; expanded to <TAB>.
(let ((files
(list
(if (or (tramp--test-gvfs-p)
(if (or (tramp--test-ange-ftp-p)
(tramp--test-gvfs-p)
(tramp--test-rclone-p)
(tramp--test-sudoedit-p)
(tramp--test-windows-nt-or-smb-p))