diff options
Diffstat (limited to 'test/lisp/net')
| -rw-r--r-- | test/lisp/net/dbus-tests.el | 6 | ||||
| -rw-r--r-- | test/lisp/net/dig-tests.el | 56 | ||||
| -rw-r--r-- | test/lisp/net/gnutls-tests.el | 2 | ||||
| -rw-r--r-- | test/lisp/net/hmac-md5-tests.el | 80 | ||||
| -rw-r--r-- | test/lisp/net/network-stream-tests.el | 52 | ||||
| -rw-r--r-- | test/lisp/net/newsticker-tests.el | 2 | ||||
| -rw-r--r-- | test/lisp/net/puny-tests.el | 23 | ||||
| -rw-r--r-- | test/lisp/net/rfc2104-tests.el | 2 | ||||
| -rw-r--r-- | test/lisp/net/sasl-scram-rfc-tests.el | 26 | ||||
| -rw-r--r-- | test/lisp/net/tramp-archive-tests.el | 2 | ||||
| -rw-r--r-- | test/lisp/net/tramp-tests.el | 1036 | ||||
| -rw-r--r-- | test/lisp/net/webjump-tests.el | 73 |
12 files changed, 1029 insertions, 331 deletions
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 68f69f62b56..45c98513653 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -1,4 +1,4 @@ -;;; dbus-tests.el --- Tests of D-Bus integration into Emacs +;;; dbus-tests.el --- Tests of D-Bus integration into Emacs -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -176,8 +176,8 @@ This includes initialization and closing the bus." (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." (interactive "p") - (funcall - (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^dbus")) + (funcall (if interactive #'ert-run-tests-interactively #'ert-run-tests-batch) + "^dbus")) (provide 'dbus-tests) ;;; dbus-tests.el ends here diff --git a/test/lisp/net/dig-tests.el b/test/lisp/net/dig-tests.el new file mode 100644 index 00000000000..1b14384634e --- /dev/null +++ b/test/lisp/net/dig-tests.el @@ -0,0 +1,56 @@ +;;; dig-tests.el --- Tests for dig.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; 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 +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; 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: + +;;; Code: + +(require 'ert) +(require 'dig) + +(defvar dig-test-result-data " +; <<>> DiG 9.11.16-2-Debian <<>> gnu.org +;; global options: +cmd +;; Got answer: +;; ->>HEADER<<- opcode: QUERY, status: NOERROR, id: 7777 +;; flags: qr rd ra; QUERY: 1, ANSWER: 1, AUTHORITY: 0, ADDITIONAL: 1 + +;; OPT PSEUDOSECTION: +; EDNS: version: 0, flags:; udp: 4096 +;; QUESTION SECTION: +;gnu.org. IN A + +;; ANSWER SECTION: +gnu.org. 300 IN A 111.11.111.111 + +;; Query time: 127 msec +;; SERVER: 192.168.0.1#53(192.168.0.1) +;; WHEN: Sun Apr 26 00:47:55 CEST 2020 +;; MSG SIZE rcvd: 52 + +" "Data used to test dig.el.") + +(ert-deftest dig-test-dig-extract-rr () + (with-temp-buffer + (insert dig-test-result-data) + (should (equal (dig-extract-rr "gnu.org") + "gnu.org. 300 IN A 111.11.111.111")))) + +(provide 'dig-tests) +;;; dig-tests.el ends here diff --git a/test/lisp/net/gnutls-tests.el b/test/lisp/net/gnutls-tests.el index c2472d844c1..07e30b64642 100644 --- a/test/lisp/net/gnutls-tests.el +++ b/test/lisp/net/gnutls-tests.el @@ -1,4 +1,4 @@ -;;; gnutls-tests.el --- Test suite for gnutls.el +;;; gnutls-tests.el --- Test suite for gnutls.el -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. diff --git a/test/lisp/net/hmac-md5-tests.el b/test/lisp/net/hmac-md5-tests.el new file mode 100644 index 00000000000..30d221ec87b --- /dev/null +++ b/test/lisp/net/hmac-md5-tests.el @@ -0,0 +1,80 @@ +;;; hmac-md5-tests.el --- Tests for hmac-md5.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; 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 +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; 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: + +;;; Code: + +(require 'ert) +(require 'hmac-md5) + +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1", +;; moved here from hmac-md5.el + +(ert-deftest hmac-md5-test-encode-string () + ;; RFC 2202 -- test_case 1 + (should (equal (encode-hex-string + (hmac-md5 "Hi There" (make-string 16 ?\x0b))) + "9294727a3638bb1c13f48ef8158bfc9d")) + + ;; RFC 2202 -- test_case 2 + (should (equal (encode-hex-string + (hmac-md5 "what do ya want for nothing?" "Jefe")) + "750c783e6ab0b503eaa86e310a5db738")) + + ;; RFC 2202 -- test_case 3 + (should (equal (encode-hex-string + (hmac-md5 (decode-hex-string (make-string 100 ?d)) + (decode-hex-string (make-string 32 ?a)))) + "56be34521d144c88dbb8c733f0e8b3f6")) + + ;; RFC 2202 -- test_case 4 + (should (equal (encode-hex-string + (hmac-md5 (decode-hex-string + (mapconcat (lambda (c) (concat (list c) "d")) + (make-string 50 ?c) "")) + (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) + "697eaf0aca3a3aea3a75164746ffaa79")) + + ;; RFC 2202 -- test_case 5 (a) + (should (equal (encode-hex-string + (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c))) + "56461ef2342edc00f9bab995690efd4c")) + + ;; RFC 2202 -- test_case 5 (b) + (should (equal (encode-hex-string + (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c))) + "56461ef2342edc00f9bab995")) + + ;; RFC 2202 -- test_case 6 + (should (equal (encode-hex-string + (hmac-md5 + "Test Using Larger Than Block-Size Key - Hash Key First" + (decode-hex-string (make-string 160 ?a)))) + "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd")) + + ;; RFC 2202 -- test_case 7 + (should (equal (encode-hex-string + (hmac-md5 + "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" + (decode-hex-string (make-string 160 ?a)))) + "6f630fad67cda0ee1fb1f562db3aa53e"))) + +(provide 'hmac-md5-tests) +;;; hmac-md5-tests.el ends here diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 28686547a44..7a982548ae1 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -724,4 +724,56 @@ 44777 (vector :nowait t)))) +(ert-deftest check-network-process-coding-system-bind () + "Check that binding coding-system-for-{read,write} works." + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'utf-8-unix) + (server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :host 'local)) + (coding (process-coding-system server))) + (should (eq (car coding) 'binary)) + (should (eq (cdr coding) 'utf-8-unix)) + (delete-process server))) + +(ert-deftest check-network-process-coding-system-no-override () + "Check that coding-system-for-{read,write} is not overridden by :coding nil." + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'utf-8-unix) + (server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :coding nil + :host 'local)) + (coding (process-coding-system server))) + (should (eq (car coding) 'binary)) + (should (eq (cdr coding) 'utf-8-unix)) + (delete-process server))) + +(ert-deftest check-network-process-coding-system-override () + "Check that :coding non-nil overrides coding-system-for-{read,write}." + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'utf-8-unix) + (server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :coding 'georgian-academy + :host 'local)) + (coding (process-coding-system server))) + (should (eq (car coding) 'georgian-academy)) + (should (eq (cdr coding) 'georgian-academy)) + (delete-process server))) ;;; network-stream-tests.el ends here diff --git a/test/lisp/net/newsticker-tests.el b/test/lisp/net/newsticker-tests.el index 1a6e11dc512..5552fa8c1a6 100644 --- a/test/lisp/net/newsticker-tests.el +++ b/test/lisp/net/newsticker-tests.el @@ -1,4 +1,4 @@ -;;; newsticker-testsuite.el --- Test suite for newsticker. +;;; newsticker-tests.el --- Test suite for newsticker. -*- lexical-binding:t -*- ;; Copyright (C) 2003-2020 Free Software Foundation, Inc. diff --git a/test/lisp/net/puny-tests.el b/test/lisp/net/puny-tests.el index 9fb2ebb5469..7dac39795b6 100644 --- a/test/lisp/net/puny-tests.el +++ b/test/lisp/net/puny-tests.el @@ -1,4 +1,4 @@ -;;; puny-tests.el --- tests for net/puny.el -*- coding: utf-8; -*- +;;; puny-tests.el --- tests for net/puny.el -*- coding: utf-8; lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. @@ -38,4 +38,25 @@ "Test puny decoding." (should (string= (puny-decode-string "xn--9dbdkw") "חנוך"))) +(ert-deftest puny-test-encode-domain () + (should (string= (puny-encode-domain "åäö.se") "xn--4cab6c.se"))) + +(ert-deftest puny-test-decode-domain () + (should (string= (puny-decode-domain "xn--4cab6c.se") "åäö.se"))) + +(ert-deftest puny-highly-restrictive-domain-p () + (should (puny-highly-restrictive-domain-p "foo.bar.org")) + (should (puny-highly-restrictive-domain-p "foo.abcåäö.org")) + (should (puny-highly-restrictive-domain-p "foo.ர.org")) + ;; Disallow unicode character 2044, visually similar to "/". + (should-not (puny-highly-restrictive-domain-p "www.yourbank.com⁄login⁄checkUser.jsp?inxs.ch")) + ;; Disallow mixing scripts. + (should-not (puny-highly-restrictive-domain-p "åர.org")) + ;; Only allowed in moderately restrictive. + (should-not (puny-highly-restrictive-domain-p "Teχ.org")) + (should-not (puny-highly-restrictive-domain-p "HλLF-LIFE.org")) + (should-not (puny-highly-restrictive-domain-p "Ωmega.org")) + ;; Only allowed in unrestricted. + (should-not (puny-highly-restrictive-domain-p "I♥NY.org"))) + ;;; puny-tests.el ends here diff --git a/test/lisp/net/rfc2104-tests.el b/test/lisp/net/rfc2104-tests.el index 5c1f4410934..90535898382 100644 --- a/test/lisp/net/rfc2104-tests.el +++ b/test/lisp/net/rfc2104-tests.el @@ -1,4 +1,4 @@ -;;; rfc2104-tests.el --- Tests of RFC2104 hashes +;;; rfc2104-tests.el --- Tests of RFC2104 hashes -*- lexical-binding:t -*- ;; Copyright (C) 2019-2020 Free Software Foundation, Inc. diff --git a/test/lisp/net/sasl-scram-rfc-tests.el b/test/lisp/net/sasl-scram-rfc-tests.el index ec283c86f55..09e05b62a25 100644 --- a/test/lisp/net/sasl-scram-rfc-tests.el +++ b/test/lisp/net/sasl-scram-rfc-tests.el @@ -1,4 +1,4 @@ -;;; sasl-scram-rfc-tests.el --- tests for SCRAM-SHA-1 -*- lexical-binding: t; -*- +;;; sasl-scram-rfc-tests.el --- tests for SCRAM -*- lexical-binding: t; -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. @@ -19,7 +19,7 @@ ;;; Commentary: -;; Test cases from RFC 5802. +;; Test cases from RFC 5802 and RFC 7677. ;;; Code: @@ -47,4 +47,26 @@ (sasl-scram-sha-1-authenticate-server client (vector nil "v=rmF9pqV8S7suAoZWja4dJRkFsKQ= ")))) +(require 'sasl-scram-sha256) + +(ert-deftest sasl-scram-sha-256-test () + ;; The following strings are taken from section 3 of RFC 7677. + (let ((client + (sasl-make-client (sasl-find-mechanism '("SCRAM-SHA-256")) + "user" + "imap" + "localhost")) + (data "r=rOprNGfwEbeRWgbNEkqO%hvYDpWUa2RaTCAfuxFIlj)hNlF$k0,s=W22ZaJ0SNY7soEsUEjb6gQ==,i=4096") + (c-nonce "rOprNGfwEbeRWgbNEkqO") + (sasl-read-passphrase + (lambda (_prompt) (copy-sequence "pencil")))) + (sasl-client-set-property client 'c-nonce c-nonce) + (should + (equal + (sasl-scram-sha-256-client-final-message client (vector nil data)) + "c=biws,r=rOprNGfwEbeRWgbNEkqO%hvYDpWUa2RaTCAfuxFIlj)hNlF$k0,p=dHzbZapWIk4jUhN+Ute9ytag9zjfMHgsqmmiz7AndVQ=")) + + ;; This should not throw an error: + (sasl-scram-sha-256-authenticate-server client (vector nil "v=6rriTRBi23WpRR/wtup+mMhUZUn/dB5nLTJRsjl95G4=")))) + ;;; sasl-scram-rfc-tests.el ends here diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 95e41a3f03b..8c75d91bb58 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -60,7 +60,6 @@ (setq password-cache-expiry nil tramp-cache-read-persistent-data t ;; For auth-sources. tramp-copy-size-limit nil - tramp-message-show-message nil tramp-persistency-file-name nil tramp-verbose 0) @@ -971,4 +970,5 @@ If INTERACTIVE is non-nil, the tests are run interactively." "^tramp-archive")) (provide 'tramp-archive-tests) + ;;; tramp-archive-tests.el ends here diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 544bdb5c058..34782e7f151 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -43,6 +43,7 @@ (require 'dired) (require 'ert) (require 'ert-x) +(require 'trace) (require 'tramp) (require 'vc) (require 'vc-bzr) @@ -50,6 +51,8 @@ (require 'vc-hg) (declare-function tramp-find-executable "tramp-sh") +(declare-function tramp-get-remote-chmod-h "tramp-sh") +(declare-function tramp-get-remote-gid "tramp-sh") (declare-function tramp-get-remote-path "tramp-sh") (declare-function tramp-get-remote-perl "tramp-sh") (declare-function tramp-get-remote-stat "tramp-sh") @@ -67,13 +70,14 @@ (defvar tramp-remote-path) (defvar tramp-remote-process-environment) -;; Needed for Emacs 24. -(defvar inhibit-message) ;; Needed for Emacs 25. (defvar connection-local-criteria-alist) (defvar connection-local-profile-alist) ;; Needed for Emacs 26. (defvar async-shell-command-width) +;; Needed for Emacs 27. +(defvar process-file-return-signal-string) +(defvar shell-command-dont-erase-buffer) ;; Beautify batch mode. (when noninteractive @@ -100,19 +104,22 @@ (add-to-list 'tramp-default-host-alist `("\\`mock\\'" nil ,(system-name))) - ;; Emacs' Makefile sets $HOME to a nonexistent value. Needed in - ;; batch mode only, therefore. + ;; Emacs's Makefile sets $HOME to a nonexistent value. Needed + ;; in batch mode only, therefore. (unless (and (null noninteractive) (file-directory-p "~/")) (setenv "HOME" temporary-file-directory)) (format "/mock::%s" temporary-file-directory))) "Temporary directory for Tramp tests.") +(defconst tramp-test-vec + (tramp-dissect-file-name tramp-test-temporary-file-directory) + "The used `tramp-file-name' structure.") + (setq auth-source-save-behavior nil password-cache-expiry nil remote-file-name-inhibit-cache nil tramp-cache-read-persistent-data t ;; For auth-sources. tramp-copy-size-limit nil - tramp-message-show-message nil tramp-persistency-file-name nil tramp-verbose 0) @@ -140,9 +147,7 @@ being the result.") (when (cdr tramp--test-enabled-checked) ;; Cleanup connection. (ignore-errors - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - nil 'keep-password))) + (tramp-cleanup-connection tramp-test-vec nil 'keep-password))) ;; Return result. (cdr tramp--test-enabled-checked)) @@ -173,38 +178,46 @@ This shall used dynamically bound only.") (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 -`tramp-verbose' is greater than 3. `should-error' is not handled -properly. BODY shall not contain a timeout." +`tramp-verbose' is greater than 3. Print traces if `tramp-verbose' +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))) - (tramp-message-show-message t) - (debug-ignored-errors - (append - '("^make-symbolic-link not supported$" - "^error with add-name-to-file") - debug-ignored-errors)) - inhibit-message) + `(let* ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0))) + (trace-buffer + (when (> tramp-verbose 10) (generate-new-buffer " *temp*"))) + (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 (tramp-list-tramp-buffers)) + (dolist + (buf (if trace-buffer + (cons (get-buffer trace-buffer) (tramp-list-tramp-buffers)) + (tramp-list-tramp-buffers))) (with-current-buffer buf - (message ";; %s\n%s" buf (buffer-string)))))))) + (message ";; %s\n%s" buf (buffer-string))))) + (when trace-buffer + (kill-buffer trace-buffer))))) (defsubst tramp--test-message (fmt-string &rest arguments) "Emit a message into ERT *Messages*." (tramp--test-instrument-test-case 0 - (apply - #'tramp-message - (tramp-dissect-file-name tramp-test-temporary-file-directory) 0 - fmt-string arguments))) + (apply #'tramp-message tramp-test-vec 0 fmt-string arguments))) (defsubst tramp--test-backtrace () "Dump a backtrace into ERT *Messages*." (tramp--test-instrument-test-case 10 - (tramp-backtrace - (tramp-dissect-file-name tramp-test-temporary-file-directory)))) + (tramp-backtrace tramp-test-vec))) (defmacro tramp--test-print-duration (message &rest body) "Run BODY and print a message with duration, prompted by MESSAGE." @@ -1966,9 +1979,9 @@ properly. BODY shall not contain a timeout." ;; Host names must match rules in case the command template of a ;; method doesn't use them. (dolist (m '("su" "sg" "sudo" "doas" "ksu")) - (let ((vec (tramp-dissect-file-name tramp-test-temporary-file-directory)) - tramp-connection-properties tramp-default-proxies-alist) - (ignore-errors (tramp-cleanup-connection vec nil 'keep-password)) + (let (tramp-connection-properties tramp-default-proxies-alist) + (ignore-errors + (tramp-cleanup-connection tramp-test-vec nil 'keep-password)) ;; Single hop. The host name must match `tramp-local-host-regexp'. (should-error (find-file (format "/%s:foo:" m)) @@ -1997,7 +2010,7 @@ properly. BODY shall not contain a timeout." ;; Samba does not support file names with periods followed by ;; spaces, and trailing periods or spaces. - (when (tramp-smb-file-name-p tramp-test-temporary-file-directory) + (when (tramp--test-smb-p) (dolist (file '("foo." "foo. bar" "foo ")) (should-error (tramp-smb-get-localname @@ -2039,7 +2052,7 @@ properly. BODY shall not contain a timeout." "/method:host:/:/path//foo")) ;; Forwhatever reasons, the following tests let Emacs crash for - ;; Emacs 24 and Emacs 25, occasionally. No idea what's up. + ;; Emacs 25, occasionally. No idea what's up. (when (tramp--test-emacs26-p) (should (string-equal (substitute-in-file-name "/method:host://~foo") "/~foo")) @@ -2151,7 +2164,7 @@ properly. BODY shall not contain a timeout." ;; These are the methods the test doesn't fail. (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)) + (tramp--test-smb-p)) (setf (ert-test-expected-result-type (ert-get-test 'tramp-test05-expand-file-name-relative)) :passed)) @@ -2218,11 +2231,10 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Bug#10085. (when (tramp--test-enabled) ;; Packages like tramp-gvfs.el might be disabled. - (dolist (n-e '(nil t)) + (dolist (non-essential '(nil t)) ;; We must clear `tramp-default-method'. On hydra, it is "ftp", ;; which ruins the tests. - (let ((non-essential n-e) - (tramp-default-method + (let ((tramp-default-method (file-remote-p tramp-test-temporary-file-directory 'method)) (host (file-remote-p tramp-test-temporary-file-directory 'host))) (dolist @@ -2238,7 +2250,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (file-name-as-directory file) - (if (tramp-completion-mode-p) + (if non-essential file (concat file (if (tramp--test-ange-ftp-p) "/" "./"))))) (should (string-equal (file-name-directory file) file)) (should (string-equal (file-name-nondirectory file) ""))))))) @@ -2296,16 +2308,25 @@ This checks also `file-name-as-directory', `file-name-directory', (unwind-protect (with-temp-buffer (write-region "foo" nil tmp-name) - (insert-file-contents tmp-name) - (should (string-equal (buffer-string) "foo")) - (insert-file-contents tmp-name) - (should (string-equal (buffer-string) "foofoo")) + (let ((point (point))) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo")) + (should (= point (point)))) + (goto-char (1+ (point))) + (let ((point (point))) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "ffoooo")) + (should (= point (point)))) ;; Insert partly. - (insert-file-contents tmp-name nil 1 3) - (should (string-equal (buffer-string) "oofoofoo")) + (let ((point (point))) + (insert-file-contents tmp-name nil 1 3) + (should (string-equal (buffer-string) "foofoooo")) + (should (= point (point)))) ;; Replace. - (insert-file-contents tmp-name nil nil nil 'replace) - (should (string-equal (buffer-string) "foo")) + (let ((point (point))) + (insert-file-contents tmp-name nil nil nil 'replace) + (should (string-equal (buffer-string) "foo")) + (should (= point (point)))) ;; Error case. (delete-file tmp-name) (should-error @@ -2357,7 +2378,14 @@ This checks also `file-name-as-directory', `file-name-directory', (write-region nil nil tmp-name 3)) (with-temp-buffer (insert-file-contents tmp-name) - (should (string-equal (buffer-string) "foobaz")))) + (should (string-equal (buffer-string) "foobaz"))) + (delete-file tmp-name) + (with-temp-buffer + (insert "foo") + (write-region nil nil tmp-name 'append)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo")))) ;; Write string. (write-region "foo" nil tmp-name) @@ -2376,7 +2404,7 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Check message. ;; 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)) + (let (inhibit-message) (dolist (noninteractive (unless (tramp--test-ange-ftp-p) '(nil t))) (dolist (visit '(nil t "string" no-message)) @@ -2393,14 +2421,14 @@ 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)) @@ -2911,6 +2939,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; (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))) + ;; `insert-directory' of crypted remote directories works only since + ;; Emacs 27.1. + (skip-unless (or (not (tramp--test-crypt-p)) (tramp--test-emacs27-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 @@ -2981,6 +3012,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) + ;; Wildcards are not supported in tramp-crypt.el. + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. (skip-unless (fboundp 'insert-directory-wildcard-in-dir-p)) @@ -3115,22 +3148,37 @@ This tests also `access-file', `file-readable-p', (file-remote-p tmp-name1) (replace-regexp-in-string "/" "//" (file-remote-p tmp-name1 'localname)))) + ;; `file-ownership-preserved-p' is implemented only in tramp-sh.el. + (test-file-ownership-preserved-p (tramp--test-sh-p)) attr) (unwind-protect (progn + ;; A sticky bit could damage the `file-ownership-preserved-p' test. + (when + (and test-file-ownership-preserved-p + (zerop (logand + #o1000 + (file-modes tramp-test-temporary-file-directory)))) + (write-region "foo" nil tmp-name1) + (setq test-file-ownership-preserved-p + (= (tramp-compat-file-attribute-group-id + (file-attributes tmp-name1)) + (tramp-get-remote-gid tramp-test-vec 'integer))) + (delete-file tmp-name1)) + (should-error (access-file tmp-name1 "error") :type tramp-file-missing) ;; `file-ownership-preserved-p' should return t for - ;; non-existing files. It is implemented only in tramp-sh.el. - (when (tramp--test-sh-p) + ;; non-existing files. + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) (should (file-readable-p tmp-name1)) (should (file-regular-p tmp-name1)) (should-not (access-file tmp-name1 "error")) - (when (tramp--test-sh-p) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) ;; We do not test inodes and device numbers. @@ -3160,16 +3208,16 @@ This tests also `access-file', `file-readable-p', (should (stringp (tramp-compat-file-attribute-group-id attr))) (tramp--test-ignore-make-symbolic-link-error - (should-error - (access-file tmp-name2 "error") - :type tramp-file-missing) - (when (tramp--test-sh-p) + (should-error + (access-file tmp-name2 "error") + :type tramp-file-missing) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name2 'group))) (make-symbolic-link tmp-name1 tmp-name2) (should (file-exists-p tmp-name2)) (should (file-symlink-p tmp-name2)) (should-not (access-file tmp-name2 "error")) - (when (tramp--test-sh-p) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name2 'group))) (setq attr (file-attributes tmp-name2)) (should @@ -3200,7 +3248,7 @@ This tests also `access-file', `file-readable-p', (tramp-dissect-file-name tmp-name3)))) (delete-file tmp-name2)) - (when (tramp--test-sh-p) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) (delete-file tmp-name1) (make-directory tmp-name1) @@ -3208,7 +3256,7 @@ This tests also `access-file', `file-readable-p', (should (file-readable-p tmp-name1)) (should-not (file-regular-p tmp-name1)) (should-not (access-file tmp-name1 "")) - (when (tramp--test-sh-p) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) (setq attr (file-attributes tmp-name1)) (should (eq (tramp-compat-file-attribute-type attr) t))) @@ -3350,25 +3398,80 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." "ftp" (file-remote-p tramp-test-temporary-file-directory 'method))))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) - (let ((tmp-name (tramp--test-make-temp-name nil quoted))) + (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) + (tmp-name2 (tramp--test-make-temp-name nil quoted))) + (unwind-protect (progn - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) - (set-file-modes tmp-name #o777) - (should (= (file-modes tmp-name) #o777)) - (should (file-executable-p tmp-name)) - (should (file-writable-p tmp-name)) - (set-file-modes tmp-name #o444) - (should (= (file-modes tmp-name) #o444)) - (should-not (file-executable-p tmp-name)) + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (set-file-modes tmp-name1 #o777) + (should (= (file-modes tmp-name1) #o777)) + (should (file-executable-p tmp-name1)) + (should (file-writable-p tmp-name1)) + (set-file-modes tmp-name1 #o444) + (should (= (file-modes tmp-name1) #o444)) + (should-not (file-executable-p tmp-name1)) ;; A file is always writable for user "root". (unless (zerop (tramp-compat-file-attribute-user-id - (file-attributes tmp-name))) - (should-not (file-writable-p tmp-name)))) + (file-attributes tmp-name1))) + (should-not (file-writable-p tmp-name1))) + ;; Check the NOFOLLOW arg. It exists since Emacs 28. For + ;; regular files, there shouldn't be a difference. + (when (tramp--test-emacs28-p) + (with-no-warnings + (set-file-modes tmp-name1 #o222 'nofollow) + (should (= (file-modes tmp-name1 'nofollow) #o222))))) ;; Cleanup. - (ignore-errors (delete-file tmp-name)))))) + (ignore-errors (delete-file tmp-name1))) + + ;; Check the NOFOLLOW arg. It exists since Emacs 28. It is + ;; implemented for tramp-gvfs.el and tramp-sh.el. However, + ;; tramp-gvfs,el does not support creating symbolic links. And + ;; in tramp-sh.el, we must ensure that the remote chmod command + ;; supports the "-h" argument. + (when (and (tramp--test-emacs28-p) (tramp--test-sh-p) + (tramp-get-remote-chmod-h tramp-test-vec)) + (unwind-protect + (with-no-warnings + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (make-symbolic-link tmp-name1 tmp-name2) + (should + (string-equal + (funcall + (if quoted #'tramp-compat-file-name-unquote #'identity) + (file-remote-p tmp-name1 'localname)) + (file-symlink-p tmp-name2))) + ;; Both report the modes of `tmp-name1'. + (should + (= (file-modes tmp-name1) (file-modes tmp-name2))) + ;; `tmp-name1' is a regular file. NOFOLLOW doesn't matter. + (should + (= (file-modes tmp-name1) (file-modes tmp-name1 'nofollow))) + ;; `tmp-name2' is a symbolic link. It has different permissions. + (should-not + (= (file-modes tmp-name2) (file-modes tmp-name2 'nofollow))) + (should-not + (= (file-modes tmp-name1 'nofollow) + (file-modes tmp-name2 'nofollow))) + ;; Change permissions. + (set-file-modes tmp-name1 #o200) + (set-file-modes tmp-name2 #o200) + (should + (= (file-modes tmp-name1) (file-modes tmp-name2) #o200)) + ;; Change permissions with NOFOLLOW. + (set-file-modes tmp-name1 #o300 'nofollow) + (set-file-modes tmp-name2 #o300 'nofollow) + (should + (= (file-modes tmp-name1 'nofollow) + (file-modes tmp-name2 'nofollow))) + (should-not (= (file-modes tmp-name1) (file-modes tmp-name2)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name2))))))) ;; Method "smb" could run into "NT_STATUS_REVISION_MISMATCH" error. (defmacro tramp--test-ignore-add-name-to-file-error (&rest body) @@ -3420,11 +3523,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :type 'file-already-exists)) (when (tramp--test-expensive-test) ;; A number means interactive case. - (cl-letf (((symbol-function 'yes-or-no-p) #'ignore)) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (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) (lambda (_prompt) t))) (make-symbolic-link tmp-name1 tmp-name2 0) (should (string-equal @@ -3496,11 +3599,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (add-name-to-file tmp-name1 tmp-name2) :type 'file-already-exists) ;; A number means interactive case. - (cl-letf (((symbol-function 'yes-or-no-p) #'ignore)) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (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) (lambda (_prompt) t))) (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) @@ -3627,7 +3730,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp--test-ignore-make-symbolic-link-error (make-symbolic-link tmp-name2 tmp-name1) (should (file-symlink-p tmp-name1)) - (if (tramp-smb-file-name-p tramp-test-temporary-file-directory) + (if (tramp--test-smb-p) ;; The symlink command of `smbclient' detects the ;; cycle already. (should-error @@ -3690,7 +3793,17 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (file-newer-than-file-p tmp-name2 tmp-name1)) ;; `tmp-name3' does not exist. (should (file-newer-than-file-p tmp-name2 tmp-name3)) - (should-not (file-newer-than-file-p tmp-name3 tmp-name1)))) + (should-not (file-newer-than-file-p tmp-name3 tmp-name1)) + ;; Check the NOFOLLOW arg. It exists since Emacs 28. For + ;; regular files, there shouldn't be a difference. + (when (tramp--test-emacs28-p) + (with-no-warnings + (set-file-times tmp-name1 (seconds-to-time 1) 'nofollow) + (should + (tramp-compat-time-equal-p + (tramp-compat-file-attribute-modification-time + (file-attributes tmp-name1)) + (seconds-to-time 1))))))) ;; Cleanup. (ignore-errors @@ -3730,6 +3843,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check that `file-acl' and `set-file-acl' work proper." (skip-unless (tramp--test-enabled)) (skip-unless (file-acl tramp-test-temporary-file-directory)) + (skip-unless (not (tramp--test-crypt-p))) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) @@ -3808,6 +3922,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (not (equal (file-selinux-context tramp-test-temporary-file-directory) '(nil nil nil nil)))) + (skip-unless (not (tramp--test-crypt-p))) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) @@ -3951,7 +4066,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (when (not (memq system-type '(cygwin windows-nt))) (let ((method (file-remote-p tramp-test-temporary-file-directory 'method)) (host (file-remote-p tramp-test-temporary-file-directory 'host)) - (vec (tramp-dissect-file-name tramp-test-temporary-file-directory)) (orig-syntax tramp-syntax)) (when (and (stringp host) (string-match tramp-host-with-port-regexp host)) (setq host (match-string 1 host))) @@ -3964,7 +4078,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-change-syntax syntax) ;; This has cleaned up all connection data, which are used ;; for completion. We must refill the cache. - (tramp-set-connection-property vec "property" nil) + (tramp-set-connection-property tramp-test-vec "property" nil) (let ;; This is needed for the `simplified' syntax. ((method-marker @@ -4020,10 +4134,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (tramp-change-syntax orig-syntax)))) - (dolist (n-e '(nil t)) + (dolist (non-essential '(nil t)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) - (let ((non-essential n-e) - (tmp-name (tramp--test-make-temp-name nil quoted))) + (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -4113,6 +4226,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name (tramp--test-make-temp-name nil quoted)) @@ -4126,6 +4240,28 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (zerop (process-file "true"))) (should-not (zerop (process-file "false"))) (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") + 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 $$")))) + ;; 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-equal + "Interrupt" + (process-file + (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") + nil nil nil "-c" "kill -2 $$")))) + (with-temp-buffer (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) @@ -4169,6 +4305,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) @@ -4181,7 +4318,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (setq proc (start-file-process "test1" (current-buffer) "cat")) (should (processp proc)) (should (equal (process-status proc) 'run)) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4224,7 +4361,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (set-process-filter proc (lambda (p s) (with-current-buffer (process-buffer p) (insert s)))) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4242,13 +4379,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) - ;; `make-process' has been inserted in Emacs 25.1. It supports file - ;; name handlers since Emacs 27. + (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-name (tramp--test-make-temp-name nil quoted)) + (tmp-name1 (tramp--test-make-temp-name nil quoted)) + (tmp-name2 (tramp--test-make-temp-name 'local quoted)) kill-buffer-query-functions proc) (with-no-warnings (should-not (make-process))) @@ -4262,7 +4400,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4278,13 +4416,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Simple process using a file. (unwind-protect (with-temp-buffer - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) (setq proc (with-no-warnings (make-process :name "test2" :buffer (current-buffer) - :command `("cat" ,(file-name-nondirectory tmp-name)) + :command `("cat" ,(file-name-nondirectory tmp-name1)) :file-handler t))) (should (processp proc)) ;; Read output. @@ -4296,7 +4434,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc) - (delete-file tmp-name))) + (delete-file tmp-name1))) ;; Process filter. (unwind-protect @@ -4311,7 +4449,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4337,7 +4475,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) (delete-process proc) ;; Read output. @@ -4345,42 +4483,74 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (while (accept-process-output proc 0 nil t))) ;; We cannot use `string-equal', because tramp-adb.el ;; echoes also the sent string. And a remote macOS sends - ;; a slightly modified string. - (should (string-match "killed.*\n\\'" (buffer-string)))) + ;; a slightly modified string. On MS Windows, + ;; `delete-process' sends an unknown signal. + (should + (string-match + (if (eq system-type 'windows-nt) + "unknown signal\n\\'" "killed.*\n\\'") + (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) - ;; Process with stderr. tramp-adb.el doesn't support it (yet). - (unless (tramp--test-adb-p) - (let ((stderr (generate-new-buffer "*stderr*"))) - (unwind-protect + ;; Process with stderr buffer. + (let ((stderr (generate-new-buffer "*stderr*"))) + (unwind-protect + (with-temp-buffer + (setq proc + (with-no-warnings + (make-process + :name "test5" :buffer (current-buffer) + :command '("cat" "/does-not-exist") + :stderr stderr + :file-handler t))) + (should (processp proc)) + ;; Read stderr. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc 0 nil t))) + (delete-process proc) + (with-current-buffer stderr + (should + (string-match + "cat:.* No such file or directory" (buffer-string))))) + + ;; Cleanup. + (ignore-errors (delete-process proc)) + (ignore-errors (kill-buffer stderr)))) + + ;; Process with stderr file. + (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 tmpfile + :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 - (setq proc - (with-no-warnings - (make-process - :name "test5" :buffer (current-buffer) - :command '("cat" "/") - :stderr stderr - :file-handler t))) - (should (processp proc)) - ;; Read stderr. - (with-current-buffer stderr - (with-timeout (10 (tramp--test-timeout-handler)) - (while (= (point-min) (point-max)) - (while (accept-process-output proc 0 nil t)))) - (should - (string-match "^cat:.* Is a directory" (buffer-string))))) + (insert-file-contents tmpfile) + (should + (string-match + "cat:.* No such file or directory" (buffer-string))))) - ;; Cleanup. - (ignore-errors (delete-process proc)) - (ignore-errors (kill-buffer stderr)))))))) + ;; Cleanup. + (ignore-errors (delete-process proc)) + (ignore-errors (delete-file tmpfile))))))) (ert-deftest tramp-test31-interrupt-process () "Check `interrupt-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. (skip-unless (boundp 'interrupt-process-functions)) @@ -4388,10 +4558,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; order to establish the connection prior running an asynchronous ;; process. (let ((default-directory (file-truename tramp-test-temporary-file-directory)) + (delete-exited-processes t) kill-buffer-query-functions proc) (unwind-protect (with-temp-buffer - (setq proc (start-file-process "test" (current-buffer) "sleep" "10")) + (setq proc (start-file-process-shell-command + "test" (current-buffer) + "trap 'echo boom; exit 1' 2; sleep 100")) (should (processp proc)) (should (process-live-p proc)) (should (equal (process-status proc) 'run)) @@ -4399,7 +4572,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (interrupt-process proc)) ;; Let the process accept the interrupt. (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output proc nil nil 0))) + (while (process-live-p proc) + (while (accept-process-output proc 0 nil t)))) (should-not (process-live-p proc)) ;; An interrupted process cannot be interrupted, again. (should-error @@ -4409,14 +4583,24 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc))))) +(defun tramp--test-async-shell-command + (command output-buffer &optional error-buffer input) + "Like `async-shell-command', reading the output. +INPUT, if non-nil, is a string sent to the process." + (async-shell-command command output-buffer error-buffer) + (let ((proc (get-buffer-process output-buffer)) + (delete-exited-processes t)) + (when (stringp input) + (process-send-string proc input)) + (with-timeout + ((if (getenv "EMACS_EMBA_CI") 30 10) (tramp--test-timeout-handler)) + (while (or (accept-process-output proc nil nil t) (process-live-p proc)))) + (accept-process-output proc nil nil t))) + (defun tramp--test-shell-command-to-string-asynchronously (command) "Like `shell-command-to-string', but for asynchronous processes." (with-temp-buffer - (async-shell-command command (current-buffer)) - (with-timeout - ((if (getenv "EMACS_EMBA_CI") 30 10) (tramp--test-timeout-handler)) - (while (accept-process-output - (get-buffer-process (current-buffer)) nil nil t))) + (tramp--test-async-shell-command command (current-buffer)) (buffer-substring-no-properties (point-min) (point-max)))) (ert-deftest tramp-test32-shell-command () @@ -4427,6 +4611,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; 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))) + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) @@ -4435,111 +4620,295 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (inhibit-message t) kill-buffer-query-functions) - ;; Test ordinary `shell-command'. - (unwind-protect - (with-temp-buffer - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) - (shell-command - (format "ls %s" (file-name-nondirectory tmp-name)) - (current-buffer)) - ;; `ls' could produce colorized output. - (goto-char (point-min)) - (while - (re-search-forward tramp-display-escape-sequence-regexp nil t) - (replace-match "" nil nil)) - (should - (string-equal - (format "%s\n" (file-name-nondirectory tmp-name)) - (buffer-string)))) + (dolist (this-shell-command + '(;; Synchronously. + shell-command + ;; Asynchronously. + tramp--test-async-shell-command)) - ;; Cleanup. - (ignore-errors (delete-file tmp-name))) - - ;; Test `shell-command' with error buffer. - (let ((stderr (generate-new-buffer "*stderr*"))) + ;; Test ordinary `{async-}shell-command'. (unwind-protect (with-temp-buffer - (shell-command "error" (current-buffer) stderr) - (should (= (point-min) (point-max))) + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (funcall + this-shell-command + (format "ls %s" (file-name-nondirectory tmp-name)) + (current-buffer)) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while + (re-search-forward tramp-display-escape-sequence-regexp nil t) + (replace-match "" nil nil)) (should - (string-match - "error:.+not found" - (with-current-buffer stderr (buffer-string))))) + (string-equal + (format "%s\n" (file-name-nondirectory tmp-name)) + (buffer-string)))) ;; Cleanup. - (ignore-errors (kill-buffer stderr)))) + (ignore-errors (delete-file tmp-name))) - ;; Test ordinary `async-shell-command'. + ;; Test `{async-}shell-command' with error buffer. + (let ((stderr (generate-new-buffer "*stderr*"))) + (unwind-protect + (with-temp-buffer + (funcall + this-shell-command + "echo foo >&2; echo bar" (current-buffer) stderr) + (should (string-equal "bar\n" (buffer-string))) + ;; Check stderr. + (with-current-buffer stderr + (should (string-equal "foo\n" (buffer-string))))) + + ;; Cleanup. + (ignore-errors (kill-buffer stderr))))) + + ;; Test sending string to `async-shell-command'. (unwind-protect (with-temp-buffer (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) - (async-shell-command - (format "ls %s" (file-name-nondirectory tmp-name)) - (current-buffer)) - ;; Read output. - (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output - (get-buffer-process (current-buffer)) nil nil t))) - ;; `ls' could produce colorized output. - (goto-char (point-min)) - (while - (re-search-forward tramp-display-escape-sequence-regexp nil t) - (replace-match "" nil nil)) + (tramp--test-async-shell-command + "read line; ls $line" (current-buffer) nil + ;; String to be sent. + (format "%s\n" (file-name-nondirectory tmp-name))) (should (string-equal - (format "%s\n" (file-name-nondirectory tmp-name)) + ;; tramp-adb.el echoes, so we must add the string. + (if (tramp--test-adb-p) + (format + "%s\n%s\n" + (file-name-nondirectory tmp-name) + (file-name-nondirectory tmp-name)) + (format "%s\n" (file-name-nondirectory tmp-name))) (buffer-string)))) ;; Cleanup. - (ignore-errors (delete-file tmp-name))) + (ignore-errors (delete-file tmp-name))))) - ;; Test sending string to `async-shell-command'. + ;; Test `async-shell-command-width'. It exists since Emacs 26.1, + ;; but seems to work since Emacs 27.1 only. + (when (and (tramp--test-sh-p) (tramp--test-emacs27-p)) + (let* ((async-shell-command-width 1024) + (default-directory tramp-test-temporary-file-directory) + (cols (ignore-errors + (read (tramp--test-shell-command-to-string-asynchronously + "tput cols"))))) + (when (natnump cols) + (should (= cols async-shell-command-width)))))) + +;; This test is inspired by Bug#39067. +(ert-deftest tramp-test32-shell-command-dont-erase-buffer () + "Check `shell-command-dont-erase-buffer'." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-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)) + + ;; We check both the local and remote case, in order to guarantee + ;; that they behave similar. + (dolist (default-directory + `(,temporary-file-directory ,tramp-test-temporary-file-directory)) + (let ((buffer (generate-new-buffer "foo")) + ;; Suppress nasty messages. + (inhibit-message t) + point kill-buffer-query-functions) (unwind-protect - (with-temp-buffer - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) - (async-shell-command "read line; ls $line" (current-buffer)) - (process-send-string - (get-buffer-process (current-buffer)) - (format "%s\n" (file-name-nondirectory tmp-name))) - ;; Read output. - (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output - (get-buffer-process (current-buffer)) nil nil t))) - ;; `ls' could produce colorized output. - (goto-char (point-min)) - (while - (re-search-forward tramp-display-escape-sequence-regexp nil t) - (replace-match "" nil nil)) - ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. - (should - (string-match - (format "\\`%s" (regexp-quote (file-name-nondirectory tmp-name))) - (buffer-string)))) + (progn + ;; Don't erase if buffer is the current one. Point is not moved. + (let (shell-command-dont-erase-buffer) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + (should (= point (point))) + (should-not (= (point) (point-max))))) + + ;; Erase if the buffer is not current one. Point is not moved. + (let (shell-command-dont-erase-buffer) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "baz\n" (buffer-string))) + (should (= point (point))) + (should-not (= (point) (point-max))))) + + ;; Erase if buffer is the current one, but + ;; `shell-command-dont-erase-buffer' is set to `erase'. + ;; There is no point to check point. + (let ((shell-command-dont-erase-buffer 'erase)) + (with-temp-buffer + (insert "bar") + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "baz\n" (buffer-string))) + ;; In the local case, point is not moved after the + ;; inserted text. + (should (= (point) + (if (file-remote-p default-directory) + (point-max) (point-min)))))) + + ;; Don't erase if the buffer is the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `beg-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'beg-last-out)) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should (= point (point))) + (should-not (= (point) (point-max)))))) + + ;; Don't erase if the buffer is not the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `beg-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'beg-last-out)) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should (= point (point))) + (should-not (= (point) (point-max)))))) + + ;; Don't erase if the buffer is the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `end-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'end-last-out)) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; This does not work as expected in the local case. + ;; Therefore, we negate the test for the time being. + (should-not + (funcall (if (file-remote-p default-directory) #'identity #'not) + (= point (point)))) + (should + (funcall (if (file-remote-p default-directory) #'identity #'not) + (= (point) (point-max)))))) + + ;; Don't erase if the buffer is not the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `end-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'end-last-out)) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should-not (= point (point))) + (should (= (point) (point-max)))))) + + ;; Don't erase if the buffer is the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `save-point'. Check point. + (let ((shell-command-dont-erase-buffer 'save-point)) + (with-temp-buffer + (insert "bar") + (goto-char (1- (point-max))) + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (1- (point-max)))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "babaz\nr" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should (= point (point))) + (should-not (= (point) (point-max)))))) + + ;; Don't erase if the buffer is not the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `save-point'. Check point. + (let ((shell-command-dont-erase-buffer 'save-point)) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (goto-char (1- (point-max))) + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (1- (point-max)))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + ;; This does not work as expected. Therefore, we + ;; use the "wrong" string. + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should (= point (point))) + (should-not (= (point) (point-max)))))) + + ;; Don't erase if the buffer is the current one and + ;; `shell-command-dont-erase-buffer' is set to a random + ;; value. Check point. + (let ((shell-command-dont-erase-buffer 'random)) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; This does not work as expected in the local case. + ;; Therefore, we negate the test for the time being. + (should-not + (funcall (if (file-remote-p default-directory) #'identity #'not) + (= point (point)))) + (should + (funcall (if (file-remote-p default-directory) #'identity #'not) + (= (point) (point-max)))))) + + ;; Don't erase if the buffer is not the current one and + ;; `shell-command-dont-erase-buffer' is set to a random + ;; value. Check point. + (let ((shell-command-dont-erase-buffer 'random)) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should-not (= point (point))) + (should (= (point) (point-max))))))) ;; Cleanup. - (ignore-errors (delete-file tmp-name))) - - ;; Test `async-shell-command-width'. Since Emacs 27.1. - (when (ignore-errors - (and (boundp 'async-shell-command-width) - (zerop (call-process "tput" nil nil nil "cols")) - (zerop (process-file "tput" nil nil nil "cols")))) - (let (async-shell-command-width) - (should - (string-equal - (format "%s\n" (car (process-lines "tput" "cols"))) - (tramp--test-shell-command-to-string-asynchronously - "tput cols"))) - (setq async-shell-command-width 1024) - (should - (string-equal - "1024\n" - (tramp--test-shell-command-to-string-asynchronously - "tput cols")))))))) + (ignore-errors (kill-buffer buffer)))))) ;; This test is inspired by Bug#23952. (ert-deftest tramp-test33-environment-variables () @@ -4547,6 +4916,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) (dolist (this-shell-command-to-string '(;; Synchronously. @@ -4559,67 +4929,72 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (envvar (concat "VAR_" (upcase (md5 (current-time-string))))) kill-buffer-query-functions) - (unwind-protect - ;; Set a value. - (let ((process-environment - (cons (concat envvar "=foo") process-environment))) - ;; Default value. - (should - (string-match - "foo" - (funcall - this-shell-command-to-string - (format "echo -n ${%s:-bla}" envvar)))))) - - (unwind-protect - ;; Set the empty value. - (let ((process-environment - (cons (concat envvar "=") process-environment))) - ;; Value is null. - (should - (string-match - "bla" - (funcall - this-shell-command-to-string - (format "echo -n ${%s:-bla}" envvar)))) - ;; Variable is set. - (should - (string-match - (regexp-quote envvar) - (funcall this-shell-command-to-string "set"))))) + ;; Check INSIDE_EMACS. + (setenv "INSIDE_EMACS") + (should + (string-equal + (format "%s,tramp:%s" emacs-version tramp-version) + (funcall this-shell-command-to-string "echo -n ${INSIDE_EMACS:-bla}"))) + (let ((process-environment + (cons (format "INSIDE_EMACS=%s,foo" emacs-version) + process-environment))) + (should + (string-equal + (format "%s,foo,tramp:%s" emacs-version tramp-version) + (funcall + this-shell-command-to-string "echo -n ${INSIDE_EMACS:-bla}")))) + + ;; Set a value. + (let ((process-environment + (cons (concat envvar "=foo") process-environment))) + ;; Default value. + (should + (string-match + "foo" + (funcall + this-shell-command-to-string (format "echo -n ${%s:-bla}" envvar))))) + + ;; Set the empty value. + (let ((process-environment + (cons (concat envvar "=") process-environment))) + ;; Value is null. + (should + (string-match + "bla" + (funcall + this-shell-command-to-string (format "echo -n ${%s:-bla}" envvar)))) + ;; Variable is set. + (should + (string-match + (regexp-quote envvar) + (funcall this-shell-command-to-string "set")))) ;; We force a reconnect, in order to have a clean environment. - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) - (unwind-protect - ;; Unset the variable. - (let ((tramp-remote-process-environment - (cons (concat envvar "=foo") - tramp-remote-process-environment))) - ;; Set the initial value, we want to unset below. - (should - (string-match - "foo" - (funcall - this-shell-command-to-string - (format "echo -n ${%s:-bla}" envvar)))) - (let ((process-environment - (cons envvar process-environment))) - ;; Variable is unset. - (should - (string-match - "bla" - (funcall - this-shell-command-to-string - (format "echo -n ${%s:-bla}" envvar)))) - ;; Variable is unset. - (should-not - (string-match - (regexp-quote envvar) - ;; We must remove PS1, the output is truncated otherwise. - (funcall - this-shell-command-to-string "printenv | grep -v PS1"))))))))) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + ;; Unset the variable. + (let ((tramp-remote-process-environment + (cons (concat envvar "=foo") tramp-remote-process-environment))) + ;; Set the initial value, we want to unset below. + (should + (string-match + "foo" + (funcall + this-shell-command-to-string (format "echo -n ${%s:-bla}" envvar)))) + (let ((process-environment (cons envvar process-environment))) + ;; Variable is unset. + (should + (string-match + "bla" + (funcall + this-shell-command-to-string + (format "echo -n ${%s:-bla}" envvar)))) + ;; Variable is unset. + (should-not + (string-match + (regexp-quote envvar) + ;; We must remove PS1, the output is truncated otherwise. + (funcall + this-shell-command-to-string "printenv | grep -v PS1")))))))) ;; This test is inspired by Bug#27009. (ert-deftest tramp-test33-environment-variables-and-port-numbers () @@ -4628,6 +5003,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; We test it only for the mock-up connection; otherwise there might ;; be problems with the used ports. (skip-unless (and (eq tramp-syntax 'default) (tramp--test-mock-p))) + (skip-unless (not (tramp--test-crypt-p))) ;; We force a reconnect, in order to have a clean environment. (dolist (dir `(,tramp-test-temporary-file-directory @@ -4732,6 +5108,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; 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))) + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. (skip-unless (and (fboundp 'connection-local-set-profile-variables) (fboundp 'connection-local-set-profiles))) @@ -4788,6 +5165,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `exec-path' and `executable-find'." (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 27.1. (skip-unless (fboundp 'exec-path)) @@ -4831,6 +5209,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check loooong `tramp-remote-path'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 27.1. (skip-unless (fboundp 'exec-path)) @@ -4838,23 +5217,20 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (default-directory tramp-test-temporary-file-directory) (orig-exec-path (with-no-warnings (exec-path))) (tramp-remote-path tramp-remote-path) - (orig-tramp-remote-path tramp-remote-path)) + (orig-tramp-remote-path tramp-remote-path) + path) (unwind-protect (progn ;; Non existing directories are removed. (setq tramp-remote-path (cons (file-remote-p tmp-name 'localname) tramp-remote-path)) - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (should (equal (with-no-warnings (exec-path)) orig-exec-path)) (setq tramp-remote-path orig-tramp-remote-path) ;; Double entries are removed. (setq tramp-remote-path (append '("/" "/") tramp-remote-path)) - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (should (equal (with-no-warnings (exec-path)) (cons "/" orig-exec-path))) (setq tramp-remote-path orig-tramp-remote-path) @@ -4866,26 +5242,30 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (let ((dir (make-temp-file (file-name-as-directory tmp-name) 'dir))) (should (file-directory-p dir)) (setq tramp-remote-path - (cons (file-remote-p dir 'localname) tramp-remote-path) + (append + tramp-remote-path `(,(file-remote-p dir 'localname))) orig-exec-path - (cons (file-remote-p dir 'localname) orig-exec-path)))) - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + (append + (butlast orig-exec-path) + `(,(file-remote-p dir 'localname)) + (last orig-exec-path))))) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (should (equal (with-no-warnings (exec-path)) orig-exec-path)) - (should - (string-equal - ;; Ignore trailing newline. - (substring (shell-command-to-string "echo $PATH") nil -1) + ;; Ignore trailing newline. + (setq path (substring (shell-command-to-string "echo $PATH") nil -1)) + ;; The shell doesn't handle such long strings. + (unless (<= (length path) + (tramp-get-connection-property + tramp-test-vec "pipe-buf" 4096)) ;; The last element of `exec-path' is `exec-directory'. - (mapconcat #'identity (butlast orig-exec-path) ":"))) + (should + (string-equal + path (mapconcat #'identity (butlast orig-exec-path) ":")))) ;; The shell "sh" shall always exist. (should (apply #'executable-find '("sh" remote)))) ;; Cleanup. - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (setq tramp-remote-path orig-tramp-remote-path) (ignore-errors (delete-directory tmp-name 'recursive))))) @@ -4894,6 +5274,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, in @@ -4922,8 +5303,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." tramp-remote-process-environment)) ;; We must force a reconnect, in order to activate $BZR_HOME. (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + tramp-test-vec 'keep-debug 'keep-password) '(Bzr)) (t nil)))) ;; Suppress nasty messages. @@ -4949,13 +5329,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (error (ert-skip "`vc-create-repo' not supported"))) ;; The structure of VC-FILESET is not documented. Let's ;; hope it won't change. - (condition-case nil - (vc-register - (list (car vc-handled-backends) - (list (file-name-nondirectory tmp-name2)))) - ;; `vc-register' has changed its arguments in Emacs - ;; 25.1. Let's skip it for older Emacsen. - (error (skip-unless (tramp--test-emacs25-p)))) + (vc-register + (list (car vc-handled-backends) + (list (file-name-nondirectory tmp-name2)))) ;; vc-git uses an own process sentinel, Tramp's sentinel ;; for flushing the cache isn't used. (dired-uncache (concat (file-remote-p default-directory) "/")) @@ -5212,12 +5588,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (delete-directory tmp-file) (should-not (file-exists-p tmp-file)))) -(defun tramp--test-emacs25-p () - "Check for Emacs version >= 25.1. -Some semantics has been changed for there, w/o new functions or -variables, so we check the Emacs version directly." - (>= emacs-major-version 25)) - (defun tramp--test-emacs26-p () "Check for Emacs version >= 26.1. Some semantics has been changed for there, w/o new functions or @@ -5230,6 +5600,12 @@ Some semantics has been changed for there, w/o new functions or variables, so we check the Emacs version directly." (>= emacs-major-version 27)) +(defun tramp--test-emacs28-p () + "Check for Emacs version >= 28.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 28)) + (defun tramp--test-adb-p () "Check, whether the remote host runs Android. This requires restrictions of file name syntax." @@ -5247,6 +5623,10 @@ This does not support some special file names." (string-equal "docker" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-crypt-p () + "Check, whether the remote directory is crypted" + (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) + (defun tramp--test-ftp-p () "Check, whether an FTP-like method is used. This does not support globbing characters in file names (yet)." @@ -5331,7 +5711,12 @@ This does not support utf8 based file transfer." "Check, whether the locale or remote host runs MS Windows. This requires restrictions of file name syntax." (or (eq system-type 'windows-nt) - (tramp-smb-file-name-p tramp-test-temporary-file-directory))) + (tramp--test-smb-p))) + +(defun tramp--test-smb-p () + "Check, whether the locale or remote host runs MS Windows. +This requires restrictions of file name syntax." + (tramp-smb-file-name-p tramp-test-temporary-file-directory)) (defun tramp--test-check-files (&rest files) "Run a simple but comprehensive test over every file in FILES." @@ -5455,8 +5840,7 @@ This requires restrictions of file name syntax." ;; It does not work in the "smb" case, only relative ;; symlinks to existing files are shown there. (tramp--test-ignore-make-symbolic-link-error - (unless - (tramp-smb-file-name-p tramp-test-temporary-file-directory) + (unless (tramp--test-smb-p) (make-symbolic-link file2 file3) (should (file-symlink-p file3)) (should @@ -5483,6 +5867,7 @@ This requires restrictions of file name syntax." ;; We do not run on macOS due to encoding problems. See ;; Bug#36940. (when (and (tramp--test-expensive-test) (tramp--test-sh-p) + (not (tramp--test-crypt-p)) (not (eq system-type 'darwin))) (dolist (elt files) (let ((envvar (concat "VAR_" (upcase (md5 elt)))) @@ -5650,18 +6035,22 @@ Use the `ls' command." "银河系漫游指南系列" "Автостопом по гала́ктике" ;; Use codepoints without a name. See Bug#31272. - "bung") + "bung" + ;; Use codepoints from Supplementary Multilingual Plane (U+10000 + ;; to U+1FFFF). + "🌈🍒👋") (when (tramp--test-expensive-test) (delete-dups (mapcar - ;; Use all available language specific snippets. Filter out - ;; strings which use unencodable characters. + ;; Use all available language specific snippets. (lambda (x) (and (stringp (setq x (eval (get-language-info (car x) 'sample-text)))) - (not (unencodable-char-position - 0 (length x) file-name-coding-system nil x)) + ;; Filter out strings which use unencodable characters. + (not (and (or (tramp--test-gvfs-p) (tramp--test-smb-p)) + (unencodable-char-position + 0 (length x) file-name-coding-system nil 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))) @@ -5675,6 +6064,7 @@ Use the `ls' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (tramp--test-utf8)) @@ -5689,6 +6079,7 @@ Use the `stat' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -5710,6 +6101,7 @@ Use the `perl' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -5734,6 +6126,7 @@ Use the `ls' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (let ((tramp-connection-properties (append @@ -5753,7 +6146,7 @@ Use the `ls' command." ;; Since Emacs 27.1. (skip-unless (fboundp 'file-system-info)) - ;; `file-system-info' exists since Emacs 27. We don't want to see + ;; `file-system-info' exists since Emacs 27.1. We don't want to see ;; compiler warnings for older Emacsen. (let ((fsi (with-no-warnings (file-system-info tramp-test-temporary-file-directory)))) @@ -5815,6 +6208,7 @@ process sentinels. They shall not disturb each other." ;; 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))) + (skip-unless (not (tramp--test-crypt-p))) (with-timeout (tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler)) @@ -5875,10 +6269,7 @@ process sentinels. They shall not disturb each other." 0 timer-repeat (lambda () (tramp--test-with-proper-process-name-and-buffer - (get-buffer-process - (tramp-get-buffer - (tramp-dissect-file-name - tramp-test-temporary-file-directory))) + (get-buffer-process (tramp-get-buffer tramp-test-vec)) (when (> (- (time-to-seconds) (time-to-seconds timer-start)) tramp--test-asynchronous-requests-timeout) (tramp--test-timeout-handler)) @@ -6146,12 +6537,14 @@ Since it unloads Tramp, it shall be the last test to run." (and (or (and (boundp x) (null (local-variable-if-set-p x))) (and (functionp x) (null (autoloadp (symbol-function x))))) (string-match "^tramp" (symbol-name x)) + ;; `tramp-completion-mode' is autoloaded in Emacs < 28.1. + (not (eq 'tramp-completion-mode x)) (not (string-match "^tramp\\(-archive\\)?--?test" (symbol-name x))) (not (string-match "unload-hook$" (symbol-name x))) (ert-fail (format "`%s' still bound" x))))) ;; The defstruct `tramp-file-name' and all its internal functions - ;; shall be purged. `cl--find-class' must be protected in Emacs 24. - (with-no-warnings (should-not (cl--find-class 'tramp-file-name))) + ;; shall be purged. + (should-not (cl--find-class 'tramp-file-name)) (mapatoms (lambda (x) (and (functionp x) @@ -6183,6 +6576,8 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * file-equal-p (partly done in `tramp-test21-file-links') ;; * file-in-directory-p ;; * file-name-case-insensitive-p +;; * tramp-get-remote-gid +;; * tramp-get-remote-uid ;; * tramp-set-file-uid-gid ;; * Work on skipped tests. Make a comment, when it is impossible. @@ -6191,11 +6586,10 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * Fix `tramp-test06-directory-file-name' for `ftp'. ;; * Investigate, why `tramp-test11-copy-file' and `tramp-test12-rename-file' ;; do not work properly for `nextcloud'. -;; * Fix `tramp-test29-start-file-process' and -;; `tramp-test30-make-process' on MS Windows (`process-send-eof'?). ;; * Implement `tramp-test31-interrupt-process' for `adb'. ;; * Fix Bug#16928 in `tramp-test43-asynchronous-requests'. A remote ;; file name operation cannot run in the timer. Remove `:unstable' tag? (provide 'tramp-tests) + ;;; tramp-tests.el ends here diff --git a/test/lisp/net/webjump-tests.el b/test/lisp/net/webjump-tests.el new file mode 100644 index 00000000000..47569c948f5 --- /dev/null +++ b/test/lisp/net/webjump-tests.el @@ -0,0 +1,73 @@ +;;; webjump-tests.el --- Tests for webjump.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@gmail.com> +;; Keywords: + +;; 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 +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; 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: + +;; + +;;; Code: + +(require 'ert) +(require 'webjump) + +(ert-deftest webjump-tests-builtin () + (should (equal (webjump-builtin '[name] "gnu.org") "gnu.org"))) + +(ert-deftest webjump-tests-builtin-check-args () + (should (webjump-builtin-check-args [1 2 3] "Foo" 2)) + (should-error (webjump-builtin-check-args [1 2 3] "Foo" 3))) + +(ert-deftest webjump-tests-mirror-default () + (should (equal (webjump-mirror-default + '("https://ftp.gnu.org/pub/gnu/" + "https://ftpmirror.gnu.org")) + "https://ftp.gnu.org/pub/gnu/"))) + +(ert-deftest webjump-tests-null-or-blank-string-p () + (should (webjump-null-or-blank-string-p nil)) + (should (webjump-null-or-blank-string-p "")) + (should (webjump-null-or-blank-string-p " ")) + (should-not (webjump-null-or-blank-string-p " . "))) + +(ert-deftest webjump-tests-url-encode () + (should (equal (webjump-url-encode "") "")) + (should (equal (webjump-url-encode "a b c") "a+b+c")) + (should (equal (webjump-url-encode "foo?") "foo%3F")) + (should (equal (webjump-url-encode "/foo\\") "/foo%5C")) + (should (equal (webjump-url-encode "f&o") "f%26o"))) + +(ert-deftest webjump-tests-url-fix () + (should (equal (webjump-url-fix nil) "")) + (should (equal (webjump-url-fix "/tmp/") "file:///tmp/")) + (should (equal (webjump-url-fix "gnu.org") "http://gnu.org/")) + (should (equal (webjump-url-fix "ftp.x.org") "ftp://ftp.x.org/")) + (should (equal (webjump-url-fix "https://gnu.org") + "https://gnu.org/"))) + +(ert-deftest webjump-tests-url-fix-trailing-slash () + (should (equal (webjump-url-fix-trailing-slash "https://gnu.org") + "https://gnu.org/")) + (should (equal (webjump-url-fix-trailing-slash "https://gnu.org/") + "https://gnu.org/"))) + +(provide 'webjump-tests) +;;; webjump-tests.el ends here |