From: Michael Albinus Date: Thu, 7 Nov 2019 11:03:19 +0000 (+0100) Subject: Make ange-ftp fit for tramp-tests X-Git-Tag: emacs-27.0.90~711 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=4ab780012649bbab60238148efd9d3b4a819fd61;p=emacs.git Make ange-ftp fit for tramp-tests * 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. --- diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index a5fc9631e8a..16e8e757dc0 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -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 diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 9b73f7ca28e..271ac7299dd 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -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)))) - - ;; 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))))) + ;; 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. 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 . (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))