diff options
Diffstat (limited to 'test/lisp/net')
39 files changed, 3218 insertions, 380 deletions
diff --git a/test/lisp/net/browse-url-tests.el b/test/lisp/net/browse-url-tests.el new file mode 100644 index 00000000000..b2b27d2ae7b --- /dev/null +++ b/test/lisp/net/browse-url-tests.el @@ -0,0 +1,119 @@ +;;; browse-url-tests.el --- Tests for browse-url.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 'browse-url) +(require 'ert) + +(ert-deftest browse-url-tests-browser-kind () + (should (eq (browse-url--browser-kind #'browse-url-w3 "gnu.org") + 'internal)) + (should + (eq (browse-url--browser-kind #'browse-url-firefox "gnu.org") + 'external))) + +(ert-deftest browse-url-tests-non-html-file-url-p () + (should (browse-url--non-html-file-url-p "file://foo.txt")) + (should-not (browse-url--non-html-file-url-p "file://foo.html"))) + +(ert-deftest browse-url-tests-select-handler-mailto () + (should (eq (browse-url-select-handler "mailto:foo@bar.org") + 'browse-url--mailto)) + (should (eq (browse-url-select-handler "mailto:foo@bar.org" + 'internal) + 'browse-url--mailto)) + (should-not (browse-url-select-handler "mailto:foo@bar.org" + 'external))) + +(ert-deftest browse-url-tests-select-handler-man () + (should (eq (browse-url-select-handler "man:ls") 'browse-url--man)) + (should (eq (browse-url-select-handler "man:ls" 'internal) + 'browse-url--man)) + (should-not (browse-url-select-handler "man:ls" 'external))) + +(ert-deftest browse-url-tests-select-handler-file () + (should (eq (browse-url-select-handler "file://foo.txt") + 'browse-url-emacs)) + (should (eq (browse-url-select-handler "file://foo.txt" 'internal) + 'browse-url-emacs)) + (should-not (browse-url-select-handler "file://foo.txt" 'external))) + +(ert-deftest browse-url-tests-url-encode-chars () + (should (equal (browse-url-url-encode-chars "foobar" "[ob]") + "f%6F%6F%62ar"))) + +(ert-deftest browse-url-tests-encode-url () + (should (equal (browse-url-encode-url "") "")) + (should (equal (browse-url-encode-url "a b c") "a b c")) + (should (equal (browse-url-encode-url "\"a\" \"b\"") + "\"a%22\"b\"")) + (should (equal (browse-url-encode-url "(a) (b)") "(a%29(b)")) + (should (equal (browse-url-encode-url "a$ b$") "a%24b$"))) + +(ert-deftest browse-url-tests-url-at-point () + (with-temp-buffer + (insert "gnu.org") + (should (equal (browse-url-url-at-point) "http://gnu.org")))) + +(ert-deftest browse-url-tests-file-url () + (should (equal (browse-url-file-url "/foo") "file:///foo")) + (should (equal (browse-url-file-url "/foo:") "ftp://foo/")) + (should (equal (browse-url-file-url "/ftp@foo:") "ftp://foo/")) + (should (equal (browse-url-file-url "/anonymous@foo:") + "ftp://foo/"))) + +(ert-deftest browse-url-tests-delete-temp-file () + (let ((browse-url-temp-file-name + (make-temp-file "browse-url-tests-"))) + (browse-url-delete-temp-file) + (should-not (file-exists-p browse-url-temp-file-name))) + (let ((file (make-temp-file "browse-url-tests-"))) + (browse-url-delete-temp-file file) + (should-not (file-exists-p file)))) + +(ert-deftest browse-url-tests-add-buttons () + (with-temp-buffer + (insert "Visit https://gnu.org") + (goto-char (point-min)) + (browse-url-add-buttons) + (goto-char (- (point-max) 1)) + (should (eq (get-text-property (point) 'face) + 'browse-url-button)) + (should (get-text-property (point) 'browse-url-data)))) + +(ert-deftest browse-url-tests-button-copy () + (with-temp-buffer + (insert "Visit https://gnu.org") + (goto-char (point-min)) + (browse-url-add-buttons) + (should-error (browse-url-button-copy)) + (goto-char (- (point-max) 1)) + (browse-url-button-copy) + (should (equal (car kill-ring) "https://gnu.org")))) + +(provide 'browse-url-tests) +;;; browse-url-tests.el ends here diff --git a/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml b/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml new file mode 100644 index 00000000000..620f10510f2 --- /dev/null +++ b/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml @@ -0,0 +1,49 @@ +<?xml version="1.0"?> +<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"> +<node> + <interface name="org.freedesktop.DBus.Introspectable"> + <method name="Introspect"> + <arg name="xml" type="s" direction="out"/> + </method> + </interface> + <interface name="org.freedesktop.DBus.Properties"> + <method name="Get"> + <arg name="interface" type="s" direction="in"/> + <arg name="name" type="s" direction="in"/> + <arg name="value" type="v" direction="out"/> + </method> + <method name="Set"> + <arg name="interface" type="s" direction="in"/> + <arg name="name" type="s" direction="in"/> + <arg name="value" type="v" direction="in"/> + </method> + <method name="GetAll"> + <arg name="interface" type="s" direction="in"/> + <arg name="properties" type="a{sv}" direction="out"/> + </method> + <signal name="PropertiesChanged"> + <arg name="interface" type="s"/> + <arg name="changed_properties" type="a{sv}"/> + <arg name="invalidated_properties" type="as"/> + </signal> + </interface> + <interface name="org.gnu.Emacs.TestDBus.Interface"> + <method name="Connect"> + <arg name="uuid" type="s" direction="in"/> + <arg name="mode" type="y" direction="in"/> + <arg name="options" type="a{sv}" direction="in"/> + <arg name="interface" type="s" direction="out"/> + </method> + <method name="DeprecatedMethod0"> + <annotation name="org.freedesktop.DBus.Deprecated" value="true"/> + </method> + <method name="DeprecatedMethod1"> + <annotation name="org.freedesktop.DBus.Deprecated" value="true"/> + </method> + <property name="Connected" type="b" access="read"/> + <property name="Player" type="o" access="read"/> + <annotation name="org.freedesktop.DBus.Deprecated" value="true"/> + </interface> + <node name="node0"/> + <node name="node1"/> +</node> diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 68f69f62b56..3cfb4b7d9e7 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -1,40 +1,52 @@ -;;; 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. ;; Author: Michael Albinus <michael.albinus@gmx.de> -;; This program 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. -;; -;; This program 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. -;; +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: (require 'ert) +(require 'ert-x) (require 'dbus) (defvar dbus-debug nil) (declare-function dbus-get-unique-name "dbusbind.c" (bus)) -(defvar dbus--test-enabled-session-bus +(defconst dbus--test-enabled-session-bus (and (featurep 'dbusbind) (dbus-ignore-errors (dbus-get-unique-name :session))) "Check, whether we are registered at the session bus.") -(defvar dbus--test-enabled-system-bus +(defconst dbus--test-enabled-system-bus (and (featurep 'dbusbind) (dbus-ignore-errors (dbus-get-unique-name :system))) "Check, whether we are registered at the system bus.") +(defconst dbus--test-service "org.gnu.Emacs.TestDBus" + "Test service.") + +(defconst dbus--test-path "/org/gnu/Emacs/TestDBus" + "Test object path.") + +(defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface" + "Test interface.") + (defun dbus--test-availability (bus) "Test availability of D-Bus BUS." (should (dbus-list-names bus)) @@ -54,6 +66,8 @@ (ert-deftest dbus-test01-type-conversion () "Check type conversion functions." + (skip-unless dbus--test-enabled-session-bus) + (let ((ustr "0123abc_xyz\x01\xff") (mstr "Grüß Göttin")) (should @@ -82,31 +96,391 @@ (string-equal (dbus-unescape-from-identifier (dbus-escape-as-identifier mstr)) mstr)))) +(ert-deftest dbus-test01-basic-types () + "Check basic D-Bus type arguments." + (skip-unless dbus--test-enabled-session-bus) + + ;; No argument or unknown keyword. + (should-error + (dbus-check-arguments :session dbus--test-service) + :type 'wrong-number-of-arguments) + (should-error + (dbus-check-arguments :session dbus--test-service :keyword) + :type 'wrong-type-argument) + + ;; `:string'. + (should (dbus-check-arguments :session dbus--test-service "string")) + (should (dbus-check-arguments :session dbus--test-service :string "string")) + (should-error + (dbus-check-arguments :session dbus--test-service :string) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :string 0.5) + :type 'wrong-type-argument) + + ;; `:object-path'. + (should + (dbus-check-arguments + :session dbus--test-service :object-path "/object/path")) + (should-error + (dbus-check-arguments :session dbus--test-service :object-path) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :object-path "string") + :type 'dbus-error) + (should-error + (dbus-check-arguments :session dbus--test-service :object-path 0.5) + :type 'wrong-type-argument) + + ;; `:signature'. + (should (dbus-check-arguments :session dbus--test-service :signature "as")) + (should-error + (dbus-check-arguments :session dbus--test-service :signature) + :type 'wrong-type-argument) + ;; Raises an error on stderr. + (should-error + (dbus-check-arguments :session dbus--test-service :signature "string") + :type 'dbus-error) + (should-error + (dbus-check-arguments :session dbus--test-service :signature 0.5) + :type 'wrong-type-argument) + + ;; `:boolean'. + (should (dbus-check-arguments :session dbus--test-service nil)) + (should (dbus-check-arguments :session dbus--test-service t)) + (should (dbus-check-arguments :session dbus--test-service :boolean nil)) + (should (dbus-check-arguments :session dbus--test-service :boolean t)) + (should (dbus-check-arguments :session dbus--test-service :boolean 'whatever)) + (should-error + (dbus-check-arguments :session dbus--test-service :boolean) + :type 'wrong-type-argument) + + ;; `:byte'. + (should (dbus-check-arguments :session dbus--test-service :byte 0)) + ;; Only the least significant byte is taken into account. + (should + (dbus-check-arguments :session dbus--test-service :byte most-positive-fixnum)) + (should-error + (dbus-check-arguments :session dbus--test-service :byte) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :byte -1) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :byte 0.5) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :byte "string") + :type 'wrong-type-argument) + + ;; `:int16'. + (should (dbus-check-arguments :session dbus--test-service :int16 0)) + (should (dbus-check-arguments :session dbus--test-service :int16 #x7fff)) + (should (dbus-check-arguments :session dbus--test-service :int16 #x-8000)) + (should-error + (dbus-check-arguments :session dbus--test-service :int16) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :int16 #x8000) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int16 #x-8001) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int16 0.5) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :int16 "string") + :type 'wrong-type-argument) + + ;; `:uint16'. + (should (dbus-check-arguments :session dbus--test-service :uint16 0)) + (should (dbus-check-arguments :session dbus--test-service :uint16 #xffff)) + (should-error + (dbus-check-arguments :session dbus--test-service :uint16) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :uint16 #x10000) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint16 -1) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :uint16 0.5) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :uint16 "string") + :type 'wrong-type-argument) + + ;; `:int32'. + (should (dbus-check-arguments :session dbus--test-service :int32 0)) + (should (dbus-check-arguments :session dbus--test-service :int32 #x7fffffff)) + (should (dbus-check-arguments :session dbus--test-service :int32 #x-80000000)) + (should-error + (dbus-check-arguments :session dbus--test-service :int32) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :int32 #x80000000) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int32 #x-80000001) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int32 0.5) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int32 "string") + :type 'wrong-type-argument) + + ;; `:uint32'. + (should (dbus-check-arguments :session dbus--test-service 0)) + (should (dbus-check-arguments :session dbus--test-service :uint32 0)) + (should (dbus-check-arguments :session dbus--test-service :uint32 #xffffffff)) + (should-error + (dbus-check-arguments :session dbus--test-service :uint32) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :uint32 #x100000000) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint32 -1) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint32 0.5) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint32 "string") + :type 'wrong-type-argument) + + ;; `:int64'. + (should (dbus-check-arguments :session dbus--test-service :int64 0)) + (should + (dbus-check-arguments :session dbus--test-service :int64 #x7fffffffffffffff)) + (should + (dbus-check-arguments :session dbus--test-service :int64 #x-8000000000000000)) + (should-error + (dbus-check-arguments :session dbus--test-service :int64) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :int64 #x8000000000000000) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int64 #x-8000000000000001) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int64 0.5) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int64 "string") + :type 'wrong-type-argument) + + ;; `:uint64'. + (should (dbus-check-arguments :session dbus--test-service :uint64 0)) + (should + (dbus-check-arguments :session dbus--test-service :uint64 #xffffffffffffffff)) + (should-error + (dbus-check-arguments :session dbus--test-service :uint64) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :uint64 #x10000000000000000) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint64 -1) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint64 0.5) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint64 "string") + :type 'wrong-type-argument) + + ;; `:double'. + (should (dbus-check-arguments :session dbus--test-service :double 0)) + (should (dbus-check-arguments :session dbus--test-service :double 0.5)) + (should (dbus-check-arguments :session dbus--test-service :double -0.5)) + (should (dbus-check-arguments :session dbus--test-service :double -1)) + ;; Shall both be supported? + (should (dbus-check-arguments :session dbus--test-service :double 1.0e+INF)) + (should (dbus-check-arguments :session dbus--test-service :double 0.0e+NaN)) + (should-error + (dbus-check-arguments :session dbus--test-service :double) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :double "string") + :type 'wrong-type-argument) + + ;; `:unix-fd'. UNIX file descriptors are transferred out-of-band. + ;; We do not support this, and so we cannot do much testing here for + ;; `:unix-fd' being an argument (which is an index to the file + ;; descriptor in the array of file descriptors that accompany the + ;; D-Bus message). Mainly testing, that values out of `:uint32' + ;; type range fail. + (should (dbus-check-arguments :session dbus--test-service :unix-fd 0)) + (should-error + (dbus-check-arguments :session dbus--test-service :unix-fd) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :unix-fd -1) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :unix-fd 0.5) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :unix-fd "string") + :type 'wrong-type-argument)) + +(ert-deftest dbus-test01-compound-types () + "Check basic D-Bus type arguments." + (skip-unless dbus--test-enabled-session-bus) + + ;; `:array'. It contains several elements of the same type. + (should (dbus-check-arguments :session dbus--test-service '("string"))) + (should (dbus-check-arguments :session dbus--test-service '(:array "string"))) + (should + (dbus-check-arguments :session dbus--test-service '(:array :string "string"))) + (should + (dbus-check-arguments + :session dbus--test-service '(:array :string "string1" "string2"))) + (should + (dbus-check-arguments + :session dbus--test-service '(:array :signature "s" :signature "ao"))) + ;; Empty array (of strings). + (should (dbus-check-arguments :session dbus--test-service '(:array))) + ;; Empty array (of object paths). + (should + (dbus-check-arguments :session dbus--test-service '(:array :signature "o"))) + ;; Different element types. + (should-error + (dbus-check-arguments + :session dbus--test-service + '(:array :string "string" :object-path "/object/path")) + :type 'wrong-type-argument) + ;; Different variant types in array don't matter. + (should + (dbus-check-arguments + :session dbus--test-service + '(:array + (:variant :string "string1") + (:variant (:struct :string "string2" :object-path "/object/path"))))) + + ;; `:variant'. It contains exactly one element. + (should + (dbus-check-arguments + :session dbus--test-service '(:variant :string "string"))) + (should + (dbus-check-arguments + :session dbus--test-service '(:variant (:array "string")))) + ;; Empty variant. + (should-error + (dbus-check-arguments :session dbus--test-service '(:variant)) + :type 'wrong-type-argument) + ;; More than one element. + (should-error + (dbus-check-arguments + :session dbus--test-service + '(:variant :string "string" :object-path "/object/path")) + :type 'wrong-type-argument) + + ;; `:dict-entry'. It must contain two elements; the first one must + ;; be of a basic type. It must be an element of an array. + (should + (dbus-check-arguments + :session dbus--test-service + '(:array (:dict-entry :string "string" :boolean nil)))) + ;; This is an alternative syntax. + (should + (dbus-check-arguments + :session dbus--test-service + '(:array :dict-entry (:string "string" :boolean t)))) + ;; Empty dict-entry. + (should-error + (dbus-check-arguments + :session dbus--test-service '(:array (:dict-entry))) + :type 'wrong-type-argument) + ;; One element. + (should-error + (dbus-check-arguments + :session dbus--test-service '(:array (:dict-entry :string "string"))) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments + :session dbus--test-service + '(:array (:dict-entry :string "string" :boolean t :boolean t))) + :type 'wrong-type-argument) + ;; The first element ist not of a basic type. + (should-error + (dbus-check-arguments + :session dbus--test-service + '(:array (:dict-entry (:array :string "string") :boolean t))) + :type 'wrong-type-argument) + ;; It is not an element of an array. + (should-error + (dbus-check-arguments + :session dbus--test-service '(:dict-entry :string "string" :boolean t)) + :type 'wrong-type-argument) + ;; Different dict entry types in array. + (should-error + (dbus-check-arguments + :session dbus--test-service + '(:array + (:dict-entry :string "string1" :boolean t) + (:dict-entry :string "string2" :object-path "/object/path"))) + :type 'wrong-type-argument) + + ;; `:struct'. There is no restriction what could be an element of a struct. + (should + (dbus-check-arguments + :session dbus--test-service + '(:struct + :string "string" + :object-path "/object/path" + (:variant (:array :unix-fd 1 :unix-fd 2 :unix-fd 3 :unix-fd 4))))) + ;; Empty struct. + (should-error + (dbus-check-arguments :session dbus--test-service '(:struct)) + :type 'wrong-type-argument) + ;; Different struct types in array. + (should-error + (dbus-check-arguments + :session dbus--test-service + '(:array + (:struct :string "string1" :boolean t) + (:struct :object-path "/object/path"))) + :type 'wrong-type-argument)) + (defun dbus--test-register-service (bus) "Check service registration at BUS." ;; Cleanup. - (dbus-ignore-errors (dbus-unregister-service bus dbus-service-emacs)) + (dbus-ignore-errors (dbus-unregister-service bus dbus--test-service)) ;; Register an own service. - (should (eq (dbus-register-service bus dbus-service-emacs) :primary-owner)) - (should (member dbus-service-emacs (dbus-list-known-names bus))) - (should (eq (dbus-register-service bus dbus-service-emacs) :already-owner)) - (should (member dbus-service-emacs (dbus-list-known-names bus))) + (should (eq (dbus-register-service bus dbus--test-service) :primary-owner)) + (should (member dbus--test-service (dbus-list-known-names bus))) + (should (eq (dbus-register-service bus dbus--test-service) :already-owner)) + (should (member dbus--test-service (dbus-list-known-names bus))) ;; Unregister the service. - (should (eq (dbus-unregister-service bus dbus-service-emacs) :released)) - (should-not (member dbus-service-emacs (dbus-list-known-names bus))) - (should (eq (dbus-unregister-service bus dbus-service-emacs) :non-existent)) - (should-not (member dbus-service-emacs (dbus-list-known-names bus))) + (should (eq (dbus-unregister-service bus dbus--test-service) :released)) + (should-not (member dbus--test-service (dbus-list-known-names bus))) + (should (eq (dbus-unregister-service bus dbus--test-service) :non-existent)) + (should-not (member dbus--test-service (dbus-list-known-names bus))) ;; `dbus-service-dbus' is reserved for the BUS itself. - (should-error (dbus-register-service bus dbus-service-dbus)) - (should-error (dbus-unregister-service bus dbus-service-dbus))) + (should + (equal + (butlast + (should-error (dbus-register-service bus dbus-service-dbus))) + `(dbus-error ,dbus-error-invalid-args))) + (should + (equal + (butlast + (should-error (dbus-unregister-service bus dbus-service-dbus))) + `(dbus-error ,dbus-error-invalid-args)))) (ert-deftest dbus-test02-register-service-session () "Check service registration at `:session' bus." (skip-unless (and dbus--test-enabled-session-bus - (dbus-register-service :session dbus-service-emacs))) + (dbus-register-service :session dbus--test-service))) (dbus--test-register-service :session) (let ((service "org.freedesktop.Notifications")) @@ -124,7 +498,7 @@ (ert-deftest dbus-test02-register-service-system () "Check service registration at `:system' bus." (skip-unless (and dbus--test-enabled-system-bus - (dbus-register-service :system dbus-service-emacs))) + (dbus-register-service :system dbus--test-service))) (dbus--test-register-service :system)) (ert-deftest dbus-test02-register-service-own-bus () @@ -148,7 +522,7 @@ This includes initialization and closing the bus." (featurep 'dbusbind) (dbus-init-bus bus) (dbus-get-unique-name bus) - (dbus-register-service bus dbus-service-emacs)))) + (dbus-register-service bus dbus--test-service)))) ;; Run the test. (dbus--test-register-service bus)) @@ -159,25 +533,1472 @@ This includes initialization and closing the bus." "Check `dbus-interface-peer' methods." (skip-unless (and dbus--test-enabled-session-bus - (dbus-register-service :session dbus-service-emacs) + (dbus-register-service :session dbus--test-service) ;; "GetMachineId" is not implemented (yet). When it returns a ;; value, another D-Bus client like dbus-monitor is reacting ;; on `dbus-interface-peer'. We cannot test then. (not (dbus-ignore-errors (dbus-call-method - :session dbus-service-emacs dbus-path-dbus + :session dbus--test-service dbus-path-dbus dbus-interface-peer "GetMachineId" :timeout 100))))) - (should (dbus-ping :session dbus-service-emacs 100)) - (dbus-unregister-service :session dbus-service-emacs) - (should-not (dbus-ping :session dbus-service-emacs 100))) + (should (dbus-ping :session dbus--test-service 100)) + (dbus-unregister-service :session dbus--test-service) + (should-not (dbus-ping :session dbus--test-service 100))) + +(defun dbus--test-method-handler (&rest args) + "Method handler for `dbus-test04-register-method'." + (cond + ;; No argument. + ((null args) + :ignore) + ;; One argument. + ((= 1 (length args)) + (car args)) + ;; Two arguments. + ((= 2 (length args)) + `(:error ,dbus-error-invalid-args + ,(format-message "Wrong arguments %s" args))) + ;; More than two arguments. + (t (signal 'dbus-error (cons "D-Bus signal" args))))) + +(ert-deftest dbus-test04-register-method () + "Check method registration for an own service." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((method1 "Method1") + (method2 "Method2") + (handler #'dbus--test-method-handler) + registered) + + ;; The service is not registered yet. + (should + (equal + (butlast + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1 :timeout 10 "foo"))) + `(dbus-error ,dbus-error-service-unknown))) + + ;; Register. + (should + (equal + (setq + registered + (dbus-register-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1 handler)) + `((:method :session ,dbus--test-interface ,method1) + (,dbus--test-service ,dbus--test-path ,handler)))) + (should + (equal + (dbus-register-method + :session dbus--test-service dbus--test-path + dbus--test-interface method2 handler) + `((:method :session ,dbus--test-interface ,method2) + (,dbus--test-service ,dbus--test-path ,handler)))) + + ;; No argument, returns nil. + (should-not + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1)) + ;; One argument, returns the argument. + (should + (string-equal + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1 "foo") + "foo")) + ;; Two arguments, D-Bus error activated as `(:error ...)' list. + (should + (equal + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1 "foo" "bar")) + `(dbus-error ,dbus-error-invalid-args "Wrong arguments (foo bar)"))) + ;; Three arguments, D-Bus error activated by `dbus-error' signal. + (should + (equal + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1 "foo" "bar" "baz")) + `(dbus-error + ,dbus-error-failed + "D-Bus error: \"D-Bus signal\", \"foo\", \"bar\", \"baz\""))) + + ;; Unregister method. + (should (dbus-unregister-object registered)) + (should-not (dbus-unregister-object registered)) + (should + (equal + (butlast + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1 :timeout 10 "foo"))) + `(dbus-error ,dbus-error-no-reply)))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(defun dbus--test-method-reentry-handler (&rest _args) + "Method handler for `dbus-test04-method-reentry'." + (dbus-get-all-managed-objects :session dbus--test-service dbus--test-path) + 42) + +(ert-deftest dbus-test04-method-reentry () + "Check receiving method call while awaiting response. +Ensure that incoming method calls are handled when call to `dbus-call-method' +is in progress." + :tags '(:expensive-test) + ;; Simulate application registration. (Bug#43251) + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((method "Reentry")) + (should + (equal + (dbus-register-method + :session dbus--test-service dbus--test-path + dbus--test-interface method #'dbus--test-method-reentry-handler) + `((:method :session ,dbus--test-interface ,method) + (,dbus--test-service ,dbus--test-path + dbus--test-method-reentry-handler)))) + + (should + (= + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method) + 42))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test04-call-method-timeout () + "Verify `dbus-call-method' request timeout." + :tags '(:expensive-test) + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + (unwind-protect + (let ((start (current-time))) + ;; Test timeout override for method call. + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus-interface-introspectable "Introspect" :timeout 2500) + :type 'dbus-error) + + (should + (< 2.4 (float-time (time-since start)) 2.7))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(defvar dbus--test-signal-received nil + "Received signal value in `dbus--test-signal-handler'.") + +(defun dbus--test-signal-handler (&rest args) + "Signal handler for `dbus-test*-signal' and `dbus-test08-register-monitor'." + (setq dbus--test-signal-received args)) + +(defun dbus--test-timeout-handler (&rest _ignore) + "Timeout handler, reporting a failed test." + (ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test))))) + +(ert-deftest dbus-test05-register-signal () + "Check signal registration for an own service." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((member "Member") + (handler #'dbus--test-signal-handler) + registered) + + ;; Register signal handler. + (should + (equal + (setq + registered + (dbus-register-signal + :session dbus--test-service dbus--test-path + dbus--test-interface member handler)) + `((:signal :session ,dbus--test-interface ,member) + (,dbus--test-service ,dbus--test-path ,handler)))) + + ;; Send one argument, basic type. + (setq dbus--test-signal-received nil) + (dbus-send-signal + :session dbus--test-service dbus--test-path + dbus--test-interface member "foo") + (with-timeout (1 (dbus--test-timeout-handler)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + (should (equal dbus--test-signal-received '("foo"))) + + ;; Send two arguments, compound types. + (setq dbus--test-signal-received nil) + (dbus-send-signal + :session dbus--test-service dbus--test-path + dbus--test-interface member + '(:array :byte 1 :byte 2 :byte 3) '(:variant :string "bar")) + (with-timeout (1 (dbus--test-timeout-handler)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + (should (equal dbus--test-signal-received '((1 2 3) ("bar")))) + + ;; Unregister signal. + (should (dbus-unregister-object registered)) + (should-not (dbus-unregister-object registered))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test06-register-property () + "Check property registration for an own service." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((property1 "Property1") + (property2 "Property2") + (property3 "Property3") + (property4 "Property4") + registered) + + ;; `:read' property. + (should + (equal + (setq + registered + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1 :read "foo")) + `((:property :session ,dbus--test-interface ,property1) + (,dbus--test-service ,dbus--test-path)))) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1) + "foo")) + ;; Due to `:read' access type, we don't get a proper reply + ;; from `dbus-set-property'. + (should + (equal + (butlast + (should-error + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1 "foofoo"))) + `(dbus-error ,dbus-error-property-read-only))) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1) + "foo")) + + ;; `:write' property. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2 :write "bar") + `((:property :session ,dbus--test-interface ,property2) + (,dbus--test-service ,dbus--test-path)))) + ;; Due to `:write' access type, we don't get a proper reply + ;; from `dbus-get-property'. + (should + (equal + (butlast + (should-error + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2))) + `(dbus-error ,dbus-error-access-denied))) + (should + (string-equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2 "barbar") + "barbar")) + ;; Still `:write' access type. + (should + (equal + (butlast + (should-error + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2))) + `(dbus-error ,dbus-error-access-denied))) + + ;; `:readwrite' property, typed value (Bug#43252). + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property3 :readwrite :object-path "/baz") + `((:property :session ,dbus--test-interface ,property3) + (,dbus--test-service ,dbus--test-path)))) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property3) + "/baz")) + (should + (string-equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property3 :object-path "/baz/baz") + "/baz/baz")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property3) + "/baz/baz")) + + ;; Not registered property. + (should + (equal + (butlast + (should-error + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property4))) + `(dbus-error ,dbus-error-unknown-property))) + (should + (equal + (butlast + (should-error + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property4 "foobarbaz"))) + `(dbus-error ,dbus-error-unknown-property))) + + ;; `dbus-get-all-properties'. We cannot retrieve a value for + ;; the property with `:write' access type. + (let ((result + (dbus-get-all-properties + :session dbus--test-service dbus--test-path + dbus--test-interface))) + (should (string-equal (cdr (assoc property1 result)) "foo")) + (should (string-equal (cdr (assoc property3 result)) "/baz/baz")) + (should-not (assoc property2 result))) + + ;; `dbus-get-all-managed-objects'. We cannot retrieve a value for + ;; the property with `:write' access type. + (let ((result + (dbus-get-all-managed-objects + :session dbus--test-service dbus--test-path))) + (should (setq result (cadr (assoc dbus--test-path result)))) + (should (setq result (cadr (assoc dbus--test-interface result)))) + (should (string-equal (cdr (assoc property1 result)) "foo")) + (should (string-equal (cdr (assoc property3 result)) "/baz/baz")) + (should-not (assoc property2 result))) + + ;; Unregister property. + (should (dbus-unregister-object registered)) + (should-not (dbus-unregister-object registered)) + (should + (equal + (butlast + (should-error + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1))) + `(dbus-error ,dbus-error-unknown-property)))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +;; The following test is inspired by Bug#43146. +(ert-deftest dbus-test06-register-property-several-paths () + "Check property registration for an own service at several paths." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((property1 "Property1") + (property2 "Property2") + (property3 "Property3")) + + ;; First path. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1 :readwrite "foo") + `((:property :session ,dbus--test-interface ,property1) + (,dbus--test-service ,dbus--test-path)))) + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2 :readwrite "bar") + `((:property :session ,dbus--test-interface ,property2) + (,dbus--test-service ,dbus--test-path)))) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1) + "foo")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2) + "bar")) + + (should + (string-equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1 "foofoo") + "foofoo")) + (should + (string-equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2 "barbar") + "barbar")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1) + "foofoo")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2) + "barbar")) + + ;; Second path. + (should + (equal + (dbus-register-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property2 :readwrite "foo") + `((:property :session ,dbus--test-interface ,property2) + (,dbus--test-service ,(concat dbus--test-path dbus--test-path))))) + (should + (equal + (dbus-register-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property3 :readwrite "bar") + `((:property :session ,dbus--test-interface ,property3) + (,dbus--test-service ,(concat dbus--test-path dbus--test-path))))) + (should + (string-equal + (dbus-get-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property2) + "foo")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property3) + "bar")) + + (should + (string-equal + (dbus-set-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property2 "foofoo") + "foofoo")) + (should + (string-equal + (dbus-set-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property3 "barbar") + "barbar")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property2) + "foofoo")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property3) + "barbar")) + + ;; Everything is still fine, tested with `dbus-get-all-properties'. + (let ((result + (dbus-get-all-properties + :session dbus--test-service dbus--test-path + dbus--test-interface))) + (should (string-equal (cdr (assoc property1 result)) "foofoo")) + (should (string-equal (cdr (assoc property2 result)) "barbar")) + (should-not (assoc property3 result))) + + (let ((result + (dbus-get-all-properties + :session dbus--test-service + (concat dbus--test-path dbus--test-path) dbus--test-interface))) + (should (string-equal (cdr (assoc property2 result)) "foofoo")) + (should (string-equal (cdr (assoc property3 result)) "barbar")) + (should-not (assoc property1 result))) + + ;; Final check with `dbus-get-all-managed-objects'. + (let ((result + (dbus-get-all-managed-objects :session dbus--test-service "/")) + result1) + (should (setq result1 (cadr (assoc dbus--test-path result)))) + (should (setq result1 (cadr (assoc dbus--test-interface result1)))) + (should (string-equal (cdr (assoc property1 result1)) "foofoo")) + (should (string-equal (cdr (assoc property2 result1)) "barbar")) + (should-not (assoc property3 result1)) + + (should + (setq + result1 + (cadr (assoc (concat dbus--test-path dbus--test-path) result)))) + (should (setq result1 (cadr (assoc dbus--test-interface result1)))) + (should (string-equal (cdr (assoc property2 result1)) "foofoo")) + (should (string-equal (cdr (assoc property3 result1)) "barbar")) + (should-not (assoc property1 result1)))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test06-register-property-emits-signal () + "Check property registration for an own service, including signalling." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((property "Property") + (handler #'dbus--test-signal-handler)) + + ;; Register signal handler. + (should + (equal + (dbus-register-signal + :session dbus--test-service dbus--test-path + dbus-interface-properties "PropertiesChanged" handler) + `((:signal :session ,dbus-interface-properties "PropertiesChanged") + (,dbus--test-service ,dbus--test-path ,handler)))) + + ;; Register property. + (setq dbus--test-signal-received nil) + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property :readwrite "foo" 'emits-signal) + `((:property :session ,dbus--test-interface ,property) + (,dbus--test-service ,dbus--test-path)))) + (with-timeout (1 (dbus--test-timeout-handler)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + ;; It returns three arguments, "interface" (a string), + ;; "changed_properties" (an array of dict entries) and + ;; "invalidated_properties" (an array of strings). + (should + (equal dbus--test-signal-received + `(,dbus--test-interface ((,property ("foo"))) ()))) + + (should + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property) + "foo")) + + ;; Set property. The new value shall be signalled. + (setq dbus--test-signal-received nil) + (should + (equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property + '(:array :byte 1 :byte 2 :byte 3)) + '(1 2 3))) + (with-timeout (1 (dbus--test-timeout-handler)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + (should + (equal + dbus--test-signal-received + `(,dbus--test-interface ((,property ((1 2 3)))) ()))) + + (should + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property) + '(1 2 3)))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(defsubst dbus--test-run-property-test (selector name value expected) + "Generate a property test: register, set, get, getall sequence. +This is a helper function for the macro `dbus--test-property'. +The argument SELECTOR indicates whether the test should expand to +`dbus-register-property' (if SELECTOR is `register') or +`dbus-set-property' (if SELECTOR is `set'). +The argument NAME is the property name. +The argument VALUE is the value to register or set. +The argument EXPECTED is a transformed VALUE representing the +form `dbus-get-property' should return." + (cond + ((eq selector 'register) + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface name + :readwrite value) + `((:property :session ,dbus--test-interface ,name) + (,dbus--test-service ,dbus--test-path))))) + + ((eq selector 'set) + (should + (equal + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface name + value) + expected))) + + (t (signal 'wrong-type-argument "Selector should be 'register or 'set."))) + + (should + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface name) + expected)) + + (let ((result + (dbus-get-all-properties + :session dbus--test-service dbus--test-path dbus--test-interface))) + (should (equal (cdr (assoc name result)) expected))) + + (let ((result + (dbus-get-all-managed-objects :session dbus--test-service "/")) + result1) + (should (setq result1 (cadr (assoc dbus--test-path result)))) + (should (setq result1 (cadr (assoc dbus--test-interface result1)))) + (should (equal (cdr (assoc name result1)) expected)))) + +(defsubst dbus--test-property (name &rest value-list) + "Test a D-Bus property named by string argument NAME. +The argument VALUE-LIST is a sequence of pairs, where each pair +represents a value form and an expected returned value form. The +first pair in VALUES is used for `dbus-register-property'. +Subsequent pairs of the list are tested with `dbus-set-property'." + (let ((values (car value-list))) + (dbus--test-run-property-test + 'register name (car values) (cdr values))) + (dolist (values (cdr value-list)) + (dbus--test-run-property-test + 'set name (car values) (cdr values)))) + +(ert-deftest dbus-test06-property-types () + "Check property access and mutation for an own service." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + (unwind-protect + (progn + (dbus--test-property + "ByteArray" + '((:array :byte 1 :byte 2 :byte 3) . (1 2 3)) + '((:array :byte 4 :byte 5 :byte 6) . (4 5 6))) + + (dbus--test-property + "StringArray" + '((:array "one" "two" :string "three") . ("one" "two" "three")) + '((:array :string "four" :string "five" "six") . ("four" "five" "six"))) + + (dbus--test-property + "ObjectArray" + '((:array + :object-path "/node00" + :object-path "/node01" + :object-path "/node0/node02") + . ("/node00" "/node01" "/node0/node02")) + '((:array + :object-path "/node10" + :object-path "/node11" + :object-path "/node0/node12") + . ("/node10" "/node11" "/node0/node12"))) + + (dbus--test-property + "Dictionary" + '((:array + :dict-entry (:string "four" (:variant :string "value of four")) + :dict-entry ("five" (:variant :object-path "/node0")) + :dict-entry ("six" (:variant (:array :byte 4 :byte 5 :byte 6)))) + . (("four" + ("value of four")) + ("five" + ("/node0")) + ("six" + ((4 5 6))))) + '((:array + :dict-entry + (:string "key0" (:variant (:array :byte 7 :byte 8 :byte 9))) + :dict-entry ("key1" (:variant :string "value")) + :dict-entry ("key2" (:variant :object-path "/node0/node1"))) + . (("key0" + ((7 8 9))) + ("key1" + ("value")) + ("key2" + ("/node0/node1"))))) + + (dbus--test-property ; Syntax emphasizing :dict compound type. + "Dictionary" + '((:array + (:dict-entry :string "seven" (:variant :string "value of seven")) + (:dict-entry "eight" (:variant :object-path "/node8")) + (:dict-entry "nine" (:variant (:array :byte 9 :byte 27 :byte 81)))) + . (("seven" + ("value of seven")) + ("eight" + ("/node8")) + ("nine" + ((9 27 81))))) + '((:array + (:dict-entry + :string "key4" (:variant (:array :byte 7 :byte 49 :byte 125))) + (:dict-entry "key5" (:variant :string "obsolete")) + (:dict-entry "key6" (:variant :object-path "/node6/node7"))) + . (("key4" + ((7 49 125))) + ("key5" + ("obsolete")) + ("key6" + ("/node6/node7"))))) + + (dbus--test-property + "ByteDictionary" + '((:array + (:dict-entry :byte 8 (:variant :string "byte-eight")) + (:dict-entry :byte 16 (:variant :object-path "/byte/sixteen")) + (:dict-entry :byte 48 (:variant (:array :byte 8 :byte 9 :byte 10)))) + . (( 8 ("byte-eight")) + (16 ("/byte/sixteen")) + (48 ((8 9 10)))))) + + (dbus--test-property + "Variant" + '((:variant "Variant string") . ("Variant string")) + '((:variant :byte 42) . (42)) + '((:variant :uint32 1000000) . (1000000)) + '((:variant :object-path "/variant/path") . ("/variant/path")) + '((:variant :signature "a{sa{sv}}") . ("a{sa{sv}}")) + '((:variant + (:struct + 42 "string" (:object-path "/structure/path") (:variant "last"))) + . ((42 "string" ("/structure/path") ("last"))))) + + ;; Test that :read prevents writes. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "StringArray" :read '(:array "one" "two" :string "three")) + `((:property :session ,dbus--test-interface "StringArray") + (,dbus--test-service ,dbus--test-path)))) + + (should-error ; Cannot set property with :read access. + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface + "StringArray" '(:array "seven" "eight" :string "nine")) + :type 'dbus-error) + + (should ; Property value preserved on error. + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "StringArray") + '("one" "two" "three"))) + + ;; Test mismatched types in array. + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "MixedArray" :readwrite + '(:array + :object-path "/node00" + :string "/node01" + :object-path "/node0/node02")) + :type 'wrong-type-argument) + + ;; Test in-range integer values. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue" :readwrite :byte 255) + `((:property :session ,dbus--test-interface "ByteValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue") + 255)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ShortValue" :readwrite :int16 32767) + `((:property :session ,dbus--test-interface "ShortValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ShortValue") + 32767)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UShortValue" :readwrite :uint16 65535) + `((:property :session ,dbus--test-interface "UShortValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UShortValue") + 65535)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "IntValue" :readwrite :int32 2147483647) + `((:property :session ,dbus--test-interface "IntValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "IntValue") + 2147483647)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UIntValue" :readwrite :uint32 4294967295) + `((:property :session ,dbus--test-interface "UIntValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UIntValue") + 4294967295)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "LongValue" :readwrite :int64 9223372036854775807) + `((:property :session ,dbus--test-interface "LongValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "LongValue") + 9223372036854775807)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ULongValue" :readwrite :uint64 18446744073709551615) + `((:property :session ,dbus--test-interface "ULongValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ULongValue") + 18446744073709551615)) + + ;; Test integer overflow. + (should + (= + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue" :byte 520) + 8)) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue") + 8)) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ShortValue" :readwrite :int16 32800) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UShortValue" :readwrite :uint16 65600) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "IntValue" :readwrite :int32 2147483700) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UIntValue" :readwrite :uint32 4294967300) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "LongValue" :readwrite :int64 9223372036854775900) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ULongValue" :readwrite :uint64 18446744073709551700) + :type 'args-out-of-range) + + ;; dbus-set-property may change property type. + (should + (= + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue" 1024) + 1024)) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue") + 1024)) + + (should ; Another change property type test. + (equal + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue" :boolean t) + t)) + + (should + (eq + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue") + t)) + + ;; Test invalid type specification. + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "InvalidType" :readwrite :keyword 128) + :type 'wrong-type-argument)) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(defun dbus--test-introspect () + "Return test introspection string." + (when (string-equal dbus--test-path (dbus-event-path-name last-input-event)) + (with-temp-buffer + (insert-file-contents-literally + (ert-resource-file "org.gnu.Emacs.TestDBus.xml")) + (buffer-string)))) + +(defsubst dbus--test-validate-interface + (iface-name expected-properties expected-methods expected-signals + expected-annotations) + "Validate an interface definition for `dbus-test07-introspection'. +The argument IFACE-NAME is a string naming the interface to validate. +The arguments EXPECTED-PROPERTIES, EXPECTED-METHODS, EXPECTED-SIGNALS, and +EXPECTED-ANNOTATIONS represent the names of the interface's properties, +methods, signals, and annotations, respectively." + + (let ((interface + (dbus-introspect-get-interface + :session dbus--test-service dbus--test-path iface-name))) + (pcase-let ((`(interface ((name . ,name)) . ,rest) interface)) + (should + (string-equal name iface-name)) + (should + (string-equal name (dbus-introspect-get-attribute interface "name"))) + + (let (properties methods signals annotations) + (mapc (lambda (x) + (let ((name (dbus-introspect-get-attribute x "name"))) + (cond + ((eq 'property (car x)) (push name properties)) + ((eq 'method (car x)) (push name methods)) + ((eq 'signal (car x)) (push name signals)) + ((eq 'annotation (car x)) (push name annotations))))) + rest) + + (should + (equal + (nreverse properties) + expected-properties)) + (should + (equal + (nreverse methods) + expected-methods)) + (should + (equal + (nreverse signals) + expected-signals)) + (should + (equal + (nreverse annotations) + expected-annotations)))))) + +(defsubst dbus--test-validate-annotations (annotations expected-annotations) + "Validate a list of D-Bus ANNOTATIONS. +Ensure each string in EXPECTED-ANNOTATIONS names an element of ANNOTATIONS. +And ensure each ANNOTATIONS has a value attribute marked \"true\"." + (mapc + (lambda (annotation) + (let ((name (dbus-introspect-get-attribute annotation "name")) + (value (dbus-introspect-get-attribute annotation "value"))) + (should + (member name expected-annotations)) + (should + (equal value "true")))) + annotations)) + +(defsubst dbus--test-validate-property + (interface property-name _expected-annotations &rest expected-args) + "Validate a property definition for `dbus-test07-introspection'. + +The argument INTERFACE is a string naming the interface owning PROPERTY-NAME. +The argument PROPERTY-NAME is a string naming the property to validate. +The arguments EXPECTED-ANNOTATIONS is a list of strings matching +the annotation names defined for the method or signal. +The argument EXPECTED-ARGS is a list of expected arguments for the property." + (let* ((property + (dbus-introspect-get-property + :session dbus--test-service dbus--test-path interface property-name)) + (name (dbus-introspect-get-attribute property "name")) + (type (dbus-introspect-get-attribute property "type")) + (access (dbus-introspect-get-attribute property "access")) + (expected (assoc-string name expected-args))) + (should expected) + + (should + (string-equal name property-name)) + + (should + (string-equal + (nth 0 expected) + name)) + + (should + (string-equal + (nth 1 expected) + type)) + + (should + (string-equal + (nth 2 expected) + access)))) + +(defsubst dbus--test-validate-m-or-s (tree expected-annotations expected-args) + "Validate a method or signal definition for `dbus-test07-introspection'. +The argument TREE is an sexp returned from either `dbus-introspect-get-method' +or `dbus-introspect-get-signal' +The arguments EXPECTED-ANNOTATIONS is a list of strings matching +the annotation names defined for the method or signal. +The argument EXPECTED-ARGS is a list of expected arguments for +the method or signal." + (let (args annotations) + (mapc (lambda (elem) + (cond + ((eq 'arg (car elem)) (push elem args)) + ((eq 'annotation (car elem)) (push elem annotations)))) + tree) + (should + (equal + (nreverse args) + expected-args)) + (dbus--test-validate-annotations annotations expected-annotations))) + +(defsubst dbus--test-validate-signal + (interface signal-name expected-annotations &rest expected-args) + "Validate a signal definition for `dbus-test07-introspection'. + +The argument INTERFACE is a string naming the interface owning SIGNAL-NAME. +The argument SIGNAL-NAME is a string naming the signal to validate. +The arguments EXPECTED-ANNOTATIONS is a list of strings matching +the annotation names defined for the signal. +The argument EXPECTED-ARGS is a list of expected arguments for the signal." + (let ((signal + (dbus-introspect-get-signal + :session dbus--test-service dbus--test-path interface signal-name))) + (pcase-let ((`(signal ((name . ,name)) . ,rest) signal)) + (should + (string-equal name signal-name)) + (should + (string-equal name (dbus-introspect-get-attribute signal "name"))) + (dbus--test-validate-m-or-s rest expected-annotations expected-args)))) + +(defsubst dbus--test-validate-method + (interface method-name expected-annotations &rest expected-args) + "Validate a method definition for `dbus-test07-introspection'. + +The argument INTERFACE is a string naming the interface owning METHOD-NAME. +The argument METHOD-NAME is a string naming the method to validate. +The arguments EXPECTED-ANNOTATIONS is a list of strings matching +the annotation names defined for the method. +The argument EXPECTED-ARGS is a list of expected arguments for the method." + (let ((method + (dbus-introspect-get-method + :session dbus--test-service dbus--test-path interface method-name))) + (pcase-let ((`(method ((name . ,name)) . ,rest) method)) + (should + (string-equal name method-name)) + (should + (string-equal name (dbus-introspect-get-attribute method "name"))) + (dbus--test-validate-m-or-s rest expected-annotations expected-args)))) + +(ert-deftest dbus-test07-introspection () + "Register an Introspection interface then query it." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + ;; Prepare introspection response. + (dbus-register-method + :session dbus--test-service dbus--test-path dbus-interface-introspectable + "Introspect" 'dbus--test-introspect) + (dbus-register-method + :session dbus--test-service (concat dbus--test-path "/node0") + dbus-interface-introspectable + "Introspect" 'dbus--test-introspect) + (dbus-register-method + :session dbus--test-service (concat dbus--test-path "/node1") + dbus-interface-introspectable + "Introspect" 'dbus--test-introspect) + (unwind-protect + (let ((start (current-time))) + ;; dbus-introspect-get-node-names + (should + (equal + (dbus-introspect-get-node-names + :session dbus--test-service dbus--test-path) + '("node0" "node1"))) + + ;; dbus-introspect-get-all-nodes + (should + (equal + (dbus-introspect-get-all-nodes + :session dbus--test-service dbus--test-path) + (list dbus--test-path + (concat dbus--test-path "/node0") + (concat dbus--test-path "/node1")))) + + ;; dbus-introspect-get-interface-names + (let ((interfaces + (dbus-introspect-get-interface-names + :session dbus--test-service dbus--test-path))) + + (should + (equal + interfaces + `(,dbus-interface-introspectable + ,dbus-interface-properties + ,dbus--test-interface))) + + (dbus--test-validate-interface + dbus-interface-introspectable nil '("Introspect") nil nil) + + ;; dbus-introspect-get-interface via `dbus--test-validate-interface'. + (dbus--test-validate-interface + dbus-interface-properties nil + '("Get" "Set" "GetAll") '("PropertiesChanged") nil) + + (dbus--test-validate-interface + dbus--test-interface '("Connected" "Player") + '("Connect" "DeprecatedMethod0" "DeprecatedMethod1") nil + `(,dbus-annotation-deprecated))) + + ;; dbus-introspect-get-method-names + (let ((methods + (dbus-introspect-get-method-names + :session dbus--test-service dbus--test-path + dbus--test-interface))) + (should + (equal + methods + '("Connect" "DeprecatedMethod0" "DeprecatedMethod1"))) + + ;; dbus-introspect-get-method via `dbus--test-validate-method'. + (dbus--test-validate-method + dbus--test-interface "Connect" nil + '(arg ((name . "uuid") (type . "s") (direction . "in"))) + '(arg ((name . "mode") (type . "y") (direction . "in"))) + '(arg ((name . "options") (type . "a{sv}") (direction . "in"))) + '(arg ((name . "interface") (type . "s") (direction . "out")))) + + (dbus--test-validate-method + dbus--test-interface "DeprecatedMethod0" + `(,dbus-annotation-deprecated)) + + (dbus--test-validate-method + dbus--test-interface "DeprecatedMethod1" + `(,dbus-annotation-deprecated))) + + ;; dbus-introspect-get-signal-names + (let ((signals + (dbus-introspect-get-signal-names + :session dbus--test-service dbus--test-path + dbus-interface-properties))) + (should + (equal + signals + '("PropertiesChanged"))) + + ;; dbus-introspect-get-signal via `dbus--test-validate-signal'. + (dbus--test-validate-signal + dbus-interface-properties "PropertiesChanged" nil + '(arg ((name . "interface") (type . "s"))) + '(arg ((name . "changed_properties") (type . "a{sv}"))) + '(arg ((name . "invalidated_properties") (type . "as"))))) + + ;; dbus-intropct-get-property-names + (let ((properties + (dbus-introspect-get-property-names + :session dbus--test-service dbus--test-path + dbus--test-interface))) + (should + (equal + properties + '("Connected" "Player"))) + + ;; dbus-introspect-get-property via `dbus--test-validate-property'. + (dbus--test-validate-property + dbus--test-interface "Connected" nil + '("Connected" "b" "read") + '("Player" "o" "read"))) + + ;; Elapsed time over a second suggests timeouts. + (should + (< 0.0 (float-time (time-since start)) 1.0))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test07-introspection-timeout () + "Verify introspection request timeouts." + :tags '(:expensive-test) + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + (unwind-protect + (let ((start (current-time))) + (dbus-introspect-xml :session dbus--test-service dbus--test-path) + ;; Introspection internal timeout is one second. + (should + (< 1.0 (float-time (time-since start))))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test08-register-monitor () + "Check monitor registration." + :tags '(:expensive-test) + (skip-unless dbus--test-enabled-session-bus) + + (unwind-protect + (let (registered) + (should + (equal + (setq registered + (dbus-register-monitor :session #'dbus--test-signal-handler)) + '((:monitor :session-private) + (nil nil dbus--test-signal-handler)))) + + ;; Send a signal, shall be traced. + (setq dbus--test-signal-received nil) + (dbus-send-signal + :session dbus--test-service dbus--test-path + dbus--test-interface "Foo" "foo") + (with-timeout (1 (dbus--test-timeout-handler)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + + ;; Unregister monitor. + (should (dbus-unregister-object registered)) + (should-not (dbus-unregister-object registered)) + + ;; Send a signal, shall not be traced. + (setq dbus--test-signal-received nil) + (dbus-send-signal + :session dbus--test-service dbus--test-path + dbus--test-interface "Foo" "foo") + (with-timeout (1 (ignore)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + (should-not dbus--test-signal-received)) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test09-get-managed-objects () + "Check `dbus-get-all-managed-objects'." + :tags '(:expensive-test) + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + (unwind-protect + (let ((interfaces + `((,(concat dbus--test-interface ".I0") + ((,(concat dbus--test-path "/obj1") + (("I0Property1" . "Zero one one") + ("I0Property2" . "Zero one two") + ("I0Property3" . "Zero one three"))) + (,(concat dbus--test-path "/obj0/obj2") + (("I0Property1" . "Zero two one") + ("I0Property2" . "Zero two two") + ("I0Property3" . "Zero two three"))) + (,(concat dbus--test-path "/obj0/obj3") + (("I0Property1" . "Zero three one") + ("I0Property2" . "Zero three two") + ("I0Property3" . "Zero three three"))))) + (,(concat dbus--test-interface ".I1") + ((,(concat dbus--test-path "/obj0/obj2") + (("I1Property1" . "One one one") + ("I1Property2" . "One one two"))) + (,(concat dbus--test-path "/obj0/obj3") + (("I1Property1" . "One two one") + ("I1Property2" . "One two two")))))))) + + (should-not + (dbus-get-all-managed-objects + :session dbus--test-service dbus--test-path)) + + (dolist (interface interfaces) + (pcase-let ((`(,iname ,objs) interface)) + (dolist (obj objs) + (pcase-let ((`(,path ,props) obj)) + (dolist (prop props) + (should + (equal + (dbus-register-property + :session dbus--test-service path iname + (car prop) :readwrite (cdr prop)) + `((:property :session ,iname ,(car prop)) + (,dbus--test-service ,path))))))))) + + (let ((result (dbus-get-all-managed-objects + :session dbus--test-service dbus--test-path))) + (should + (= 3 (length result))) + + (dolist (interface interfaces) + (pcase-let ((`(,iname ,objs) interface)) + (dolist (obj objs) + (pcase-let ((`(,path ,props) obj)) + (let* ((object (cadr (assoc-string path result))) + (iface (cadr (assoc-string iname object)))) + (should object) + (should iface) + (dolist (prop props) + (should (equal (cdr (assoc-string (car prop) iface)) + (cdr prop)))))))))) + + (let ((result (dbus-get-all-managed-objects + :session dbus--test-service + (concat dbus--test-path "/obj0")))) + (should + (= 2 (length result))) + + (dolist (interface interfaces) + (pcase-let ((`(,iname ,objs) interface)) + (dolist (obj objs) + (pcase-let ((`(,path ,props) obj)) + (when (string-prefix-p (concat dbus--test-path "/obj0/") path) + (let* ((object (cadr (assoc-string path result))) + (iface (cadr (assoc-string iname object)))) + (should object) + (should iface) + (dolist (prop props) + (should (equal (cdr (assoc-string (car prop) iface)) + (cdr prop))))))))))) + + (let ((result (dbus-get-all-managed-objects + :session dbus--test-service + (concat dbus--test-path "/obj0/obj2")))) + (should + (= 1 (length result))) + + (dolist (interface interfaces) + (pcase-let ((`(,iname ,objs) interface)) + (dolist (obj objs) + (pcase-let ((`(,path ,props) obj)) + (when (string-prefix-p + (concat dbus--test-path "/obj0/obj2") path) + (let* ((object (cadr (assoc-string path result))) + (iface (cadr (assoc-string iname object)))) + (should object) + (should iface) + (dolist (prop props) + (should (equal (cdr (assoc-string (car prop) iface)) + (cdr prop)))))))))))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) (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..5205f0b851f 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. @@ -241,6 +241,7 @@ (ert-deftest test-gnutls-005-aead-ciphers () "Test the GnuTLS AEAD ciphers" + :tags '(:expensive-test) (skip-unless (memq 'AEAD-ciphers (gnutls-available-p))) (setq gnutls-tests-message-prefix "AEAD verification: ") (let ((keys '("mykey" "mykey2")) 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/mailcap-resources/mime.types b/test/lisp/net/mailcap-resources/mime.types new file mode 100644 index 00000000000..4bedfaf9702 --- /dev/null +++ b/test/lisp/net/mailcap-resources/mime.types @@ -0,0 +1,5 @@ +# this is a comment + +audio/ogg opus +audio/flac flac +audio/x-wav wav diff --git a/test/lisp/net/mailcap-tests.el b/test/lisp/net/mailcap-tests.el index 8354d8e5e23..0ebbec61159 100644 --- a/test/lisp/net/mailcap-tests.el +++ b/test/lisp/net/mailcap-tests.el @@ -24,13 +24,10 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'mailcap) -(defconst mailcap-tests-data-dir - (expand-file-name "test/data/mailcap" source-directory)) - -(defconst mailcap-tests-path - (expand-file-name "mime.types" mailcap-tests-data-dir) +(defconst mailcap-tests-path (ert-resource-file "mime.types") "String used as PATH argument of `mailcap-parse-mimetypes'.") (defconst mailcap-tests-mime-extensions (copy-alist mailcap-mime-extensions)) diff --git a/test/lisp/net/netrc-resources/authinfo b/test/lisp/net/netrc-resources/authinfo new file mode 100644 index 00000000000..88aa1712e9d --- /dev/null +++ b/test/lisp/net/netrc-resources/authinfo @@ -0,0 +1,2 @@ +machine imap.example.org login jrh@example.org password "*foobar*" +machine ftp.example.org login jrh password "*baz*" diff --git a/test/lisp/net/netrc-resources/services b/test/lisp/net/netrc-resources/services new file mode 100644 index 00000000000..fd8a0348df2 --- /dev/null +++ b/test/lisp/net/netrc-resources/services @@ -0,0 +1,6 @@ +tcpmux 1/tcp # TCP port service multiplexer +smtp 25/tcp mail +http 80/tcp www # WorldWideWeb HTTP +kerberos 88/tcp kerberos5 krb5 kerberos-sec # Kerberos v5 +kerberos 88/udp kerberos5 krb5 kerberos-sec # Kerberos v5 +rtmp 1/ddp # Routing Table Maintenance Protocol diff --git a/test/lisp/net/netrc-tests.el b/test/lisp/net/netrc-tests.el new file mode 100644 index 00000000000..291943990ad --- /dev/null +++ b/test/lisp/net/netrc-tests.el @@ -0,0 +1,53 @@ +;;; netrc-tests.el --- Tests for netrc.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@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 +;; (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/>. + +;;; Code: + +(require 'ert) +(require 'ert-x) +(require 'netrc) + +(ert-deftest test-netrc-parse-services () + (let ((netrc-services-file (ert-resource-file "services"))) + (should (equal (netrc-parse-services) + '(("tcpmux" 1 tcp) + ("smtp" 25 tcp) + ("http" 80 tcp) + ("kerberos" 88 tcp) + ("kerberos" 88 udp) + ("rtmp" 1 ddp)))))) + +(ert-deftest test-netrc-find-service-name () + (let ((netrc-services-file (ert-resource-file "services"))) + (should (equal (netrc-find-service-name 25) "smtp")) + (should (equal (netrc-find-service-name 88 'udp) "kerberos")) + (should-not (netrc-find-service-name 12345)))) + +(ert-deftest test-netrc-credentials () + (let ((netrc-file (ert-resource-file "authinfo"))) + (should (equal (netrc-credentials "imap.example.org") + '("jrh@example.org" "*foobar*"))) + (should (equal (netrc-credentials "ftp.example.org") + '("jrh" "*baz*"))))) + +(provide 'netrc-tests) + +;;; netrc-tests.el ends here diff --git a/test/lisp/net/network-stream-resources/cert.pem b/test/lisp/net/network-stream-resources/cert.pem new file mode 100644 index 00000000000..4df4e92e0bf --- /dev/null +++ b/test/lisp/net/network-stream-resources/cert.pem @@ -0,0 +1,25 @@ +-----BEGIN CERTIFICATE----- +MIIELTCCAxWgAwIBAgIJAI6LqlFyaPRkMA0GCSqGSIb3DQEBCwUAMIGsMQswCQYD +VQQGEwJBVTEYMBYGA1UECAwPTmV3IFNvdXRoIFdhbGVzMQ8wDQYDVQQHDAZTeWRu +ZXkxITAfBgNVBAoMGEVtYWNzIFRlc3QgU2VydmljZXNzIExMQzESMBAGA1UECwwJ +QXV0b21hdGVkMRcwFQYDVQQDDA50ZXN0LmVtYWNzLnpvdDEiMCAGCSqGSIb3DQEJ +ARYTZW1hY3MtZGV2ZWxAZnNmLm9yZzAeFw0xNjAyMDgwNDA0MzJaFw0xNjAzMDkw +NDA0MzJaMIGsMQswCQYDVQQGEwJBVTEYMBYGA1UECAwPTmV3IFNvdXRoIFdhbGVz +MQ8wDQYDVQQHDAZTeWRuZXkxITAfBgNVBAoMGEVtYWNzIFRlc3QgU2VydmljZXNz +IExMQzESMBAGA1UECwwJQXV0b21hdGVkMRcwFQYDVQQDDA50ZXN0LmVtYWNzLnpv +dDEiMCAGCSqGSIb3DQEJARYTZW1hY3MtZGV2ZWxAZnNmLm9yZzCCASIwDQYJKoZI +hvcNAQEBBQADggEPADCCAQoCggEBAM52lP7k1rBpctBX1irRVgDerxqlFSTkvg8L +WmRCfwm3XY8EZWqM/8Eex5soH7myRlWfUH/cKxbqScZqXotj0hlPxdRkM6gWgHS9 +Mml7wnz2LZGvD5PfMfs+yBHKAMrqortFXCKksHsYIJ66l9gJMm1G5XjWha6CaEr/ +k2bE5Ovw0fB2B4vH0OqhJzGyenJOspXZz1ttn3h3UC5fbDXS8fUM9k/FbgJKypWr +zB3P12GcMR939FsR5sqa8nNoCMw+WBzs4XuM5Ad+s/UtEaZvmtwvLwmdB7cgCEyM +x5gaM969SlpOmuy7dDTCCK3lBl6B5dgFKvVcChYwSW+xJz5tfL0CAwEAAaNQME4w +HQYDVR0OBBYEFG3YhH7ZzEdOGstkT67uUh1RylNjMB8GA1UdIwQYMBaAFG3YhH7Z +zEdOGstkT67uUh1RylNjMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcNAQELBQADggEB +ADnJL2tBMnPepywA57yDfJz54FvrqRd+UAjSiB7/QySDpHnTM3b3sXWfwAkXPTjM +c+jRW2kfdnL6OQW2tpcpPZANGnwK8MJrtGcbHhtPXjgDRhVZp64hsB7ayS+l0Dm7 +2ZBbi2SF8FgZVcQy0WD01ir2raSODo124dMrq+3aHP77YLbiNEKj+wFoDbndQ1FQ +gtIJBE80FADoqc7LnBrpA20aVlfqhKZqe+leYDSZ+CE1iwlPdvD+RTUxVDs5EfpB +qVOHDlzEfVmcMnddKTV8pNYuo93AG4s0KdrGG9RwSvtLaOoHd2i6RmIs+Yiumbau +mXodMxxAEW/cM7Ita/2QVmk= +-----END CERTIFICATE----- diff --git a/test/lisp/net/network-stream-resources/key.pem b/test/lisp/net/network-stream-resources/key.pem new file mode 100644 index 00000000000..5db58f573ca --- /dev/null +++ b/test/lisp/net/network-stream-resources/key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQDOdpT+5NawaXLQ +V9Yq0VYA3q8apRUk5L4PC1pkQn8Jt12PBGVqjP/BHsebKB+5skZVn1B/3CsW6knG +al6LY9IZT8XUZDOoFoB0vTJpe8J89i2Rrw+T3zH7PsgRygDK6qK7RVwipLB7GCCe +upfYCTJtRuV41oWugmhK/5NmxOTr8NHwdgeLx9DqoScxsnpyTrKV2c9bbZ94d1Au +X2w10vH1DPZPxW4CSsqVq8wdz9dhnDEfd/RbEebKmvJzaAjMPlgc7OF7jOQHfrP1 +LRGmb5rcLy8JnQe3IAhMjMeYGjPevUpaTprsu3Q0wgit5QZegeXYBSr1XAoWMElv +sSc+bXy9AgMBAAECggEAaqHkIiGeoE5V9jTncAXeHWTlmyVX3k4luy9p6A5P/nyt +3YevuXBJRzzWatQ2Tno8yUwXD3Ju7s7ie4/EdMmBYYFJ84AtDctRXPm6Z7B7qn6a +2ntH2F+WOOUb/9QMxMCae44/H8VfQLQdZN2KPxHA8Z+ENPzW3mKL6vBE+PcIJLK2 +kTXQdCEIuUb1v4kxKYfjyyHAQ9yHvocUvZdodGHrpmWOr/2QCrqCjwiKnXyvdJMi +JQ4a3dU+JG5Zwr2hScyeLgS4p+M3A2NY+oIACn2rCcsIKC6uvBK3wAbhssaY8z9c +5kap862oMBNmPCxPuQTIIO7ptla0EWHktpFxnu7GIQKBgQDvKyXt82zGHiOZ9acx +4fV7t3NF2MNd9fOn59NYWYRSs2gaEjit6BnsCgiKZOJJ2YFsggBiQMiWuEzwqIdW +bOH8W5AubTxnE2OjeIpH5r8AXI6I/pKdOedM86oeElbL0p53OZqSqBK6vA5SnE76 +fZwC505h/mqH2E6AdKpcyL7sJwKBgQDc/jc4MkVnqF7xcYoJrYEbnkhwqRxIM+0Y +HY2qXszWQPgjae3NK1rw/PEOATzWrHLvRS/utQ8yeLUAZIGsFY8+c1kjvkvl4ZK2 +OnsEOVLmEwjDqqnq3JFYCVSkXfLBGRD3wGldzkCQljOiGuJ/Co1rGHk7CfBmxX2p +kxdts5OKewKBgQDTRsSc7Zs7cMh2a0GlmTyoa6iTHSeIy4rQ2sQimgGApSfjUBFt +30l28G4XA4O7RT9FwZnhMeWA75JYTigwOsNvkNtPiAQB8mjksclGNxqnkRwA/RI7 +fjlMCzxOkFjIeWivXd2kjIDvIM1uQNKsCWZWUks12e/1zSmb5HPSvyuZpQKBgQDQ +qVgKP604ysmav9HOgXy+Tx2nAoYpxp2/f2gbzZcrVfz1szdN2fnsQWh6CMEhEYMU +WQeBJIRM65w72qp1iYXPOaqZDT0suWiFl4I/4sBbbO2BkssNb2Xs8iJxcCOeH8Td +qVfTssNTwf7OuQPTYGtXC6ysCh5ra13Tl4cvlbdhsQKBgFHXP+919wSncLS+2ySD +waBzG6GyVOgV+FE3DrM3Xp4S6fldWYAndKHQ1HjJVDY8SkC2Tk1D7QSQnmS+ZzYs +YqzcnkPCTHLb6wCErs4ZiW0gn9xJnfxyv6wPujsayL4TMsmsqkj/IAB61UjwaA/a +Z+rUw/WkcNPD59AD1J0eeSZu +-----END PRIVATE KEY----- diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 28686547a44..07eb2823282 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -24,6 +24,8 @@ ;;; Code: +(require 'ert) +(require 'ert-x) (require 'gnutls) (require 'network-stream) ;; The require above is needed for 'open-network-stream' to work, but @@ -136,7 +138,20 @@ (t )))) +(defun network-test--resolve-system-name () + (cl-loop for address in (network-lookup-address-info (system-name)) + when (or (and (= (length address) 5) + ;; IPv4 localhost addresses start with 127. + (= (elt address 0) 127)) + (and (= (length address) 9) + ;; IPv6 localhost address. + (equal address [0 0 0 0 0 0 0 1 0]))) + return t)) + (ert-deftest echo-server-with-dns () + (unless (network-test--resolve-system-name) + (ert-skip "Can't test resolver for (system-name)")) + (let* ((server (make-server (system-name))) (port (aref (process-contact server :local) 4)) (proc (make-network-process :name "foo" @@ -226,16 +241,13 @@ (should (equal (buffer-string) "foo\n"))) (delete-process server))) -(defconst network-stream-tests--datadir - (expand-file-name "test/data/net" source-directory)) - (defun make-tls-server (port) (start-process "gnutls" (generate-new-buffer "*tls*") "gnutls-serv" "--http" "--x509keyfile" - (concat network-stream-tests--datadir "/key.pem") + (ert-resource-file "key.pem") "--x509certfile" - (concat network-stream-tests--datadir "/cert.pem") + (ert-resource-file "cert.pem") "--port" (format "%s" port))) (ert-deftest connect-to-tls-ipv4-wait () @@ -724,4 +736,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/ntlm-tests.el b/test/lisp/net/ntlm-tests.el new file mode 100644 index 00000000000..e515ebe2635 --- /dev/null +++ b/test/lisp/net/ntlm-tests.el @@ -0,0 +1,52 @@ +;;; ntlm-tests.el --- tests for ntlm.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/>. + +(require 'ert) +(require 'ntlm) + +;; 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 +microsecond since January 1, 1601 as a 64-bit little-endian +signed integer. TIME must be on the form (HIGH LOW USEC PSEC)." + (let* ((s (+ (ash (nth 0 time) 16) (nth 1 time))) + (us (nth 2 time)) + (ps (nth 3 time)) + (tenths-of-us-since-jan-1-1601 + (+ (* s 10000000) (* us 10) (/ ps 100000) + ;; tenths of microseconds between 1601-01-01 and 1970-01-01 + 116444736000000000))) + (apply #'unibyte-string + (mapcar (lambda (i) + (logand (ash tenths-of-us-since-jan-1-1601 (* i -8)) + #xff)) + (number-sequence 0 7))))) + +(ert-deftest ntlm-time-to-timestamp () + ;; Verify poor man's bignums in implementation that can run on Emacs < 27.1. + (let ((time '(24471 63910 412962 0))) + (should (equal (ntlm--time-to-timestamp time) + (ntlm-tests--time-to-timestamp time)))) + (let ((time '(397431 65535 999999 999999))) + (should (equal (ntlm--time-to-timestamp time) + (ntlm-tests--time-to-timestamp time))))) + +(provide 'ntlm-tests) 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/rcirc-tests.el b/test/lisp/net/rcirc-tests.el index 8d14378b4ff..285926af9d2 100644 --- a/test/lisp/net/rcirc-tests.el +++ b/test/lisp/net/rcirc-tests.el @@ -2,18 +2,20 @@ ;; Copyright (C) 2019-2020 Free Software Foundation, Inc. -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/lisp/net/rfc2104-tests.el b/test/lisp/net/rfc2104-tests.el index 5c1f4410934..e7d5a7f30e5 100644 --- a/test/lisp/net/rfc2104-tests.el +++ b/test/lisp/net/rfc2104-tests.el @@ -1,21 +1,23 @@ -;;; 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. ;; Author: Lars Ingebrigtsen <larsi@gnus.org> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: 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/secrets-tests.el b/test/lisp/net/secrets-tests.el index 6d420c4cb17..1e2cf3aef66 100644 --- a/test/lisp/net/secrets-tests.el +++ b/test/lisp/net/secrets-tests.el @@ -4,18 +4,20 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/lisp/net/shr-resources/div-div.html b/test/lisp/net/shr-resources/div-div.html new file mode 100644 index 00000000000..1c191ae44d8 --- /dev/null +++ b/test/lisp/net/shr-resources/div-div.html @@ -0,0 +1 @@ +<div>foo</div><div>Bar</div> diff --git a/test/lisp/net/shr-resources/div-div.txt b/test/lisp/net/shr-resources/div-div.txt new file mode 100644 index 00000000000..62715e12513 --- /dev/null +++ b/test/lisp/net/shr-resources/div-div.txt @@ -0,0 +1,2 @@ +foo +Bar diff --git a/test/lisp/net/shr-resources/div-p.html b/test/lisp/net/shr-resources/div-p.html new file mode 100644 index 00000000000..fcbdfc43293 --- /dev/null +++ b/test/lisp/net/shr-resources/div-p.html @@ -0,0 +1 @@ +<div>foo</div><p>Bar</p> diff --git a/test/lisp/net/shr-resources/div-p.txt b/test/lisp/net/shr-resources/div-p.txt new file mode 100644 index 00000000000..859d731da89 --- /dev/null +++ b/test/lisp/net/shr-resources/div-p.txt @@ -0,0 +1,3 @@ +foo + +Bar diff --git a/test/lisp/net/shr-resources/li-div.html b/test/lisp/net/shr-resources/li-div.html new file mode 100644 index 00000000000..eca3c511bd9 --- /dev/null +++ b/test/lisp/net/shr-resources/li-div.html @@ -0,0 +1,10 @@ +<ul> + <li> + <div> + <p >This is the first paragraph of a list item.</div> + <p >This is the second paragraph of a list item.</li> + <li> + <div>This is the first paragraph of a list item.</div> + <div>This is the second paragraph of a list item.</div> + </li> +</ul> diff --git a/test/lisp/net/shr-resources/li-div.txt b/test/lisp/net/shr-resources/li-div.txt new file mode 100644 index 00000000000..9fc54f2bdc6 --- /dev/null +++ b/test/lisp/net/shr-resources/li-div.txt @@ -0,0 +1,6 @@ +* This is the first paragraph of a list item. + + This is the second paragraph of a list item. + +* This is the first paragraph of a list item. + This is the second paragraph of a list item. diff --git a/test/lisp/net/shr-resources/li-empty.html b/test/lisp/net/shr-resources/li-empty.html new file mode 100644 index 00000000000..05cfee7bdd4 --- /dev/null +++ b/test/lisp/net/shr-resources/li-empty.html @@ -0,0 +1 @@ +<ol><li></li><li></li><li></li></ol> diff --git a/test/lisp/net/shr-resources/li-empty.txt b/test/lisp/net/shr-resources/li-empty.txt new file mode 100644 index 00000000000..906fd8df8b3 --- /dev/null +++ b/test/lisp/net/shr-resources/li-empty.txt @@ -0,0 +1,3 @@ +1%20 +2%20 +3%20 diff --git a/test/lisp/net/shr-resources/nonbr.html b/test/lisp/net/shr-resources/nonbr.html new file mode 100644 index 00000000000..56282cf4ca5 --- /dev/null +++ b/test/lisp/net/shr-resources/nonbr.html @@ -0,0 +1 @@ +<div class="gmail_extra">(progn</div><div class="gmail_extra"> (setq minibuffer-prompt-properties '(read-only t cursor-intangible t face minibuffer-prompt))</div><div class="gmail_extra"><br></div><div class="gmail_extra"> (defun turn-on-cursor-intangible-mode ()</div><div class="gmail_extra"> "Turns on cursor-intangible-mode."</div><div class="gmail_extra"> (interactive)</div><div class="gmail_extra"> (cursor-intangible-mode 1))</div><div class="gmail_extra"> (define-globalized-minor-mode global-cursor-intangible-mode cursor-intangible-mode turn-on-cursor-intangible-mode)</div><div class="gmail_extra"><br></div><div class="gmail_extra"> (global-cursor-intangible-mode 1))</div><div class="gmail_extra"><br></div> diff --git a/test/lisp/net/shr-resources/nonbr.txt b/test/lisp/net/shr-resources/nonbr.txt new file mode 100644 index 00000000000..0c3cffa93f9 --- /dev/null +++ b/test/lisp/net/shr-resources/nonbr.txt @@ -0,0 +1,12 @@ +(progn + (setq minibuffer-prompt-properties '(read-only t cursor-intangible t face +minibuffer-prompt)) + + (defun turn-on-cursor-intangible-mode () + "Turns on cursor-intangible-mode." + (interactive) + (cursor-intangible-mode 1)) + (define-globalized-minor-mode global-cursor-intangible-mode +cursor-intangible-mode turn-on-cursor-intangible-mode) + + (global-cursor-intangible-mode 1)) diff --git a/test/lisp/net/shr-resources/ol.html b/test/lisp/net/shr-resources/ol.html new file mode 100644 index 00000000000..f9a15f26409 --- /dev/null +++ b/test/lisp/net/shr-resources/ol.html @@ -0,0 +1,29 @@ +<ol> + <li>one</li> + <li>two</li> + <li>three</li> +</ol> + +<ol start="10"> + <li>ten</li> + <li>eleven</li> + <li>twelve</li> +</ol> + +<ol start="0"> + <li>zero</li> + <li>one</li> + <li>two</li> +</ol> + +<ol start="-5"> + <li>minus five</li> + <li>minus four</li> + <li>minus three</li> +</ol> + +<ol start="notanumber"> + <li>one</li> + <li>two</li> + <li>three</li> +</ol> diff --git a/test/lisp/net/shr-resources/ol.txt b/test/lisp/net/shr-resources/ol.txt new file mode 100644 index 00000000000..0d46e2a8ddb --- /dev/null +++ b/test/lisp/net/shr-resources/ol.txt @@ -0,0 +1,19 @@ +1 one +2 two +3 three + +10 ten +11 eleven +12 twelve + +0 zero +1 one +2 two + +-5 minus five +-4 minus four +-3 minus three + +1 one +2 two +3 three diff --git a/test/lisp/net/shr-resources/ul-empty.html b/test/lisp/net/shr-resources/ul-empty.html new file mode 100644 index 00000000000..e5a75ab9216 --- /dev/null +++ b/test/lisp/net/shr-resources/ul-empty.html @@ -0,0 +1,4 @@ +<ul> +<li></li> +</ul> +Lala diff --git a/test/lisp/net/shr-resources/ul-empty.txt b/test/lisp/net/shr-resources/ul-empty.txt new file mode 100644 index 00000000000..8993555425b --- /dev/null +++ b/test/lisp/net/shr-resources/ul-empty.txt @@ -0,0 +1,3 @@ +* + +Lala
\ No newline at end of file diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el index 88a31bcf645..abc4f6a656b 100644 --- a/test/lisp/net/shr-tests.el +++ b/test/lisp/net/shr-tests.el @@ -23,14 +23,13 @@ ;;; Code: +(require 'ert) +(require 'ert-x) (require 'shr) -(defconst shr-tests--datadir - (expand-file-name "test/data/shr" source-directory)) - (defun shr-test (name) (with-temp-buffer - (insert-file-contents (format (concat shr-tests--datadir "/%s.html") name)) + (insert-file-contents (format (concat (ert-resource-directory) "/%s.html") name)) (let ((dom (libxml-parse-html-region (point-min) (point-max))) (shr-width 80) (shr-use-fonts nil)) @@ -39,7 +38,7 @@ (cons (buffer-substring-no-properties (point-min) (point-max)) (with-temp-buffer (insert-file-contents - (format (concat shr-tests--datadir "/%s.txt") name)) + (format (concat (ert-resource-directory) "/%s.txt") name)) (while (re-search-forward "%\\([0-9A-F][0-9A-F]\\)" nil t) (replace-match (string (string-to-number (match-string 1) 16)) t t)) @@ -47,7 +46,7 @@ (ert-deftest rendering () (skip-unless (fboundp 'libxml-parse-html-region)) - (dolist (file (directory-files shr-tests--datadir nil "\\.html\\'")) + (dolist (file (directory-files (ert-resource-directory) nil "\\.html\\'")) (let* ((name (replace-regexp-in-string "\\.html\\'" "" file)) (result (shr-test name))) (unless (equal (car result) (cdr result)) diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 95e41a3f03b..97c22fd2feb 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -4,18 +4,20 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -27,40 +29,74 @@ ;; tests in tramp-tests.el. (require 'ert) +(require 'ert-x) (require 'tramp-archive) (defvar tramp-copy-size-limit) (defvar tramp-persistency-file-name) -(defconst tramp-archive-test-resource-directory - (let ((default-directory - (if load-in-progress - (file-name-directory load-file-name) - default-directory))) - (cond - ((file-accessible-directory-p (expand-file-name "resources")) - (expand-file-name "resources")) - ((file-accessible-directory-p (expand-file-name "tramp-archive-resources")) - (expand-file-name "tramp-archive-resources")))) - "The resources directory test files are located in.") - -(defconst tramp-archive-test-file-archive - (file-truename - (expand-file-name "foo.tar.gz" tramp-archive-test-resource-directory)) +;; `ert-resource-file' was introduced in Emacs 28.1. +(unless (macrop 'ert-resource-file) + (eval-and-compile + (defvar ert-resource-directory-format "%s-resources/" + "Format for `ert-resource-directory'.") + (defvar ert-resource-directory-trim-left-regexp "" + "Regexp for `string-trim' (left) used by `ert-resource-directory'.") + (defvar ert-resource-directory-trim-right-regexp "\\(-tests?\\)?\\.el" + "Regexp for `string-trim' (right) used by `ert-resource-directory'.") + + (defmacro ert-resource-directory () + "Return absolute file name of the resource directory for this file. + +The path to the resource directory is the \"resources\" directory +in the same directory as the test file. + +If that directory doesn't exist, use the directory named like the +test file but formatted by `ert-resource-directory-format' and trimmed +using `string-trim' with arguments +`ert-resource-directory-trim-left-regexp' and +`ert-resource-directory-trim-right-regexp'. The default values mean +that if called from a test file named \"foo-tests.el\", return +the absolute file name for \"foo-resources\"." + `(let* ((testfile ,(or (bound-and-true-p byte-compile-current-file) + (and load-in-progress load-file-name) + buffer-file-name)) + (default-directory (file-name-directory testfile))) + (file-truename + (if (file-accessible-directory-p "resources/") + (expand-file-name "resources/") + (expand-file-name + (format + ert-resource-directory-format + (string-trim testfile + ert-resource-directory-trim-left-regexp + ert-resource-directory-trim-right-regexp))))))) + + (defmacro ert-resource-file (file) + "Return file name of resource file named FILE. +A resource file is in the resource directory as per +`ert-resource-directory'." + `(expand-file-name ,file (ert-resource-directory))))) + +(defconst tramp-archive-test-file-archive (ert-resource-file "foo.tar.gz") "The test file archive.") +(defun tramp-archive-test-file-archive-hexlified () + "Return hexlified `tramp-archive-test-file-archive'. +Do not hexlify \"/\". This hexlified string is used in `file:///' URLs." + (let* ((url-unreserved-chars (cons ?/ url-unreserved-chars))) + (url-hexify-string tramp-archive-test-file-archive))) + (defconst tramp-archive-test-archive (file-name-as-directory tramp-archive-test-file-archive) "The test archive.") (defconst tramp-archive-test-directory - (file-truename - (expand-file-name "foo.iso" tramp-archive-test-resource-directory)) + (file-truename (ert-resource-file "foo.iso")) "A directory file name, which looks like an archive.") (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) @@ -175,7 +211,8 @@ variables, so we check the Emacs version directly." (should (string-equal host - (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (url-hexify-string + (concat "file://" (tramp-archive-test-file-archive-hexlified))))) (should-not port) (should (string-equal localname "/")) (should (string-equal archive tramp-archive-test-file-archive))) @@ -194,7 +231,8 @@ variables, so we check the Emacs version directly." (should (string-equal host - (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (url-hexify-string + (concat "file://" (tramp-archive-test-file-archive-hexlified))))) (should-not port) (should (string-equal localname "/foo")) (should (string-equal archive tramp-archive-test-file-archive))) @@ -238,7 +276,8 @@ variables, so we check the Emacs version directly." ;; archive boundaries. So we must cut the ;; trailing slash ourselves. (substring - (file-name-directory tramp-archive-test-file-archive) + (file-name-directory + (tramp-archive-test-file-archive-hexlified)) 0 -1))) nil "/")) (file-name-nondirectory tramp-archive-test-file-archive))))) @@ -971,4 +1010,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 cc65421619d..00d08ea6f67 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -4,18 +4,20 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -43,6 +45,7 @@ (require 'dired) (require 'ert) (require 'ert-x) +(require 'trace) (require 'tramp) (require 'vc) (require 'vc-bzr) @@ -50,14 +53,13 @@ (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") (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") -(declare-function tramp-time-diff "tramp") (defvar ange-ftp-make-backup-files) (defvar auto-save-file-name-transforms) (defvar tramp-connection-properties) @@ -68,8 +70,6 @@ (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) @@ -98,25 +98,29 @@ '("mock" (tramp-login-program "sh") (tramp-login-args (("-i"))) + (tramp-direct-async-args (("-c"))) (tramp-remote-shell "/bin/sh") (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10))) (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) @@ -144,9 +148,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)) @@ -177,38 +179,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." @@ -1970,9 +1980,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)) @@ -1992,16 +2002,17 @@ properly. BODY shall not contain a timeout." (skip-unless (tramp--test-enabled)) ;; Multi hops are allowed for inline methods only. - (should-error - (file-remote-p "/ssh:user1@host1|method:user2@host2:/path/to/file") - :type 'user-error) - (should-error - (file-remote-p "/method:user1@host1|ssh:user2@host2:/path/to/file") - :type 'user-error) + (let (non-essential) + (should-error + (expand-file-name "/ssh:user1@host1|method:user2@host2:/path/to/file") + :type 'user-error) + (should-error + (expand-file-name "/method:user1@host1|ssh:user2@host2:/path/to/file") + :type 'user-error)) ;; 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 @@ -2013,8 +2024,12 @@ properly. BODY shall not contain a timeout." "Check `substitute-in-file-name'." (skip-unless (eq tramp-syntax 'default)) - ;; Suppress method name check. - (let ((tramp-methods (cons '("method") tramp-methods))) + ;; Suppress method name check. We cannot use the string "foo" as + ;; user name, because (substitute-in-string "/~foo") returns + ;; different values depending on the existence of user "foo" (see + ;; Bug#43052). + (let ((tramp-methods (cons '("method") tramp-methods)) + (foo (downcase (md5 (current-time-string))))) (should (string-equal (substitute-in-file-name "/method:host:///foo") "/foo")) (should @@ -2043,39 +2058,43 @@ 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")) + (string-equal + (substitute-in-file-name (concat "/method:host://~" foo)) + (concat "/~" foo))) (should (string-equal - (substitute-in-file-name "/method:host:/~foo") "/method:host:/~foo")) + (substitute-in-file-name (concat "/method:host:/~" foo)) + (concat "/method:host:/~" foo))) (should (string-equal - (substitute-in-file-name "/method:host:/path//~foo") "/~foo")) + (substitute-in-file-name (concat "/method:host:/path//~" foo)) + (concat "/~" foo))) ;; (substitute-in-file-name "/path/~foo") expands only for a local ;; user "foo" to "/~foo"". Otherwise, it doesn't expand. (should (string-equal - (substitute-in-file-name "/method:host:/path/~foo") - "/method:host:/path/~foo")) + (substitute-in-file-name (concat "/method:host:/path/~" foo)) + (concat "/method:host:/path/~" foo))) ;; Quoting local part. (should (string-equal - (substitute-in-file-name "/method:host:/://~foo") - "/method:host:/://~foo")) + (substitute-in-file-name (concat "/method:host:/://~" foo)) + (concat "/method:host:/://~" foo))) (should (string-equal - (substitute-in-file-name - "/method:host:/:/~foo") "/method:host:/:/~foo")) + (substitute-in-file-name (concat "/method:host:/:/~" foo)) + (concat "/method:host:/:/~" foo))) (should (string-equal - (substitute-in-file-name "/method:host:/:/path//~foo") - "/method:host:/:/path//~foo")) + (substitute-in-file-name (concat "/method:host:/:/path//~" foo)) + (concat "/method:host:/:/path//~" foo))) (should (string-equal - (substitute-in-file-name "/method:host:/:/path/~foo") - "/method:host:/:/path/~foo"))) + (substitute-in-file-name (concat "/method:host:/:/path/~" foo)) + (concat "/method:host:/:/path/~" foo)))) (let (process-environment) (should @@ -2215,11 +2234,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 @@ -2235,7 +2253,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) ""))))))) @@ -2250,7 +2268,28 @@ This checks also `file-name-as-directory', `file-name-directory', (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) (delete-file tmp-name) - (should-not (file-exists-p tmp-name))))) + (should-not (file-exists-p tmp-name)) + + ;; Trashing files doesn't work for crypted remote files. + (unless (tramp--test-crypt-p) + (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) + (delete-by-moving-to-trash t)) + (make-directory trash-directory) + (should-not (file-exists-p tmp-name)) + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (delete-file tmp-name 'trash) + (should-not (file-exists-p tmp-name)) + (should + (or (file-exists-p + (expand-file-name + (file-name-nondirectory tmp-name) trash-directory)) + ;; Gdrive. + (file-symlink-p + (expand-file-name + (file-name-nondirectory tmp-name) trash-directory)))) + (delete-directory trash-directory 'recursive) + (should-not (file-exists-p trash-directory))))))) (ert-deftest tramp-test08-file-local-copy () "Check `file-local-copy'." @@ -2293,16 +2332,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 @@ -2380,7 +2428,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)) @@ -2406,7 +2454,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should-error (cl-letf (((symbol-function #'y-or-n-p) #'ignore) ;; Ange-FTP. - ((symbol-function 'yes-or-no-p) 'ignore)) + ((symbol-function #'yes-or-no-p) #'ignore)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) :type 'file-already-exists) (should-error @@ -2738,7 +2786,53 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (delete-directory tmp-name1) :type 'file-error) (delete-directory tmp-name1 'recursive) - (should-not (file-directory-p tmp-name1))))) + (should-not (file-directory-p tmp-name1)) + + ;; Trashing directories works only since Emacs 27.1. It doesn't + ;; work for crypted remote directories and for ange-ftp. + (when (and (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p)) + (tramp--test-emacs27-p)) + (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) + (delete-by-moving-to-trash t)) + (make-directory trash-directory) + ;; Delete empty directory. + (make-directory tmp-name1) + (should (file-directory-p tmp-name1)) + (delete-directory tmp-name1 nil 'trash) + (should-not (file-directory-p tmp-name1)) + (should + (file-exists-p + (expand-file-name + (file-name-nondirectory tmp-name1) trash-directory))) + (delete-directory trash-directory 'recursive) + (should-not (file-exists-p trash-directory)) + ;; Delete non-empty directory. + (make-directory tmp-name1) + (should (file-directory-p tmp-name1)) + (write-region "foo" nil (expand-file-name "bla" tmp-name1)) + (should (file-exists-p (expand-file-name "bla" tmp-name1))) + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + (write-region "foo" nil (expand-file-name "bla" tmp-name2)) + (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)) + (delete-directory tmp-name1 'recursive 'trash) + (should-not (file-directory-p tmp-name1)) + (should + (file-exists-p + (format + "%s/%s/bla" trash-directory (file-name-nondirectory tmp-name1)))) + (should + (file-exists-p + (format + "%s/%s/%s/bla" trash-directory (file-name-nondirectory tmp-name1) + (file-name-nondirectory tmp-name2)))) + (delete-directory trash-directory 'recursive) + (should-not (file-exists-p trash-directory))))))) (ert-deftest tramp-test15-copy-directory () "Check `copy-directory'." @@ -2838,7 +2932,15 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." '("bla" "foo"))) (should (equal (directory-files tmp-name1 'full directory-files-no-dot-files-regexp) - `(,tmp-name2 ,tmp-name3)))) + `(,tmp-name2 ,tmp-name3))) + ;; Check the COUNT arg. It exists since Emacs 28. + (when (tramp--test-emacs28-p) + (with-no-warnings + (should + (equal + (directory-files + tmp-name1 nil directory-files-no-dot-files-regexp nil 1) + '("bla")))))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) @@ -2915,6 +3017,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 @@ -2985,6 +3090,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)) @@ -3134,8 +3241,7 @@ This tests also `access-file', `file-readable-p', (setq test-file-ownership-preserved-p (= (tramp-compat-file-attribute-group-id (file-attributes tmp-name1)) - (tramp-get-remote-gid - (tramp-dissect-file-name tmp-name1) 'integer))) + (tramp-get-remote-gid tramp-test-vec 'integer))) (delete-file tmp-name1)) (should-error @@ -3352,7 +3458,14 @@ They might differ only in time attributes or directory size." (file-attributes (car elt)) (cdr elt)))) (setq attr (directory-files-and-attributes tmp-name2 nil "\\`b")) - (should (equal (mapcar #'car attr) '("bar" "boz")))) + (should (equal (mapcar #'car attr) '("bar" "boz"))) + + ;; Check the COUNT arg. It exists since Emacs 28. + (when (tramp--test-emacs28-p) + (with-no-warnings + (setq attr (directory-files-and-attributes + tmp-name2 nil "\\`b" nil nil 1)) + (should (equal (mapcar #'car attr) '("bar")))))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) @@ -3370,25 +3483,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) @@ -3472,7 +3640,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; `tmp-name3' is a local file name. Therefore, the link ;; target remains unchanged, even if quoted. ;; `make-symbolic-link' might not be permitted on w32 systems. - (unless (tramp--test-windows-nt) + (unless (tramp--test-windows-nt-p) (make-symbolic-link tmp-name1 tmp-name3) (should (string-equal tmp-name1 (file-symlink-p tmp-name3)))) @@ -3586,7 +3754,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (concat (file-remote-p tmp-name2) penguin))))) ;; `tmp-name3' is a local file name. ;; `make-symbolic-link' might not be permitted on w32 systems. - (unless (tramp--test-windows-nt) + (unless (tramp--test-windows-nt-p) (make-symbolic-link tmp-name1 tmp-name3) (should (file-symlink-p tmp-name3)) (should-not (string-equal tmp-name3 (file-truename tmp-name3))) @@ -3647,7 +3815,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 @@ -3710,7 +3878,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 @@ -3750,6 +3928,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)) @@ -3828,6 +4007,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)) @@ -3971,7 +4151,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))) @@ -3984,7 +4163,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 @@ -4040,10 +4219,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 @@ -4133,6 +4311,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)) @@ -4211,6 +4390,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) @@ -4229,9 +4409,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. - (should (string-match "\\`foo" (buffer-string)))) + (should (string-match "foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4250,7 +4428,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - (should (string-equal (buffer-string) "foo"))) + (should (string-match "foo" (buffer-string)))) ;; Cleanup. (ignore-errors @@ -4272,9 +4450,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. - (should (string-match "\\`foo" (buffer-string)))) + (should (string-match "foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4282,7 +4458,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; PTY. (unwind-protect (with-temp-buffer - (if (not (tramp--test-sh-p)) + ;; It works only for tramp-sh.el, and not direct async processes. + (if (or (not (tramp--test-sh-p)) (tramp-direct-async-process-p)) (should-error (start-file-process "test4" (current-buffer) nil) :type 'wrong-type-argument) @@ -4294,13 +4471,37 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc)))))) +(defmacro tramp--test--deftest-direct-async-process + (test docstring &optional unstable) + "Define ert test `TEST-direct-async' for direct async processes. +If UNSTABLE is non-nil, the test is tagged as `:unstable'." + (declare (indent 1)) + `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) () + ,docstring + :tags (if ,unstable '(:expensive-test :unstable) '(:expensive-test)) + (skip-unless (tramp--test-enabled)) + (let ((default-directory tramp-test-temporary-file-directory) + (ert-test (ert-get-test ',test)) + (tramp-connection-properties + (cons '(nil "direct-async-process" t) tramp-connection-properties))) + (skip-unless (tramp-direct-async-process-p)) + ;; We do expect an established connection already, + ;; `file-truename' does it by side-effect. Suppress + ;; `tramp--test-enabled', in order to keep the connection. + (cl-letf (((symbol-function #'tramp--test-enabled) (lambda nil t))) + (file-truename tramp-test-temporary-file-directory) + (funcall (ert-test-body ert-test)))))) + +(tramp--test--deftest-direct-async-process tramp-test29-start-file-process + "Check direct async `start-file-process'.") + (ert-deftest tramp-test30-make-process () "Check `make-process'." :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))) @@ -4326,9 +4527,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. - (should (string-match "\\`foo" (buffer-string)))) + (should (string-match "foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4349,7 +4548,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - (should (string-equal (buffer-string) "foo"))) + (should (string-match "foo" (buffer-string)))) ;; Cleanup. (ignore-errors @@ -4375,9 +4574,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (not (string-match "foo" (buffer-string))) (while (accept-process-output proc 0 nil t)))) - ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. - (should (string-match "\\`foo" (buffer-string)))) + (should (string-match "foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4401,75 +4598,74 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) (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. 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)))) + ;; On some MS Windows systems, it returns "unknown signal". + (should (string-match "unknown signal\\|killed" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) ;; 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))))) + (unless (tramp-direct-async-process-p) + (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)))) + ;; 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) + (unless (tramp-direct-async-process-p) + (dolist (tmpfile `(,tmp-name1 ,tmp-name2)) + (unwind-protect (with-temp-buffer - (insert-file-contents tmpfile) - (should - (string-match - "cat:.* No such file or directory" (buffer-string))))) + (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 + (insert-file-contents tmpfile) + (should + (string-match + "cat:.* No such file or directory" (buffer-string))))) - ;; Cleanup. - (ignore-errors (delete-process proc)) - (ignore-errors (delete-file tmpfile))))))) + ;; Cleanup. + (ignore-errors (delete-process proc)) + (ignore-errors (delete-file tmpfile)))))))) + +(tramp--test--deftest-direct-async-process tramp-test30-make-process + "Check direct async `make-process'.") (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)) @@ -4530,6 +4726,7 @@ INPUT, if non-nil, is a string sent to the process." ;; 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)) @@ -4623,6 +4820,7 @@ INPUT, if non-nil, is a string sent to the process." :tags '(:expensive-test :unstable) (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)) @@ -4746,6 +4944,7 @@ INPUT, if non-nil, is a string sent to the process." :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. @@ -4758,67 +4957,71 @@ INPUT, if non-nil, is a string sent to the process." (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\n" emacs-version tramp-version) + (funcall this-shell-command-to-string "echo ${INSIDE_EMACS:-bla}"))) + (let ((process-environment + (cons (format "INSIDE_EMACS=%s,foo" emacs-version) + process-environment))) + (should + (string-equal + (format "%s,foo,tramp:%s\n" emacs-version tramp-version) + (funcall + this-shell-command-to-string "echo ${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 ${%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 ${%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 ${%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 ${%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 () @@ -4827,6 +5030,7 @@ INPUT, if non-nil, is a string sent to the process." ;; 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 @@ -4849,7 +5053,7 @@ INPUT, if non-nil, is a string sent to the process." (should (string-match (number-to-string port) - (shell-command-to-string (format "echo -n $%s" envvar)))))) + (shell-command-to-string (format "echo $%s" envvar)))))) ;; Cleanup. (dolist (dir '("/mock:localhost#11111:" "/mock:localhost#22222:")) @@ -4931,6 +5135,7 @@ INPUT, if non-nil, is a string sent to the process." ;; 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))) @@ -4987,6 +5192,7 @@ INPUT, if non-nil, is a string sent to the process." "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)) @@ -5030,6 +5236,7 @@ INPUT, if non-nil, is a string sent to the process." "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)) @@ -5037,23 +5244,20 @@ INPUT, if non-nil, is a string sent to the process." (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) @@ -5065,26 +5269,30 @@ INPUT, if non-nil, is a string sent to the process." (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))))) @@ -5093,6 +5301,7 @@ INPUT, if non-nil, is a string sent to the process." :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 @@ -5121,8 +5330,7 @@ INPUT, if non-nil, is a string sent to the process." 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. @@ -5148,13 +5356,9 @@ INPUT, if non-nil, is a string sent to the process." (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) "/")) @@ -5411,12 +5615,6 @@ INPUT, if non-nil, is a string sent to the process." (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 @@ -5452,6 +5650,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)." @@ -5507,9 +5709,8 @@ This does not support special file names." (defun tramp--test-sh-p () "Check, whether the remote host runs a based method from tramp-sh.el." - (eq - (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) - 'tramp-sh-file-name-handler)) + (tramp-sh-file-name-handler-p + (tramp-dissect-file-name tramp-test-temporary-file-directory))) (defun tramp--test-share-p () "Check, whether the method needs a share." @@ -5522,11 +5723,11 @@ This does not support special file names." "Check, whether the sudoedit method is used." (tramp-sudoedit-file-name-p tramp-test-temporary-file-directory)) -(defun tramp--test-windows-nt () +(defun tramp--test-windows-nt-p () "Check, whether the locale host runs MS Windows." (eq system-type 'windows-nt)) -(defun tramp--test-windows-nt-and-batch () +(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)) @@ -5543,7 +5744,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." @@ -5667,8 +5873,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 @@ -5695,6 +5900,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)))) @@ -5828,7 +6034,7 @@ Use the `ls' command." (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-batch))) + (skip-unless (not (tramp--test-windows-nt-and-batch-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (let ((tramp-connection-properties @@ -5862,18 +6068,28 @@ 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))) + ;; Filter out not displayable characters. + (setq x (mapconcat + (lambda (y) + (and (char-displayable-p y) (char-to-string y))) + 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))) @@ -5884,9 +6100,10 @@ Use the `ls' command." (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))) + (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-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (tramp--test-utf8)) @@ -5898,9 +6115,10 @@ 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))) + (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-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))) @@ -5919,9 +6137,10 @@ 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))) + (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-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))) @@ -5943,9 +6162,10 @@ 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))) + (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-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (let ((tramp-connection-properties (append @@ -6027,6 +6247,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)) @@ -6036,7 +6257,7 @@ process sentinels. They shall not disturb each other." (shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) ;; It doesn't work on w32 systems. (watchdog - (unless (tramp--test-windows-nt) + (unless (tramp--test-windows-nt-p) (start-process-shell-command "*watchdog*" nil (format @@ -6087,10 +6308,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)) @@ -6358,12 +6576,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) @@ -6395,6 +6615,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. @@ -6403,9 +6625,11 @@ 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'. -;; * Implement `tramp-test31-interrupt-process' for `adb'. +;; * Implement `tramp-test31-interrupt-process' for `adb' and for +;; direct async processes. ;; * 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 |