diff options
Diffstat (limited to 'test/lisp/net')
| -rw-r--r-- | test/lisp/net/netrc-resources/netrc-folding | 6 | ||||
| -rw-r--r-- | test/lisp/net/netrc-tests.el | 7 | ||||
| -rw-r--r-- | test/lisp/net/network-stream-tests.el | 3 | ||||
| -rw-r--r-- | test/lisp/net/nsm-tests.el | 2 | ||||
| -rw-r--r-- | test/lisp/net/ntlm-resources/authinfo | 1 | ||||
| -rw-r--r-- | test/lisp/net/ntlm-tests.el | 368 | ||||
| -rw-r--r-- | test/lisp/net/puny-tests.el | 6 | ||||
| -rw-r--r-- | test/lisp/net/sasl-scram-rfc-tests.el | 2 | ||||
| -rw-r--r-- | test/lisp/net/shr-tests.el | 2 | ||||
| -rw-r--r-- | test/lisp/net/socks-tests.el | 291 | ||||
| -rw-r--r-- | test/lisp/net/tramp-archive-tests.el | 120 | ||||
| -rw-r--r-- | test/lisp/net/tramp-tests.el | 542 |
12 files changed, 1109 insertions, 241 deletions
diff --git a/test/lisp/net/netrc-resources/netrc-folding b/test/lisp/net/netrc-resources/netrc-folding new file mode 100644 index 00000000000..85e5e324cdf --- /dev/null +++ b/test/lisp/net/netrc-resources/netrc-folding @@ -0,0 +1,6 @@ +# Foo +machine XM login XL password XP + +machine YM + login YL + password YP diff --git a/test/lisp/net/netrc-tests.el b/test/lisp/net/netrc-tests.el index 1328b191494..f75328a59f7 100644 --- a/test/lisp/net/netrc-tests.el +++ b/test/lisp/net/netrc-tests.el @@ -48,6 +48,13 @@ (should (equal (netrc-credentials "ftp.example.org") '("jrh" "*baz*"))))) +(ert-deftest test-netrc-credentials () + (let ((netrc-file (ert-resource-file "netrc-folding"))) + (should + (equal (netrc-parse netrc-file) + '((("machine" . "XM") ("login" . "XL") ("password" . "XP")) + (("machine" . "YM")) (("login" . "YL")) (("password" . "YP"))))))) + (provide 'netrc-tests) ;;; netrc-tests.el ends here diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index e0a06a28eec..4a0b23dd26f 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -128,7 +128,7 @@ (when prev (setq string (concat prev string)) (process-put proc 'previous-string nil))) - (if (and (not (string-match "\n" string)) + (if (and (not (string-search "\n" string)) (> (length string) 0)) (process-put proc 'previous-string string)) (let ((command (split-string string))) @@ -307,6 +307,7 @@ :name "bar" :buffer (generate-new-buffer "*foo*") :nowait t + :family 'ipv4 :tls-parameters (cons 'gnutls-x509pki (gnutls-boot-parameters diff --git a/test/lisp/net/nsm-tests.el b/test/lisp/net/nsm-tests.el index ff453319b37..1a35ec34cb9 100644 --- a/test/lisp/net/nsm-tests.el +++ b/test/lisp/net/nsm-tests.el @@ -1,4 +1,4 @@ -;;; network-stream-tests.el --- tests for network security manager -*- lexical-binding: t; -*- +;;; nsm-tests.el --- tests for network security manager -*- lexical-binding: t; -*- ;; Copyright (C) 2019-2021 Free Software Foundation, Inc. diff --git a/test/lisp/net/ntlm-resources/authinfo b/test/lisp/net/ntlm-resources/authinfo new file mode 100644 index 00000000000..698391e9313 --- /dev/null +++ b/test/lisp/net/ntlm-resources/authinfo @@ -0,0 +1 @@ +machine localhost port http user ntlm password ntlm diff --git a/test/lisp/net/ntlm-tests.el b/test/lisp/net/ntlm-tests.el index 6408ac13349..2420b3b48a9 100644 --- a/test/lisp/net/ntlm-tests.el +++ b/test/lisp/net/ntlm-tests.el @@ -17,11 +17,26 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Commentary: + +;; Run this with `NTLM_TESTS_VERBOSE=1' to get verbose debugging. + +;;; Code: + (require 'ert) +(require 'ert-x) (require 'ntlm) +(defsubst ntlm-tests-message (format-string &rest arguments) + "Print a message conditional on an environment variable being set. +FORMAT-STRING and ARGUMENTS are passed to the message function." + (when (getenv "NTLM_TESTS_VERBOSE") + (apply #'message (concat "ntlm-tests: " format-string) arguments))) + + ;; This is the Lisp bignum implementation of `ntlm--time-to-timestamp', ;; for reference. + (defun ntlm-tests--time-to-timestamp (time) "Convert TIME to an NTLMv2 timestamp. Return a unibyte string representing the number of tenths of a @@ -49,4 +64,357 @@ signed integer. TIME must be on the form (HIGH LOW USEC PSEC)." (should (equal (ntlm--time-to-timestamp time) (ntlm-tests--time-to-timestamp time))))) +(defvar ntlm-tests--username-oem "ntlm" + "The username for NTLM authentication tests, in OEM string encoding.") +(defvar ntlm-tests--username-unicode + (ntlm-ascii2unicode ntlm-tests--username-oem + (length ntlm-tests--username-oem)) + "The username for NTLM authentication tests, in Unicode string encoding.") + +(defvar ntlm-tests--password "ntlm" + "The password used for NTLM authentication tests.") + +(defvar ntlm-tests--client-supports-unicode nil + "Non-nil if client supports Unicode strings. +If client only supports OEM strings, nil.") + +(defvar ntlm-tests--challenge nil "The global random challenge.") + +(defun ntlm-server-build-type-2 () + "Return an NTLM Type 2 message as a string. +This string will be returned from the NTLM server to the NTLM client." + (let ((target (if ntlm-tests--client-supports-unicode + (ntlm-ascii2unicode "DOMAIN" (length "DOMAIN")) + "DOMAIN")) + (target-information ntlm-tests--password) + ;; Flag byte 1 flags. + (_negotiate-unicode 1) + (negotiate-oem 2) + (request-target 4) + ;; Flag byte 2 flags. + (negotiate-ntlm 2) + (_negotiate-local-call 4) + (_negotiate-always-sign 8) + ;; Flag byte 3 flags. + (_target-type-domain 1) + (_target-type-server 2) + (target-type-share 4) + (_negotiate-ntlm2-key 8) + (negotiate-target-information 128) + ;; Flag byte 4 flags, unused. + (_negotiate-128 32) + (_negotiate-56 128)) + (concat + ;; Signature. + "NTLMSSP" (unibyte-string 0) + ;; Type 2. + (unibyte-string 2 0 0 0) + ;; Target length + (unibyte-string (length target) 0) + ;; Target allocated space. + (unibyte-string (length target) 0) + ;; Target offset. + (unibyte-string 48 0 0 0) + ;; Flags. + ;; Flag byte 1. + ;; Tell the client that this test server only supports OEM + ;; strings. This test server will handle Unicode strings + ;; anyway though. + (unibyte-string (logior negotiate-oem request-target)) + ;; Flag byte 2. + (unibyte-string negotiate-ntlm) + ;; Flag byte 3. + (unibyte-string (logior negotiate-target-information target-type-share)) + ;; Flag byte 4. Not sure what 2 means here. + (unibyte-string 2) + ;; Challenge. Set this to (unibyte-string 1 2 3 4 5 6 7 8) + ;; instead of (ntlm-generate-nonce) to hold constant for + ;; debugging. + (setq ntlm-tests--challenge (ntlm-generate-nonce)) + ;; Context. + (make-string 8 0) + (unibyte-string (length target-information) 0) + (unibyte-string (length target-information) 0) + (unibyte-string 54 0 0 0) + target + target-information))) + +(defun ntlm-server-hash (challenge blob username password) + "Hash CHALLENGE, BLOB, USERNAME and PASSWORD for a Type 3 check." + (hmac-md5 (concat challenge blob) + (hmac-md5 (concat + (upcase + ;; This calculation always uses + ;; Unicode username, even when the + ;; server only supports OEM strings. + (ntlm-ascii2unicode username (length username))) "") + (cadr (ntlm-get-password-hashes password))))) + +(defun ntlm-server-check-authorization (authorization-string) + "Return t if AUTHORIZATION-STRING correctly authenticates the user." + (let* ((binary (base64-decode-string + (caddr (split-string authorization-string " ")))) + (_lm-response-length (md4-unpack-int16 (substring binary 12 14))) + (_lm-response-offset + (cdr (md4-unpack-int32 (substring binary 16 20)))) + (ntlm-response-length (md4-unpack-int16 (substring binary 20 22))) + (ntlm-response-offset + (cdr (md4-unpack-int32 (substring binary 24 28)))) + (ntlm-hash + (substring binary ntlm-response-offset (+ ntlm-response-offset 16))) + (username-length (md4-unpack-int16 (substring binary 36 38))) + (username-offset (cdr (md4-unpack-int32 (substring binary 40 44)))) + (username (substring binary username-offset + (+ username-offset username-length)))) + (if (equal ntlm-response-length 24) + (let* ((expected + (ntlm-smb-owf-encrypt + (cadr (ntlm-get-password-hashes ntlm-tests--password)) + ntlm-tests--challenge)) + (received (substring binary ntlm-response-offset + (+ ntlm-response-offset + ntlm-response-length)))) + (ntlm-tests-message "Got NTLMv1 response:") + (ntlm-tests-message "Expected hash: ===%S===" expected) + (ntlm-tests-message "Got hash: ===%S===" received) + (ntlm-tests-message "Expected username: ===%S===" + ntlm-tests--username-oem) + (ntlm-tests-message "Got username: ===%S===" username) + (and (or (equal username ntlm-tests--username-oem) + (equal username ntlm-tests--username-unicode)) + (equal expected received))) + (let* ((ntlm-response-blob + (substring binary (+ ntlm-response-offset 16) + (+ (+ ntlm-response-offset 16) + (- ntlm-response-length 16)))) + (_ntlm-timestamp (substring ntlm-response-blob 8 16)) + (_ntlm-nonce (substring ntlm-response-blob 16 24)) + (_target-length (md4-unpack-int16 (substring binary 28 30))) + (_target-offset + (cdr (md4-unpack-int32 (substring binary 32 36)))) + (_workstation-length (md4-unpack-int16 (substring binary 44 46))) + (_workstation-offset + (cdr (md4-unpack-int32 (substring binary 48 52))))) + (cond + ;; This test server claims to only support OEM strings, + ;; but also checks Unicode strings. + ((or (equal username ntlm-tests--username-oem) + (equal username ntlm-tests--username-unicode)) + (let* ((password ntlm-tests--password) + (ntlm-hash-from-type-3 (ntlm-server-hash + ntlm-tests--challenge + ntlm-response-blob + ;; Always -oem since + ;; `ntlm-server-hash' + ;; always converts it to + ;; Unicode. + ntlm-tests--username-oem + password))) + (ntlm-tests-message "Got NTLMv2 response:") + (ntlm-tests-message "Expected hash: ==%S==" ntlm-hash) + (ntlm-tests-message "Got hash: ==%S==" ntlm-hash-from-type-3) + (ntlm-tests-message "Expected username: ===%S===" + ntlm-tests--username-oem) + (ntlm-tests-message " or username: ===%S===" + ntlm-tests--username-unicode) + (ntlm-tests-message "Got username: ===%S===" username) + (equal ntlm-hash ntlm-hash-from-type-3))) + (t + nil)))))) + +(require 'eieio) +(require 'cl-lib) + +;; Silence some byte-compiler warnings that occur when +;; web-server/web-server.el is not found. +(declare-function ws-send nil) +(declare-function ws-parse-request nil) +(declare-function ws-start nil) +(declare-function ws-stop-all nil) + +(require 'web-server nil t) +(require 'url-http-ntlm nil t) + +(defun ntlm-server-do-token (request _process) + "Process an NTLM client's REQUEST. +PROCESS is unused." + (with-slots (process headers) request + (let* ((header-alist (cdr headers)) + (authorization-header (assoc ':AUTHORIZATION header-alist)) + (authorization-string (cdr authorization-header))) + (if (and (stringp authorization-string) + (string-match "NTLM " authorization-string)) + (let* ((challenge (substring authorization-string (match-end 0))) + (binary (base64-decode-string challenge)) + (type (aref binary 8)) + ;; Flag byte 1 flags. + (negotiate-unicode 1) + (negotiate-oem 2) + (flags-byte-1 (aref binary 12)) + (client-supports-unicode + (not (zerop (logand flags-byte-1 negotiate-unicode)))) + (client-supports-oem + (not (zerop (logand flags-byte-1 negotiate-oem)))) + (connection-header (assoc ':CONNECTION header-alist)) + (_keep-alive + (when connection-header (cdr connection-header))) + (response + (cl-case type + (1 + ;; Return Type 2 message. + (when (and (not client-supports-unicode) + (not client-supports-oem)) + (warn (concat + "Weird client supports neither Unicode" + " nor OEM strings, using OEM."))) + (setq ntlm-tests--client-supports-unicode + client-supports-unicode) + (concat + "HTTP/1.1 401 Unauthorized\r\n" + "WWW-Authenticate: NTLM " + (base64-encode-string + (ntlm-server-build-type-2) t) "\r\n" + "WWW-Authenticate: Negotiate\r\n" + "WWW-Authenticate: Basic realm=\"domain\"\r\n" + "Content-Length: 0\r\n\r\n")) + (3 + (if (ntlm-server-check-authorization + authorization-string) + "HTTP/1.1 200 OK\r\n\r\nAuthenticated.\r\n" + (progn + (if process + (set-process-filter process nil) + (error "Type 3 message found first?")) + (concat "HTTP/1.1 401 Unauthorized\r\n\r\n" + "Access Denied.\r\n"))))))) + (if response + (ws-send process response) + (when process + (set-process-filter process nil))) + (when (equal type 3) + (set-process-filter process nil) + (process-send-eof process))) + (progn + ;; Did not get NTLM anything. + (set-process-filter process nil) + (process-send-eof process) + (concat "HTTP/1.1 401 Unauthorized\r\n\r\n" + "Access Denied.\r\n")))))) + +(defun ntlm-server-filter (process string) + "Read from PROCESS a STRING and treat it as a request from an NTLM client." + (let ((request (make-instance 'ws-request + :process process :pending string))) + (if (ws-parse-request request) + (ntlm-server-do-token request process) + (error "Failed to parse request")))) + +(defun ntlm-server-handler (request) + "Handle an HTTP REQUEST." + (with-slots (process headers) request + (let* ((header-alist (cdr headers)) + (authorization-header (assoc ':AUTHORIZATION header-alist)) + (connection-header (assoc ':CONNECTION header-alist)) + (keep-alive (when connection-header (cdr connection-header))) + (response (concat + "HTTP/1.1 401 Unauthorized\r\n" + "WWW-Authenticate: Negotiate\r\n" + "WWW-Authenticate: NTLM\r\n" + "WWW-Authenticate: Basic realm=\"domain\"\r\n" + "Content-Length: 0\r\n\r\n"))) + (if (null authorization-header) + ;; Tell client to use NTLM. Firefox will create a new + ;; connection. + (progn + (process-send-string process response) + (process-send-eof process)) + (progn + (ntlm-server-do-token request nil) + (set-process-filter process #'ntlm-server-filter) + (if (equal (upcase keep-alive) "KEEP-ALIVE") + :keep-alive + (error "NTLM server expects keep-alive connection header"))))))) + +(defun ntlm-server-start () + "Start an NTLM server on port 8080 for testing." + (ws-start 'ntlm-server-handler 8080)) + +(defun ntlm-server-stop () + "Stop the NTLM server." + (ws-stop-all)) + +(defvar ntlm-tests--result-buffer nil "Final NTLM result buffer.") + +(require 'url) + +(defun ntlm-tests--url-retrieve-internal-around (original &rest arguments) + "Save the result buffer from a `url-retrieve-internal' to a global variable. +ORIGINAL is the original `url-retrieve-internal' function and +ARGUMENTS are passed to it." + (setq ntlm-tests--result-buffer (apply original arguments))) + +(defun ntlm-tests--authenticate () + "Authenticate using credentials from the authinfo resource file." + (setq ntlm-tests--result-buffer nil) + (let ((auth-sources (list (ert-resource-file "authinfo"))) + (auth-source-do-cache nil) + (auth-source-debug (when (getenv "NTLM_TESTS_VERBOSE") 'trivia))) + (ntlm-tests-message "Using auth-sources: %S" auth-sources) + (url-retrieve-synchronously "http://localhost:8080")) + (sleep-for 0.1) + (ntlm-tests-message "Results are in: %S" ntlm-tests--result-buffer) + (with-current-buffer ntlm-tests--result-buffer + (buffer-string))) + +(defun ntlm-tests--start-server-authenticate-stop-server () + "Start an NTLM server, authenticate against it, then stop the server." + (advice-add #'url-retrieve-internal + :around #'ntlm-tests--url-retrieve-internal-around) + (ntlm-server-stop) + (ntlm-server-start) + (let ((result (ntlm-tests--authenticate))) + (advice-remove #'url-retrieve-internal + #'ntlm-tests--url-retrieve-internal-around) + (ntlm-server-stop) + result)) + +(defvar ntlm-tests--successful-result + (concat "HTTP/1.1 200 OK\n\nAuthenticated." (unibyte-string 13) "\n") + "Expected result of successful NTLM authentication.") + +(require 'find-func) +(defun ntlm-tests--ensure-ws-parse-ntlm-support () + "Ensure NTLM special-case in `ws-parse'." + (let* ((hit (find-function-search-for-symbol + 'ws-parse nil (locate-file "web-server.el" load-path))) + (buffer (car hit)) + (position (cdr hit))) + (with-current-buffer buffer + (goto-char position) + (search-forward-regexp + ":NTLM" (save-excursion (forward-sexp) (point)) t)))) + +(require 'lisp-mnt) +(defvar ntlm-tests--dependencies-present + (and (featurep 'url-http-ntlm) + (version<= "2.0.4" + (lm-version (locate-file "url-http-ntlm.el" load-path))) + (featurep 'web-server) + (ntlm-tests--ensure-ws-parse-ntlm-support)) + "Non-nil if GNU ELPA test dependencies were loaded.") + +(ert-deftest ntlm-authentication () + "Check ntlm.el's implementation of NTLM authentication over HTTP." + (skip-unless ntlm-tests--dependencies-present) + (should (equal (ntlm-tests--start-server-authenticate-stop-server) + ntlm-tests--successful-result))) + +(ert-deftest ntlm-authentication-old-compatibility-level () + (skip-unless ntlm-tests--dependencies-present) + (setq ntlm-compatibility-level 0) + (should (equal (ntlm-tests--start-server-authenticate-stop-server) + ntlm-tests--successful-result))) + (provide 'ntlm-tests) + +;;; ntlm-tests.el ends here diff --git a/test/lisp/net/puny-tests.el b/test/lisp/net/puny-tests.el index b37168f5ca7..28c0d49cbee 100644 --- a/test/lisp/net/puny-tests.el +++ b/test/lisp/net/puny-tests.el @@ -39,10 +39,12 @@ (should (string= (puny-decode-string "xn--9dbdkw") "חנוך"))) (ert-deftest puny-test-encode-domain () - (should (string= (puny-encode-domain "åäö.se") "xn--4cab6c.se"))) + (should (string= (puny-encode-domain "åäö.se") "xn--4cab6c.se")) + (should (string= (puny-encode-domain "яндекс.рф") "xn--d1acpjx3f.xn--p1ai"))) (ert-deftest puny-test-decode-domain () - (should (string= (puny-decode-domain "xn--4cab6c.se") "åäö.se"))) + (should (string= (puny-decode-domain "xn--4cab6c.se") "åäö.se")) + (should (string= (puny-decode-domain "xn--d1acpjx3f.xn--p1ai") "яндекс.рф"))) (ert-deftest puny-highly-restrictive-domain-p () (should (puny-highly-restrictive-domain-p "foo.bar.org")) diff --git a/test/lisp/net/sasl-scram-rfc-tests.el b/test/lisp/net/sasl-scram-rfc-tests.el index 3e9879a49d4..dfd4cf0e7ac 100644 --- a/test/lisp/net/sasl-scram-rfc-tests.el +++ b/test/lisp/net/sasl-scram-rfc-tests.el @@ -4,6 +4,8 @@ ;; Author: Magnus Henoch <magnus.henoch@gmail.com> +;; This file is part of GNU Emacs. + ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el index a06e31a4f88..ed532af657a 100644 --- a/test/lisp/net/shr-tests.el +++ b/test/lisp/net/shr-tests.el @@ -1,4 +1,4 @@ -;;; network-stream-tests.el --- tests for network processes -*- lexical-binding: t; -*- +;;; shr-tests.el --- tests for shr.el -*- lexical-binding: t; -*- ;; Copyright (C) 2016-2021 Free Software Foundation, Inc. diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el index b378ed2964e..71bdd74890a 100644 --- a/test/lisp/net/socks-tests.el +++ b/test/lisp/net/socks-tests.el @@ -21,68 +21,151 @@ ;;; Code: +(require 'ert) (require 'socks) (require 'url-http) -(defvar socks-tests-canned-server-port nil) +(ert-deftest socks-tests-auth-registration-and-suite-offer () + (ert-info ("Default favors user/pass auth") + (should (equal socks-authentication-methods + '((2 "Username/Password" . socks-username/password-auth) + (0 "No authentication" . identity)))) + (should (equal "\2\0\2" (socks-build-auth-list)))) ; length [offer ...] + (let (socks-authentication-methods) + (ert-info ("Empty selection/no methods offered") + (should (equal "\0" (socks-build-auth-list)))) + (ert-info ("Simulate library defaults") + (socks-register-authentication-method 0 "No authentication" + 'identity) + (should (equal socks-authentication-methods + '((0 "No authentication" . identity)))) + (should (equal "\1\0" (socks-build-auth-list))) + (socks-register-authentication-method 2 "Username/Password" + 'socks-username/password-auth) + (should (equal socks-authentication-methods + '((2 "Username/Password" . socks-username/password-auth) + (0 "No authentication" . identity)))) + (should (equal "\2\0\2" (socks-build-auth-list)))) + (ert-info ("Removal") + (socks-unregister-authentication-method 2) + (should (equal socks-authentication-methods + '((0 "No authentication" . identity)))) + (should (equal "\1\0" (socks-build-auth-list))) + (socks-unregister-authentication-method 0) + (should-not socks-authentication-methods) + (should (equal "\0" (socks-build-auth-list)))))) -(defun socks-tests-canned-server-create (verbatim patterns) - "Create a fake SOCKS server and return the process. +(ert-deftest socks-tests-filter-response-parsing-v4 () + "Ensure new chunks added on right (Bug#45162)." + (let* ((buf (generate-new-buffer "*test-socks-filter*")) + (proc (start-process "test-socks-filter" buf "sleep" "1"))) + (process-put proc 'socks t) + (process-put proc 'socks-state socks-state-waiting) + (process-put proc 'socks-server-protocol 4) + (ert-info ("Receive initial incomplete segment") + (socks-filter proc (concat [0 90 0 0 93 184 216])) + ;; From example.com: OK status ^ ^ msg start + (ert-info ("State still set to waiting") + (should (eq (process-get proc 'socks-state) socks-state-waiting))) + (ert-info ("Response field is nil because processing incomplete") + (should-not (process-get proc 'socks-response))) + (ert-info ("Scratch field holds stashed partial payload") + (should (string= (concat [0 90 0 0 93 184 216]) + (process-get proc 'socks-scratch))))) + (ert-info ("Last part arrives") + (socks-filter proc "\42") ; ?\" 34 + (ert-info ("State transitions to complete (length check passes)") + (should (eq (process-get proc 'socks-state) socks-state-connected))) + (ert-info ("Scratch and response fields hold stash w. last chunk") + (should (string= (concat [0 90 0 0 93 184 216 34]) + (process-get proc 'socks-response))) + (should (string= (process-get proc 'socks-response) + (process-get proc 'socks-scratch))))) + (delete-process proc) + (kill-buffer buf))) -`VERBATIM' and `PATTERNS' are dotted alists containing responses. -Requests are tried in order. On failure, an error is raised." - (let* ((buf (generate-new-buffer "*canned-socks-server*")) +(ert-deftest socks-tests-filter-response-parsing-v5 () + "Ensure new chunks added on right (Bug#45162)." + (let* ((buf (generate-new-buffer "*test-socks-filter*")) + (proc (start-process "test-socks-filter" buf "sleep" "1"))) + (process-put proc 'socks t) + (process-put proc 'socks-state socks-state-waiting) + (process-put proc 'socks-server-protocol 5) + (ert-info ("Receive initial incomplete segment") + ;; From fedora.org: 2605:bc80:3010:600:dead:beef:cafe:fed9 + ;; 5004 ~~> Version Status (OK) NOOP Addr-Type (4 -> IPv6) + (socks-filter proc "\5\0\0\4\x26\x05\xbc\x80\x30\x10\x00\x60") + (ert-info ("State still waiting and response emtpy") + (should (eq (process-get proc 'socks-state) socks-state-waiting)) + (should-not (process-get proc 'socks-response))) + (ert-info ("Scratch field holds partial payload of pending msg") + (should (string= "\5\0\0\4\x26\x05\xbc\x80\x30\x10\x00\x60" + (process-get proc 'socks-scratch))))) + (ert-info ("Middle chunk arrives") + (socks-filter proc "\xde\xad\xbe\xef\xca\xfe\xfe\xd9") + (ert-info ("State and response fields still untouched") + (should (eq (process-get proc 'socks-state) socks-state-waiting)) + (should-not (process-get proc 'socks-response))) + (ert-info ("Scratch contains new arrival appended (on RHS)") + (should (string= (concat "\5\0\0\4" + "\x26\x05\xbc\x80\x30\x10\x00\x60" + "\xde\xad\xbe\xef\xca\xfe\xfe\xd9") + (process-get proc 'socks-scratch))))) + (ert-info ("Final part arrives (port number)") + (socks-filter proc "\0\0") + (ert-info ("State transitions to complete") + (should (eq (process-get proc 'socks-state) socks-state-connected))) + (ert-info ("Scratch and response fields show last chunk appended") + (should (string= (concat "\5\0\0\4" + "\x26\x05\xbc\x80\x30\x10\x00\x60" + "\xde\xad\xbe\xef\xca\xfe\xfe\xd9" + "\0\0") + (process-get proc 'socks-scratch))) + (should (string= (process-get proc 'socks-response) + (process-get proc 'socks-scratch))))) + (delete-process proc) + (kill-buffer buf))) + +(defvar socks-tests-canned-server-patterns nil + "Alist containing request/response cons pairs to be tried in order. +Vectors must match verbatim. Strings are considered regex patterns.") + +(defun socks-tests-canned-server-create () + "Create and return a fake SOCKS server." + (let* ((port (nth 2 socks-server)) + (name (format "socks-server:%d" port)) + (pats socks-tests-canned-server-patterns) (filt (lambda (proc line) - (let ((resp (or (assoc-default line verbatim - (lambda (k s) ; s is line - (string= (concat k) s))) - (assoc-default line patterns - (lambda (p s) - (string-match-p p s)))))) - (unless resp + (pcase-let ((`(,pat . ,resp) (pop pats))) + (unless (or (and (vectorp pat) (equal pat (vconcat line))) + (string-match-p pat line)) (error "Unknown request: %s" line)) (let ((print-escape-control-characters t)) - (princ (format "<- %s\n" (prin1-to-string line)) buf) - (princ (format "-> %s\n" (prin1-to-string resp)) buf)) + (message "[%s] <- %s" name (prin1-to-string line)) + (message "[%s] -> %s" name (prin1-to-string resp))) (process-send-string proc (concat resp))))) - (srv (make-network-process :server 1 - :buffer buf - :filter filt - :name "server" - :family 'ipv4 - :host 'local - :service socks-tests-canned-server-port))) - (set-process-query-on-exit-flag srv nil) - (princ (format "[%s] Listening on localhost:10080\n" srv) buf) - srv)) - -;; Add ([5 3 0 1 2] . [5 2]) to the `verbatim' list below to validate -;; against curl 7.71 with the following options: -;; $ curl --verbose -U foo:bar --proxy socks5h://127.0.0.1:10080 example.com -;; -;; If later implementing version 4a, try these: -;; [4 1 0 80 0 0 0 1 0 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0] . [0 90 0 0 0 0 0 0] -;; $ curl --verbose --proxy socks4a://127.0.0.1:10080 example.com + (serv (make-network-process :server 1 + :buffer (get-buffer-create name) + :filter filt + :name name + :family 'ipv4 + :host 'local + :coding 'binary + :service port))) + (set-process-query-on-exit-flag serv nil) + serv)) -(ert-deftest socks-tests-auth-filter-url-http () - "Verify correct handling of SOCKS5 user/pass authentication." - (let* ((socks-server '("server" "127.0.0.1" 10080 5)) - (socks-username "foo") - (socks-password "bar") - (url-gateway-method 'socks) +(defvar socks-tests--hello-world-http-request-pattern + (cons "^GET /" (concat "HTTP/1.1 200 OK\r\n" + "Content-Type: text/plain\r\n" + "Content-Length: 13\r\n\r\n" + "Hello World!\n"))) + +(defun socks-tests-perform-hello-world-http-request () + "Start canned server, validate hello-world response, and finalize." + (let* ((url-gateway-method 'socks) (url (url-generic-parse-url "http://example.com")) - (verbatim '(([5 2 0 2] . [5 2]) - ([1 3 ?f ?o ?o 3 ?b ?a ?r] . [1 0]) - ([5 1 0 3 11 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0 80] - . [5 0 0 1 0 0 0 0 0 0]))) - (patterns - `(("^GET /" . ,(concat "HTTP/1.1 200 OK\r\n" - "Content-Type: text/plain; charset=UTF-8\r\n" - "Content-Length: 13\r\n\r\n" - "Hello World!\n")))) - (socks-tests-canned-server-port 10080) - (server (socks-tests-canned-server-create verbatim patterns)) - (tries 10) + (server (socks-tests-canned-server-create)) ;; done ;; @@ -90,14 +173,112 @@ Requests are tried in order. On failure, an error is raised." (goto-char (point-min)) (should (search-forward "Hello World" nil t)) (setq done t))) - (buf (url-http url cb '(nil)))) - (ert-info ("Connect to HTTP endpoint over SOCKS5 with USER/PASS method") - (while (and (not done) (< 0 (cl-decf tries))) ; cl-lib via url-http - (sleep-for 0.1))) + (inhibit-message noninteractive) + (buf (url-http url cb '(nil))) + (proc (get-buffer-process buf)) + (attempts 10)) + (while (and (not done) (< 0 (cl-decf attempts))) + (sleep-for 0.1)) (should done) (delete-process server) + (delete-process proc) ; otherwise seems client proc is sometimes reused (kill-buffer (process-buffer server)) (kill-buffer buf) (ignore url-gateway-method))) +;; Unlike curl, socks.el includes the ID field (but otherwise matches): +;; $ curl --proxy socks4://127.0.0.1:1080 example.com + +(ert-deftest socks-tests-v4-basic () + "Show correct preparation of SOCKS4 connect command (Bug#46342)." + (let ((socks-server '("server" "127.0.0.1" 10079 4)) + (url-user-agent "Test/4-basic") + (socks-tests-canned-server-patterns + `(([4 1 0 80 93 184 216 34 ?f ?o ?o 0] . [0 90 0 0 0 0 0 0]) + ,socks-tests--hello-world-http-request-pattern)) + socks-nslookup-program) + (ert-info ("Make HTTP request over SOCKS4") + (cl-letf (((symbol-function 'socks-nslookup-host) + (lambda (host) + (should (equal host "example.com")) + (list 93 184 216 34))) + ((symbol-function 'user-full-name) + (lambda () "foo"))) + (socks-tests-perform-hello-world-http-request))))) + +;; Replace first pattern below with ([5 3 0 1 2] . [5 2]) to validate +;; against curl 7.71 with the following options: +;; $ curl --verbose -U foo:bar --proxy socks5h://127.0.0.1:10080 example.com + +(ert-deftest socks-tests-v5-auth-user-pass () + "Verify correct handling of SOCKS5 user/pass authentication." + (should (assq 2 socks-authentication-methods)) + (let ((socks-server '("server" "127.0.0.1" 10080 5)) + (socks-username "foo") + (socks-password "bar") + (url-user-agent "Test/auth-user-pass") + (socks-tests-canned-server-patterns + `(([5 2 0 2] . [5 2]) + ([1 3 ?f ?o ?o 3 ?b ?a ?r] . [1 0]) + ([5 1 0 3 11 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0 80] + . [5 0 0 1 0 0 0 0 0 0]) + ,socks-tests--hello-world-http-request-pattern))) + (ert-info ("Make HTTP request over SOCKS5 with USER/PASS auth method") + (socks-tests-perform-hello-world-http-request)))) + +;; Services (like Tor) may be configured without auth but for some +;; reason still prefer the user/pass method over none when offered both. +;; Given this library's defaults, the scenario below is possible. +;; +;; FYI: RFC 1929 doesn't say that a username or password is required +;; but notes that the length of both fields should be at least one. +;; However, both socks.el and curl send zero-length fields (though +;; curl drops the user part too when the password is empty). +;; +;; From Tor's docs /socks-extensions.txt, 1.1 Extent of support: +;; > We allow username/password fields of this message to be empty ... +;; line 41 in blob 5fd1f828f3e9d014f7b65fa3bd1d33c39e4129e2 +;; https://gitweb.torproject.org/torspec.git/tree/socks-extensions.txt +;; +;; To verify against curl 7.71, swap out the first two pattern pairs +;; with ([5 3 0 1 2] . [5 2]) and ([1 0 0] . [1 0]), then run: +;; $ curl verbose -U "foo:" --proxy socks5h://127.0.0.1:10081 example.com + +(ert-deftest socks-tests-v5-auth-user-pass-blank () + "Verify correct SOCKS5 user/pass authentication with empty pass." + (should (assq 2 socks-authentication-methods)) + (let ((socks-server '("server" "127.0.0.1" 10081 5)) + (socks-username "foo") ; defaults to (user-login-name) + (socks-password "") ; simulate user hitting enter when prompted + (url-user-agent "Test/auth-user-pass-blank") + (socks-tests-canned-server-patterns + `(([5 2 0 2] . [5 2]) + ([1 3 ?f ?o ?o 0] . [1 0]) + ([5 1 0 3 11 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0 80] + . [5 0 0 1 0 0 0 0 0 0]) + ,socks-tests--hello-world-http-request-pattern))) + (ert-info ("Make HTTP request over SOCKS5 with USER/PASS auth method") + (socks-tests-perform-hello-world-http-request)))) + +;; Swap out ([5 2 0 1] . [5 0]) with the first pattern below to validate +;; against curl 7.71 with the following options: +;; $ curl --verbose --proxy socks5h://127.0.0.1:10082 example.com + +(ert-deftest socks-tests-v5-auth-none () + "Verify correct handling of SOCKS5 when auth method 0 requested." + (let ((socks-server '("server" "127.0.0.1" 10082 5)) + (socks-authentication-methods (append socks-authentication-methods + nil)) + (url-user-agent "Test/auth-none") + (socks-tests-canned-server-patterns + `(([5 1 0] . [5 0]) + ([5 1 0 3 11 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0 80] + . [5 0 0 1 0 0 0 0 0 0]) + ,socks-tests--hello-world-http-request-pattern))) + (socks-unregister-authentication-method 2) + (should-not (assq 2 socks-authentication-methods)) + (ert-info ("Make HTTP request over SOCKS5 with no auth method") + (socks-tests-perform-hello-world-http-request))) + (should (assq 2 socks-authentication-methods))) + ;;; socks-tests.el ends here diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 6a6b56f4a1d..aac1b13bd0e 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -292,15 +292,26 @@ variables, so we check the Emacs version directly." "Check `expand-file-name'." (should (string-equal - (expand-file-name "/foo.tar/path/./file") "/foo.tar/path/file")) + (expand-file-name (concat tramp-archive-test-archive "path/./file")) + (concat tramp-archive-test-archive "path/file"))) (should - (string-equal (expand-file-name "/foo.tar/path/../file") "/foo.tar/file")) + (string-equal + (expand-file-name (concat tramp-archive-test-archive "path/../file")) + (concat tramp-archive-test-archive "file"))) ;; `expand-file-name' does not care "~/" in archive file names. (should - (string-equal (expand-file-name "/foo.tar/~/file") "/foo.tar/~/file")) + (string-equal + (expand-file-name (concat tramp-archive-test-archive "~/file")) + (concat tramp-archive-test-archive "~/file"))) ;; `expand-file-name' does not care file archive boundaries. - (should (string-equal (expand-file-name "/foo.tar/./file") "/foo.tar/file")) - (should (string-equal (expand-file-name "/foo.tar/../file") "/file"))) + (should + (string-equal + (expand-file-name (concat tramp-archive-test-archive "./file")) + (concat tramp-archive-test-archive "file"))) + (should + (string-equal + (expand-file-name (concat tramp-archive-test-archive "../file")) + (concat (ert-resource-directory) "file")))) ;; This test is inspired by Bug#30293. (ert-deftest tramp-archive-test05-expand-file-name-non-archive-directory () @@ -325,38 +336,59 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal - (directory-file-name "/foo.tar/path/to/file") "/foo.tar/path/to/file")) + (directory-file-name (concat tramp-archive-test-archive "path/to/file")) + (concat tramp-archive-test-archive "path/to/file"))) (should (string-equal - (directory-file-name "/foo.tar/path/to/file/") "/foo.tar/path/to/file")) + (directory-file-name (concat tramp-archive-test-archive "path/to/file/")) + (concat tramp-archive-test-archive "path/to/file"))) ;; `directory-file-name' does not leave file archive boundaries. - (should (string-equal (directory-file-name "/foo.tar/") "/foo.tar/")) + (should + (string-equal + (directory-file-name tramp-archive-test-archive) tramp-archive-test-archive)) (should (string-equal - (file-name-as-directory "/foo.tar/path/to/file") "/foo.tar/path/to/file/")) + (file-name-as-directory (concat tramp-archive-test-archive "path/to/file")) + (concat tramp-archive-test-archive "path/to/file/"))) (should (string-equal - (file-name-as-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/")) - (should (string-equal (file-name-as-directory "/foo.tar/") "/foo.tar/")) - (should (string-equal (file-name-as-directory "/foo.tar") "/foo.tar/")) + (file-name-as-directory (concat tramp-archive-test-archive "path/to/file/")) + (concat tramp-archive-test-archive "path/to/file/"))) + (should + (string-equal + (file-name-as-directory tramp-archive-test-archive) + tramp-archive-test-archive)) + (should + (string-equal + (file-name-as-directory tramp-archive-test-file-archive) + tramp-archive-test-archive)) (should (string-equal - (file-name-directory "/foo.tar/path/to/file") "/foo.tar/path/to/")) + (file-name-directory (concat tramp-archive-test-archive "path/to/file")) + (concat tramp-archive-test-archive "path/to/"))) (should (string-equal - (file-name-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/")) - (should (string-equal (file-name-directory "/foo.tar/") "/foo.tar/")) + (file-name-directory (concat tramp-archive-test-archive "path/to/file/")) + (concat tramp-archive-test-archive "path/to/file/"))) + (should + (string-equal + (file-name-directory tramp-archive-test-archive) tramp-archive-test-archive)) (should - (string-equal (file-name-nondirectory "/foo.tar/path/to/file") "file")) + (string-equal + (file-name-nondirectory (concat tramp-archive-test-archive "path/to/file")) + "file")) (should - (string-equal (file-name-nondirectory "/foo.tar/path/to/file/") "")) - (should (string-equal (file-name-nondirectory "/foo.tar/") "")) + (string-equal + (file-name-nondirectory (concat tramp-archive-test-archive "path/to/file/")) + "")) + (should (string-equal (file-name-nondirectory tramp-archive-test-archive) "")) (should-not - (unhandled-file-name-directory "/foo.tar/path/to/file"))) + (unhandled-file-name-directory + (concat tramp-archive-test-archive "path/to/file")))) (ert-deftest tramp-archive-test07-file-exists-p () "Check `file-exist-p', `write-region' and `delete-file'." @@ -824,7 +856,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (tramp-archive-cleanup-hash)))) ;; The functions were introduced in Emacs 26.1. -(ert-deftest tramp-archive-test39-make-nearby-temp-file () +(ert-deftest tramp-archive-test40-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." (skip-unless tramp-archive-enabled) ;; Since Emacs 26.1. @@ -861,7 +893,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (delete-directory tmp-file) (should-not (file-exists-p tmp-file)))) -(ert-deftest tramp-archive-test42-file-system-info () +(ert-deftest tramp-archive-test43-file-system-info () "Check that `file-system-info' returns proper values." (skip-unless tramp-archive-enabled) ;; Since Emacs 27.1. @@ -887,27 +919,35 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." ;; tramp-archive is neither loaded at Emacs startup, nor when ;; loading a file like "/mock::foo" (which loads Tramp). - (let ((default-directory (expand-file-name temporary-file-directory)) - (code + (let ((code "(progn \ - (message \"tramp-archive loaded: %%s %%s\" \ - (featurep 'tramp) (featurep 'tramp-archive)) \ + (message \"tramp-archive loaded: %%s\" \ + (featurep 'tramp-archive)) \ (file-attributes %S \"/\") \ - (message \"tramp-archive loaded: %%s %%s\" \ - (featurep 'tramp) (featurep 'tramp-archive)))")) - (dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo"))) - (should - (string-match - (format - "tramp-archive loaded: nil nil[[:ascii:]]+tramp-archive loaded: t %s" - (tramp-archive-file-name-p file)) - (shell-command-to-string - (format - "%s -batch -Q -L %s --eval %s" - (shell-quote-argument - (expand-file-name invocation-name invocation-directory)) - (mapconcat #'shell-quote-argument load-path " -L ") - (shell-quote-argument (format code file))))))))) + (message \"tramp-archive loaded: %%s\" \ + (featurep 'tramp-archive)))")) + (dolist (default-directory + `(,temporary-file-directory + ;; Starting Emacs in a directory which has + ;; `tramp-archive-file-name-regexp' syntax is + ;; supported only with Emacs > 27.2 (sigh!). + ;; (Bug#48476) + ,(file-name-as-directory tramp-archive-test-directory))) + (dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo"))) + (should + (string-match + (format + "tramp-archive loaded: %s[[:ascii:]]+tramp-archive loaded: %s" + (tramp-archive-file-name-p default-directory) + (or (tramp-archive-file-name-p default-directory) + (tramp-archive-file-name-p file))) + (shell-command-to-string + (format + "%s -batch -Q -L %s --eval %s" + (shell-quote-argument + (expand-file-name invocation-name invocation-directory)) + (mapconcat #'shell-quote-argument load-path " -L ") + (shell-quote-argument (format code file)))))))))) (ert-deftest tramp-archive-test45-delay-load () "Check that `tramp-archive' is loaded lazily, only when needed." diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index f4883923f6a..3008861f22b 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -33,7 +33,7 @@ ;; remote host, set this environment variable to "/dev/null" or ;; whatever is appropriate on your system. -;; For slow remote connections, `tramp-test43-asynchronous-requests' +;; For slow remote connections, `tramp-test44-asynchronous-requests' ;; might be too heavy. Setting $REMOTE_PARALLEL_PROCESSES to a proper ;; value less than 10 could help. @@ -59,9 +59,12 @@ (declare-function tramp-get-remote-perl "tramp-sh") (declare-function tramp-get-remote-stat "tramp-sh") (declare-function tramp-list-tramp-buffers "tramp-cmds") +(declare-function tramp-method-out-of-band-p "tramp-sh") (declare-function tramp-smb-get-localname "tramp-smb") (defvar ange-ftp-make-backup-files) (defvar auto-save-file-name-transforms) +(defvar lock-file-name-transforms) +(defvar remote-file-name-inhibit-locks) (defvar tramp-connection-properties) (defvar tramp-copy-size-limit) (defvar tramp-display-escape-sequence-regexp) @@ -121,6 +124,7 @@ (setq auth-source-save-behavior nil password-cache-expiry nil remote-file-name-inhibit-cache nil + tramp-allow-unsafe-temporary-files t tramp-cache-read-persistent-data t ;; For auth-sources. tramp-copy-size-limit nil tramp-persistency-file-name nil @@ -178,6 +182,11 @@ The temporary file is not created." "Whether `tramp--test-instrument-test-case' run. This shall used dynamically bound only.") +;; When `tramp-verbose' is greater than 10, and you want to trace +;; other functions as well, do something like +;; (let ((tramp-trace-functions '(file-name-non-special))) +;; (tramp--test-instrument-test-case 11 +;; ...)) (defmacro tramp--test-instrument-test-case (verbose &rest body) "Run BODY with `tramp-verbose' equal VERBOSE. Print the content of the Tramp connection and debug buffers, if @@ -186,31 +195,22 @@ is greater than 10. `should-error' is not handled properly. BODY shall not contain a timeout." (declare (indent 1) (debug (natnump body))) `(let* ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0))) - (trace-buffer - (when (> tramp-verbose 10) (generate-new-buffer " *temp*"))) + (trace-buffer (tramp-trace-buffer-name tramp-test-vec)) (debug-ignored-errors (append '("^make-symbolic-link not supported$" "^error with add-name-to-file") debug-ignored-errors)) inhibit-message) - (when trace-buffer - (dolist (elt (all-completions "tramp-" obarray 'functionp)) - (trace-function-background (intern elt)))) (unwind-protect (let ((tramp--test-instrument-test-case-p t)) ,@body) ;; Unwind forms. - (when trace-buffer - (untrace-all)) (when (and (null tramp--test-instrument-test-case-p) (> tramp-verbose 3)) - (dolist - (buf (if trace-buffer - (cons (get-buffer trace-buffer) (tramp-list-tramp-buffers)) - (tramp-list-tramp-buffers))) + (untrace-all) + (dolist (buf (tramp-list-tramp-buffers)) (with-current-buffer buf - (message ";; %s\n%s" buf (buffer-string))))) - (when trace-buffer - (kill-buffer trace-buffer))))) + (message ";; %s\n%s" buf (buffer-string))) + (kill-buffer buf)))))) (defsubst tramp--test-message (fmt-string &rest arguments) "Emit a message into ERT *Messages*." @@ -232,6 +232,16 @@ is greater than 10. "%s %f sec" ,message (float-time (time-subtract (current-time) start)))))) +;; `always' is introduced with Emacs 28.1. +(defalias 'tramp--test-always + (if (fboundp 'always) + #'always + (lambda (&rest _arguments) + "Do nothing and return t. +This function accepts any number of ARGUMENTS, but ignores them. +Also see `ignore'." + t))) + (ert-deftest tramp-test00-availability () "Test availability of Tramp functions." :expected-result (if (tramp--test-enabled) :passed :failed) @@ -2182,6 +2192,16 @@ is greater than 10. (expand-file-name ".." "./")) (concat (file-remote-p tramp-test-temporary-file-directory) "/")))) +(ert-deftest tramp-test05-expand-file-name-top () + "Check `expand-file-name'." + (skip-unless (tramp--test-enabled)) + (skip-unless (not (tramp--test-ange-ftp-p))) + + (let ((dir (concat (file-remote-p tramp-test-temporary-file-directory) "/"))) + (dolist (local '("." "..")) + (should (string-equal (expand-file-name local dir) dir)) + (should (string-equal (expand-file-name (concat dir local)) dir))))) + (ert-deftest tramp-test06-directory-file-name () "Check `directory-file-name'. This checks also `file-name-as-directory', `file-name-directory', @@ -2446,10 +2466,13 @@ This checks also `file-name-as-directory', `file-name-directory', "^\\'") tramp--test-messages)))))))) + ;; We do not test lockname here. See + ;; `tramp-test39-make-lock-file-name'. + ;; Do not overwrite if excluded. - (cl-letf (((symbol-function #'y-or-n-p) (lambda (_prompt) t)) + (cl-letf (((symbol-function #'y-or-n-p) #'tramp--test-always) ;; Ange-FTP. - ((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) + ((symbol-function 'yes-or-no-p) #'tramp--test-always)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) ;; `mustbenew' is passed to Tramp since Emacs 26.1. (when (tramp--test-emacs26-p) @@ -2814,9 +2837,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (should (file-exists-p (expand-file-name "bla" tmp-name2))) (should-error (delete-directory tmp-name1 nil 'trash) - ;; tramp-rclone.el calls the local `delete-directory'. - ;; This raises another error. - :type (if (tramp--test-rclone-p) 'error 'file-error)) + ;; tramp-rclone.el and tramp-sshfs.el call the local + ;; `delete-directory'. This raises another error. + :type (if (tramp--test-fuse-p) 'error 'file-error)) (delete-directory tmp-name1 'recursive 'trash) (should-not (file-directory-p tmp-name1)) (should @@ -3244,8 +3267,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (ignore-errors (delete-directory tmp-name1 'recursive)))))) ;; Method "smb" supports `make-symbolic-link' only if the remote host -;; has CIFS capabilities. tramp-adb.el, tramp-gvfs.el and -;; tramp-rclone.el do not support symbolic links at all. +;; has CIFS capabilities. tramp-adb.el, tramp-gvfs.el, tramp-rclone.el +;; and tramp-sshfs.el do not support symbolic links at all. (defmacro tramp--test-ignore-make-symbolic-link-error (&rest body) "Run BODY, ignoring \"make-symbolic-link not supported\" file error." (declare (indent defun) (debug (body))) @@ -3526,7 +3549,7 @@ They might differ only in time attributes or directory size." This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (skip-unless (tramp--test-enabled)) (skip-unless - (or (tramp--test-sh-p) (tramp--test-sudoedit-p) + (or (tramp--test-sh-p) (tramp--test-sshfs-p) (tramp--test-sudoedit-p) ;; Not all tramp-gvfs.el methods support changing the file mode. (and (tramp--test-gvfs-p) @@ -3663,7 +3686,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should-error (make-symbolic-link tmp-name1 tmp-name2 0) :type 'file-already-exists))) - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) #'tramp--test-always)) (make-symbolic-link tmp-name1 tmp-name2 0) (should (string-equal @@ -3739,7 +3762,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should-error (add-name-to-file tmp-name1 tmp-name2 0) :type 'file-already-exists)) - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) #'tramp--test-always)) (add-name-to-file tmp-name1 tmp-name2 0) (should (file-regular-p tmp-name2))) (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) @@ -4073,7 +4096,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) (should (file-selinux-context tmp-name1)) - (copy-file tmp-name1 tmp-name2) + (copy-file tmp-name1 tmp-name2 nil nil nil 'preserve-permissions) (should (file-selinux-context tmp-name2)) (should (equal @@ -4357,11 +4380,15 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (and (featurep 'tramp-test-load) (unload-feature 'tramp-test-load)) (delete-file tmp-name)))))) +(defun tramp--test-shell-file-name () + "Return default remote shell." + (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) + (ert-deftest tramp-test28-process-file () "Check `process-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) @@ -4378,25 +4405,27 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should-not (zerop (process-file "binary-does-not-exist"))) ;; Return exit code. (should (= 42 (process-file - (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") + (tramp--test-shell-file-name) nil nil nil "-c" "exit 42"))) ;; Return exit code in case the process is interrupted, ;; and there's no indication for a signal describing string. - (let (process-file-return-signal-string) - (should - (= (+ 128 2) - (process-file - (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") - nil nil nil "-c" "kill -2 $$")))) + (unless (tramp--test-sshfs-p) + (let (process-file-return-signal-string) + (should + (= (+ 128 2) + (process-file + (tramp--test-shell-file-name) + nil nil nil "-c" "kill -2 $$"))))) ;; Return string in case the process is interrupted and ;; there's an indication for a signal describing string. - (let ((process-file-return-signal-string t)) - (should - (string-match-p - "Interrupt\\|Signal 2" - (process-file - (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") - nil nil nil "-c" "kill -2 $$")))) + (unless (tramp--test-sshfs-p) + (let ((process-file-return-signal-string t)) + (should + (string-match-p + "Interrupt\\|Signal 2" + (process-file + (tramp--test-shell-file-name) + nil nil nil "-c" "kill -2 $$"))))) (with-temp-buffer (write-region "foo" nil tmp-name) @@ -4440,7 +4469,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `start-file-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) @@ -4531,7 +4560,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." If UNSTABLE is non-nil, the test is tagged as `:unstable'." (declare (indent 1)) ;; `make-process' supports file name handlers since Emacs 27. - (when (let ((file-name-handler-alist '(("" . (lambda (&rest _) t))))) + (when (let ((file-name-handler-alist '(("" . #'tramp--test-always)))) (ignore-errors (make-process :file-handler t))) `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) () ,docstring @@ -4547,7 +4576,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; `file-truename' does it by side-effect. Suppress ;; `tramp--test-enabled', in order to keep the connection. ;; Suppress "Process ... finished" messages. - (cl-letf (((symbol-function #'tramp--test-enabled) (lambda nil t)) + (cl-letf (((symbol-function #'tramp--test-enabled) #'tramp--test-always) ((symbol-function #'internal-default-process-sentinel) #'ignore)) (file-truename tramp-test-temporary-file-directory) @@ -4560,15 +4589,14 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." "Check `make-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) ;; `make-process' supports file name handlers since Emacs 27. (skip-unless (tramp--test-emacs27-p)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) - (tmp-name1 (tramp--test-make-temp-name nil quoted)) - (tmp-name2 (tramp--test-make-temp-name 'local quoted)) + (tmp-name (tramp--test-make-temp-name nil quoted)) kill-buffer-query-functions proc) (with-no-warnings (should-not (make-process))) @@ -4596,13 +4624,13 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Simple process using a file. (unwind-protect (with-temp-buffer - (write-region "foo" nil tmp-name1) - (should (file-exists-p tmp-name1)) + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) (setq proc (with-no-warnings (make-process :name "test2" :buffer (current-buffer) - :command `("cat" ,(file-name-nondirectory tmp-name1)) + :command `("cat" ,(file-name-nondirectory tmp-name)) :file-handler t))) (should (processp proc)) ;; Read output. @@ -4614,7 +4642,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc) - (delete-file tmp-name1))) + (delete-file tmp-name))) ;; Process filter. (unwind-protect @@ -4678,11 +4706,17 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." :stderr stderr :file-handler t))) (should (processp proc)) - ;; Read stderr. + ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) (while (accept-process-output proc 0 nil t))) - (delete-process proc) + ;; Read stderr. (with-current-buffer stderr + (with-timeout (10 (tramp--test-timeout-handler)) + (while (not (string-match-p + "No such file or directory" (buffer-string))) + (while (accept-process-output + (get-buffer-process stderr) 0 nil t)))) + (delete-process proc) (should (string-match-p "cat:.* No such file or directory" (buffer-string))))) @@ -4693,30 +4727,67 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Process with stderr file. (unless (tramp-direct-async-process-p) - (dolist (tmpfile `(,tmp-name1 ,tmp-name2)) + (unwind-protect + (with-temp-buffer + (setq proc + (with-no-warnings + (make-process + :name "test6" :buffer (current-buffer) + :command '("cat" "/does-not-exist") + :stderr tmp-name + :file-handler t))) + (should (processp proc)) + ;; Read stderr. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc nil nil t))) + (delete-process proc) + (with-temp-buffer + (insert-file-contents tmp-name) + (should + (string-match-p + "cat:.* No such file or directory" (buffer-string))))) + + ;; Cleanup. + (ignore-errors (delete-process proc)) + (ignore-errors (delete-file tmp-name)))) + + ;; Process connection type. + (when (and (tramp--test-sh-p) + ;; `executable-find' has changed the number of + ;; parameters in Emacs 27.1, so we use `apply' for + ;; older Emacsen. + (ignore-errors + (with-no-warnings + (apply #'executable-find '("hexdump" remote))))) + (dolist (connection-type '(nil pipe t pty)) (unwind-protect (with-temp-buffer (setq proc (with-no-warnings (make-process - :name "test6" :buffer (current-buffer) - :command '("cat" "/does-not-exist") - :stderr tmpfile + :name (format "test7-%s" connection-type) + :buffer (current-buffer) + :connection-type connection-type + :command '("hexdump" "-v" "-e" "/1 \"%02X\n\"") :file-handler t))) (should (processp proc)) - ;; Read stderr. + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo\r\n") + (process-send-eof proc) + ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output proc nil nil t))) - (delete-process proc) - (with-temp-buffer - (insert-file-contents tmpfile) - (should - (string-match-p - "cat:.* No such file or directory" (buffer-string))))) + (while (< (- (point-max) (point-min)) + (length "66\n6F\n6F\n0D\n0A\n")) + (while (accept-process-output proc 0 nil t)))) + (should + (string-match-p + (if (memq connection-type '(nil pipe)) + "66\n6F\n6F\n0D\n0A\n" + "66\n6F\n6F\n0A\n0A\n") + (buffer-string)))) ;; Cleanup. - (ignore-errors (delete-process proc)) - (ignore-errors (delete-file tmpfile)))))))) + (ignore-errors (delete-process proc)))))))) (tramp--test--deftest-direct-async-process tramp-test30-make-process "Check direct async `make-process'.") @@ -4788,7 +4859,7 @@ INPUT, if non-nil, is a string sent to the process." ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) - (tramp--test-sh-p))) + (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) @@ -4887,7 +4958,7 @@ INPUT, if non-nil, is a string sent to the process." :tags '(:expensive-test :unstable) (skip-unless (tramp--test-enabled)) (skip-unless nil) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) ;; Prior Emacs 27, `shell-command-dont-erase-buffer' wasn't working properly. (skip-unless (tramp--test-emacs27-p)) @@ -5092,8 +5163,10 @@ INPUT, if non-nil, is a string sent to the process." (string-match-p (regexp-quote envvar) ;; We must remove PS1, the output is truncated otherwise. + ;; We must suppress "_=VAR...". (funcall - this-shell-command-to-string "printenv | grep -v PS1"))))))))) + this-shell-command-to-string + "printenv | grep -v PS1 | grep -v _="))))))))) (tramp--test--deftest-direct-async-process tramp-test33-environment-variables "Check that remote processes set / unset environment variables properly. @@ -5210,7 +5283,7 @@ Use direct async.") ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) - (tramp--test-sh-p))) + (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. (skip-unless (and (fboundp 'connection-local-set-profile-variables) @@ -5232,8 +5305,7 @@ Use direct async.") (with-no-warnings (connection-local-set-profile-variables 'remote-sh - `((explicit-shell-file-name - . ,(if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) + `((explicit-shell-file-name . ,(tramp--test-shell-file-name)) (explicit-sh-args . ("-c" "echo foo")))) (connection-local-set-profiles `(:application tramp @@ -5267,7 +5339,7 @@ Use direct async.") (ert-deftest tramp-test35-exec-path () "Check `exec-path' and `executable-find'." (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 27.1. (skip-unless (fboundp 'exec-path)) @@ -5451,7 +5523,8 @@ Use direct async.") (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))) + (tmp-name2 (tramp--test-make-temp-name nil quoted)) + tramp-allow-unsafe-temporary-files) (unwind-protect (progn @@ -5535,11 +5608,37 @@ Use direct async.") ("]" . "_r")) (tramp-compat-file-name-unquote tmp-name1))) tmp-name2))) - (should (file-directory-p tmp-name2)))))) + (should (file-directory-p tmp-name2))))) + + ;; Create temporary file. This shall check for sensible + ;; files, owned by root. + (let ((tramp-auto-save-directory temporary-file-directory)) + (write-region "foo" nil tmp-name1) + (when (zerop (or (tramp-compat-file-attribute-user-id + (file-attributes tmp-name1)) + tramp-unknown-id-integer)) + (with-temp-buffer + (setq buffer-file-name tmp-name1) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (let ((tramp-allow-unsafe-temporary-files t)) + (should (stringp (make-auto-save-file-name)))) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) + (should-error + (make-auto-save-file-name) + :type 'file-error)) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'yes-or-no-p) + #'tramp--test-always)) + (should (stringp (make-auto-save-file-name)))))))) ;; Cleanup. (ignore-errors (delete-file tmp-name1)) - (ignore-errors (delete-directory tmp-name2 'recursive)))))) + (ignore-errors (delete-directory tmp-name2 'recursive)) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password))))) (ert-deftest tramp-test38-find-backup-file-name () "Check `find-backup-file-name'." @@ -5549,6 +5648,7 @@ Use direct async.") (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) + tramp-allow-unsafe-temporary-files ;; 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)) @@ -5653,10 +5753,175 @@ Use direct async.") (should (file-directory-p tmp-name2)))) ;; Cleanup. - (ignore-errors (delete-directory tmp-name2 'recursive)))))) + (ignore-errors (delete-directory tmp-name2 'recursive))) + + (unwind-protect + ;; Create temporary file. This shall check for sensible + ;; files, owned by root. + (let ((backup-directory-alist `(("." . ,temporary-file-directory))) + tramp-backup-directory-alist) + (write-region "foo" nil tmp-name1) + (when (zerop (or (tramp-compat-file-attribute-user-id + (file-attributes tmp-name1)) + tramp-unknown-id-integer)) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (let ((tramp-allow-unsafe-temporary-files t)) + (should (stringp (car (find-backup-file-name tmp-name1))))) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) + (should-error + (find-backup-file-name tmp-name1) + :type 'file-error)) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'yes-or-no-p) + #'tramp--test-always)) + (should (stringp (car (find-backup-file-name tmp-name1))))))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password))))) + +;; The functions were introduced in Emacs 28.1. +(ert-deftest tramp-test39-make-lock-file-name () + "Check `make-lock-file-name', `lock-file', `unlock-file' and `file-locked-p'." + (skip-unless (tramp--test-enabled)) + (skip-unless (not (tramp--test-ange-ftp-p))) + ;; Since Emacs 28.1. + (skip-unless (and (fboundp 'lock-file) (fboundp 'unlock-file))) + (skip-unless (and (fboundp 'file-locked-p) (fboundp 'make-lock-file-name))) + + ;; `lock-file', `unlock-file', `file-locked-p' and + ;; `make-lock-file-name' exists since Emacs 28.1. We don't want to + ;; see compiler warnings for older Emacsen. + (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)) + (remote-file-name-inhibit-cache t) + (remote-file-name-inhibit-locks nil) + (create-lockfiles t) + tramp-allow-unsafe-temporary-files + (inhibit-message t) + ;; tramp-rclone.el and tramp-sshfs.el cache the mounted files. + (tramp-cleanup-connection-hook + (append + (and (tramp--test-fuse-p) '(tramp-fuse-unmount)) + tramp-cleanup-connection-hook)) + auto-save-default + noninteractive) + + (unwind-protect + (progn + ;; A simple file lock. + (should-not (with-no-warnings (file-locked-p tmp-name1))) + (with-no-warnings (lock-file tmp-name1)) + (should (eq (with-no-warnings (file-locked-p tmp-name1)) t)) + + ;; If it is locked already, nothing changes. + (with-no-warnings (lock-file tmp-name1)) + (should (eq (with-no-warnings (file-locked-p tmp-name1)) t)) + + ;; `save-buffer' removes the lock. + (with-temp-buffer + (set-visited-file-name tmp-name1) + (insert "foo") + (save-buffer)) + (should-not (with-no-warnings (file-locked-p tmp-name1))) + (with-no-warnings (lock-file tmp-name1)) + (should (eq (with-no-warnings (file-locked-p tmp-name1)) t)) + + ;; A new connection changes process id, and also the + ;; lockname contents. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (should (stringp (with-no-warnings (file-locked-p tmp-name1)))) + + ;; When `remote-file-name-inhibit-locks' is set, nothing happens. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (let ((remote-file-name-inhibit-locks t)) + (with-no-warnings (lock-file tmp-name1)) + (should-not (with-no-warnings (file-locked-p tmp-name1)))) + + ;; When `lock-file-name-transforms' is set, another lock + ;; file is used. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (let ((lock-file-name-transforms `((".*" ,tmp-name2)))) + (should + (string-equal + (with-no-warnings (make-lock-file-name tmp-name1)) + (with-no-warnings (make-lock-file-name tmp-name2)))) + (with-no-warnings (lock-file tmp-name1)) + (should (eq (with-no-warnings (file-locked-p tmp-name1)) t)) + (with-no-warnings (unlock-file tmp-name1)) + (should-not (with-no-warnings (file-locked-p tmp-name1)))) + + ;; Steal the file lock. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?s))) + (with-no-warnings (lock-file tmp-name1))) + (should (eq (with-no-warnings (file-locked-p tmp-name1)) t)) + + ;; Ignore the file lock. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?p))) + (with-no-warnings (lock-file tmp-name1))) + (should (stringp (with-no-warnings (file-locked-p tmp-name1)))) + + ;; Quit the file lock machinery. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?q))) + (with-no-warnings + (should-error + (lock-file tmp-name1) + :type 'file-locked)) + ;; The same for `write-region'. + (should-error + (write-region "foo" nil tmp-name1) + :type 'file-locked) + (should-error + (write-region "foo" nil tmp-name1 nil nil tmp-name1) + :type 'file-locked) + ;; The same for `set-visited-file-name'. + (with-temp-buffer + (should-error + (set-visited-file-name tmp-name1) + :type 'file-locked))) + (should (stringp (with-no-warnings (file-locked-p tmp-name1))))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (with-no-warnings (unlock-file tmp-name1)) + (with-no-warnings (unlock-file tmp-name2)) + (should-not (with-no-warnings (file-locked-p tmp-name1))) + (should-not (with-no-warnings (file-locked-p tmp-name2)))) + + (unwind-protect + ;; Create temporary file. This shall check for sensible + ;; files, owned by root. + (let ((lock-file-name-transforms auto-save-file-name-transforms)) + (write-region "foo" nil tmp-name1) + (when (zerop (or (tramp-compat-file-attribute-user-id + (file-attributes tmp-name1)) + tramp-unknown-id-integer)) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) + (should-error + (write-region "foo" nil tmp-name1) + :type 'file-error)) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'yes-or-no-p) + #'tramp--test-always)) + (write-region "foo" nil tmp-name1)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password))))) ;; The functions were introduced in Emacs 26.1. -(ert-deftest tramp-test39-make-nearby-temp-file () +(ert-deftest tramp-test40-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))) @@ -5739,6 +6004,10 @@ This does not support globbing characters in file names (yet)." (string-match-p "ftp$" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-fuse-p () + "Check, whether an FUSE file system isused." + (or (tramp--test-rclone-p) (tramp--test-sshfs-p))) + (defun tramp--test-gdrive-p () "Check, whether the gdrive method is used." (string-equal @@ -5807,6 +6076,11 @@ Additionally, ls does not support \"--dired\"." "^\\(afp\\|davs?\\|smb\\)$" (file-remote-p tramp-test-temporary-file-directory 'method)))) +(defun tramp--test-sshfs-p () + "Check, whether the remote host is offered by sshfs. +This requires restrictions of file name syntax." + (tramp-sshfs-file-name-p tramp-test-temporary-file-directory)) + (defun tramp--test-sudoedit-p () "Check, whether the sudoedit method is used." (tramp-sudoedit-file-name-p tramp-test-temporary-file-directory)) @@ -5815,18 +6089,11 @@ Additionally, ls does not support \"--dired\"." "Check, whether the locale host runs MS Windows." (eq system-type 'windows-nt)) -(defun tramp--test-windows-nt-and-batch-p () - "Check, whether the locale host runs MS Windows in batch mode. -This does not support special characters." - (and (eq system-type 'windows-nt) noninteractive)) - -(defun tramp--test-windows-nt-and-pscp-psftp-p () - "Check, whether the locale host runs MS Windows, and ps{cp,ftp} is used. +(defun tramp--test-windows-nt-and-out-of-band-p () + "Check, whether the locale host runs MS Windows and an out-of-band method. This does not support utf8 based file transfer." (and (eq system-type 'windows-nt) - (string-match-p - (regexp-opt '("pscp" "psftp")) - (file-remote-p tramp-test-temporary-file-directory 'method)))) + (tramp-method-out-of-band-p tramp-test-vec 1))) (defun tramp--test-windows-nt-or-smb-p () "Check, whether the locale or remote host runs MS Windows. @@ -5851,7 +6118,9 @@ This requires restrictions of file name syntax." (file-truename tramp-test-temporary-file-directory)) (tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name 'local quoted)) - (files (delq nil files)) + (files + (delq + nil (mapcar (lambda (x) (unless (string-empty-p x) x)) files))) (process-environment process-environment) (sorted-files (sort (copy-sequence files) #'string-lessp)) buffer) @@ -5861,6 +6130,7 @@ This requires restrictions of file name syntax." (make-directory tmp-name2) (dolist (elt files) + ;(tramp--test-message "'%s'" elt) (let* ((file1 (expand-file-name elt tmp-name1)) (file2 (expand-file-name elt tmp-name2)) (file3 (expand-file-name (concat elt "foo") tmp-name1))) @@ -6028,7 +6298,7 @@ This requires restrictions of file name syntax." (ignore-errors (delete-directory tmp-name2 'recursive)))))) (defun tramp--test-special-characters () - "Perform the test in `tramp-test40-special-characters*'." + "Perform the test in `tramp-test41-special-characters*'." ;; Newlines, slashes and backslashes in file names are not ;; supported. So we don't test. And we don't test the tab ;; character on Windows or Cygwin, because the backslash is @@ -6050,9 +6320,9 @@ This requires restrictions of file name syntax." "\tfoo bar baz\t") (t " foo\tbar baz\t")) "@foo@bar@baz@" - "$foo$bar$$baz$" + (unless (tramp--test-windows-nt-and-out-of-band-p) "$foo$bar$$baz$") "-foo-bar-baz-" - "%foo%bar%baz%" + (unless (tramp--test-windows-nt-and-out-of-band-p) "%foo%bar%baz%") "&foo&bar&baz&" (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p) @@ -6066,9 +6336,10 @@ This requires restrictions of file name syntax." "'foo'bar'baz'" "'foo\"bar'baz\"") "#foo~bar#baz~" - (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) - "!foo!bar!baz!" - "!foo|bar!baz|") + (unless (tramp--test-windows-nt-and-out-of-band-p) + (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) + "!foo!bar!baz!" + "!foo|bar!baz|")) (if (or (tramp--test-gvfs-p) (tramp--test-rclone-p) (tramp--test-windows-nt-or-smb-p)) @@ -6085,24 +6356,21 @@ This requires restrictions of file name syntax." files (list (mapconcat #'identity files "")))))) ;; These tests are inspired by Bug#17238. -(ert-deftest tramp-test40-special-characters () +(ert-deftest tramp-test41-special-characters () "Check special characters in file names." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) (tramp--test-special-characters)) -(ert-deftest tramp-test40-special-characters-with-stat () +(ert-deftest tramp-test41-special-characters-with-stat () "Check special characters in file names. Use the `stat' command." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -6114,15 +6382,13 @@ Use the `stat' command." tramp-connection-properties))) (tramp--test-special-characters))) -(ert-deftest tramp-test40-special-characters-with-perl () +(ert-deftest tramp-test41-special-characters-with-perl () "Check special characters in file names. Use the `perl' command." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -6137,15 +6403,13 @@ Use the `perl' command." tramp-connection-properties))) (tramp--test-special-characters))) -(ert-deftest tramp-test40-special-characters-with-ls () +(ert-deftest tramp-test41-special-characters-with-ls () "Check special characters in file names. Use the `ls' command." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) (let ((tramp-connection-properties (append @@ -6160,7 +6424,7 @@ Use the `ls' command." (tramp--test-special-characters))) (defun tramp--test-utf8 () - "Perform the test in `tramp-test41-utf8*'." + "Perform the test in `tramp-test42-utf8*'." (let* ((utf8 (if (and (eq system-type 'darwin) (memq 'utf-8-hfs (coding-system-list))) 'utf-8-hfs 'utf-8)) @@ -6201,17 +6465,17 @@ Use the `ls' command." x "")) (not (string-empty-p x)) ;; ?\n and ?/ shouldn't be part of any file name. ?\t, - ;; ?. and ?? do not work for "smb" method. - (replace-regexp-in-string "[\t\n/.?]" "" x))) + ;; ?. and ?? do not work for "smb" method. " " does not + ;; work at begin or end of the string for MS Windows. + (replace-regexp-in-string "[ \t\n/.?]" "" x))) language-info-alist))))))) -(ert-deftest tramp-test41-utf8 () +(ert-deftest tramp-test42-utf8 () "Check UTF8 encoding in file names and file contents." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-gdrive-p))) (skip-unless (not (tramp--test-crypt-p))) @@ -6219,7 +6483,7 @@ Use the `ls' command." (tramp--test-utf8)) -(ert-deftest tramp-test41-utf8-with-stat () +(ert-deftest tramp-test42-utf8-with-stat () "Check UTF8 encoding in file names and file contents. Use the `stat' command." :tags '(:expensive-test) @@ -6227,11 +6491,9 @@ Use the `stat' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -6243,7 +6505,7 @@ Use the `stat' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test41-utf8-with-perl () +(ert-deftest tramp-test42-utf8-with-perl () "Check UTF8 encoding in file names and file contents. Use the `perl' command." :tags '(:expensive-test) @@ -6251,11 +6513,9 @@ Use the `perl' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -6270,7 +6530,7 @@ Use the `perl' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test41-utf8-with-ls () +(ert-deftest tramp-test42-utf8-with-ls () "Check UTF8 encoding in file names and file contents. Use the `ls' command." :tags '(:expensive-test) @@ -6278,11 +6538,9 @@ Use the `ls' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) (let ((tramp-connection-properties (append @@ -6296,7 +6554,7 @@ Use the `ls' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test42-file-system-info () +(ert-deftest tramp-test43-file-system-info () "Check that `file-system-info' returns proper values." (skip-unless (tramp--test-enabled)) ;; Since Emacs 27.1. @@ -6313,16 +6571,17 @@ Use the `ls' command." (numberp (nth 1 fsi)) (numberp (nth 2 fsi)))))) -;; `tramp-test43-asynchronous-requests' could be blocked. So we set a +;; `tramp-test44-asynchronous-requests' could be blocked. So we set a ;; timeout of 300 seconds, and we send a SIGUSR1 signal after 300 ;; seconds. Similar check is performed in the timer function. (defconst tramp--test-asynchronous-requests-timeout 300 - "Timeout for `tramp-test43-asynchronous-requests'.") + "Timeout for `tramp-test44-asynchronous-requests'.") (defmacro tramp--test-with-proper-process-name-and-buffer (proc &rest body) "Set \"process-name\" and \"process-buffer\" connection properties. The values are derived from PROC. Run BODY. This is needed in timer functions as well as process filters and sentinels." + ;; FIXME: For tramp-sshfs.el, `processp' does not work. (declare (indent 1) (debug (processp body))) `(let* ((v (tramp-get-connection-property ,proc "vector" nil)) (pname (tramp-get-connection-property v "process-name" nil)) @@ -6352,7 +6611,7 @@ This is needed in timer functions as well as process filters and sentinels." (tramp-flush-connection-property v "process-buffer"))))) ;; This test is inspired by Bug#16928. -(ert-deftest tramp-test43-asynchronous-requests () +(ert-deftest tramp-test44-asynchronous-requests () "Check parallel asynchronous requests. Such requests could arrive from timers, process filters and process sentinels. They shall not disturb each other." @@ -6372,7 +6631,7 @@ process sentinels. They shall not disturb each other." (define-key special-event-map [sigusr1] #'tramp--test-timeout-handler) (let* (;; For the watchdog. (default-directory (expand-file-name temporary-file-directory)) - (shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) + (shell-file-name (tramp--test-shell-file-name)) ;; It doesn't work on w32 systems. (watchdog (start-process-shell-command @@ -6552,11 +6811,11 @@ process sentinels. They shall not disturb each other." (ignore-errors (cancel-timer timer)) (ignore-errors (delete-directory tmp-name 'recursive)))))) -;; (tramp--test--deftest-direct-async-process tramp-test43-asynchronous-requests +;; (tramp--test--deftest-direct-async-process tramp-test44-asynchronous-requests ;; "Check parallel direct asynchronous requests." 'unstable) ;; This test is inspired by Bug#29163. -(ert-deftest tramp-test44-auto-load () +(ert-deftest tramp-test45-auto-load () "Check that Tramp autoloads properly." ;; If we use another syntax but `default', Tramp is already loaded ;; due to the `tramp-change-syntax' call. @@ -6581,7 +6840,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test44-delay-load () +(ert-deftest tramp-test45-delay-load () "Check that Tramp is loaded lazily, only when needed." ;; The autoloaded Tramp objects are different since Emacs 26.1. We ;; cannot test older Emacsen, therefore. @@ -6614,7 +6873,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument (format code tm))))))))) -(ert-deftest tramp-test44-recursive-load () +(ert-deftest tramp-test45-recursive-load () "Check that Tramp does not fail due to recursive load." (skip-unless (tramp--test-enabled)) @@ -6638,7 +6897,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code)))))))) -(ert-deftest tramp-test44-remote-load-path () +(ert-deftest tramp-test45-remote-load-path () "Check that Tramp autoloads its packages with remote `load-path'." ;; The autoloaded Tramp objects are different since Emacs 26.1. We ;; cannot test older Emacsen, therefore. @@ -6667,7 +6926,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test45-unload () +(ert-deftest tramp-test46-unload () "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) @@ -6730,8 +6989,8 @@ Since it unloads Tramp, it shall be the last test to run." If INTERACTIVE is non-nil, the tests are run interactively." (interactive "p") (funcall - (if interactive - #'ert-run-tests-interactively #'ert-run-tests-batch) "^tramp")) + (if interactive #'ert-run-tests-interactively #'ert-run-tests-batch) + "^tramp")) ;; TODO: @@ -6747,9 +7006,10 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * Work on skipped tests. Make a comment, when it is impossible. ;; * Revisit expensive tests, once problems in `tramp-error' are solved. ;; * Fix `tramp-test06-directory-file-name' for `ftp'. -;; * Implement `tramp-test31-interrupt-process' for `adb' and for -;; direct async processes. -;; * Fix `tramp-test44-threads'. +;; * Implement `tramp-test31-interrupt-process' for `adb', `sshfs' and +;; for direct async processes. +;; * Check, why direct async processes do not work for +;; `tramp-test44-asynchronous-requests'. (provide 'tramp-tests) |