aboutsummaryrefslogtreecommitdiffstats
path: root/test/lisp
diff options
context:
space:
mode:
authorAndrea Corallo2020-10-04 19:45:05 +0200
committerAndrea Corallo2020-10-04 19:45:05 +0200
commit44ef24342fd8a2ac876212124ebf38673acda35a (patch)
tree793dc4ba4197559b4bc65339d713c0807a7b2ca9 /test/lisp
parentafb765ab3cab7b6582d0def543b23603cd076445 (diff)
parentd8665e6d3473403c90a0831e83439a013d0012d3 (diff)
downloademacs-44ef24342fd8a2ac876212124ebf38673acda35a.tar.gz
emacs-44ef24342fd8a2ac876212124ebf38673acda35a.zip
Merge remote-tracking branch 'savannah/master' into HEAD
Diffstat (limited to 'test/lisp')
-rw-r--r--test/lisp/calc/calc-tests.el116
-rw-r--r--test/lisp/electric-tests.el3
-rw-r--r--test/lisp/emacs-lisp/backtrace-tests.el2
-rw-r--r--test/lisp/emacs-lisp/edebug-tests.el2
-rw-r--r--test/lisp/files-tests.el4
-rw-r--r--test/lisp/gnus/gnus-util-tests.el13
-rw-r--r--test/lisp/gnus/mml-sec-tests.el32
-rw-r--r--test/lisp/mail/uudecode-tests.el4
-rw-r--r--test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml49
-rw-r--r--test/lisp/net/dbus-tests.el816
-rw-r--r--test/lisp/obsolete/cl-tests.el3
-rw-r--r--test/lisp/progmodes/python-tests.el4
-rw-r--r--test/lisp/simple-tests.el2
-rw-r--r--test/lisp/vc/vc-bzr-tests.el5
-rw-r--r--test/lisp/wdired-tests.el16
15 files changed, 995 insertions, 76 deletions
diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el
index dce82b6f536..0df96a0e2db 100644
--- a/test/lisp/calc/calc-tests.el
+++ b/test/lisp/calc/calc-tests.el
@@ -458,6 +458,122 @@ An existing calc stack is reused, otherwise a new one is created."
458 (calcFunc-choose '(frac -15 2) 3)) 458 (calcFunc-choose '(frac -15 2) 3))
459 (calc-tests--choose -7.5 3)))) 459 (calc-tests--choose -7.5 3))))
460 460
461(ert-deftest calc-business-days ()
462 (cl-flet ((m (s) (math-parse-date s))
463 (b+ (a b) (calcFunc-badd a b))
464 (b- (a b) (calcFunc-bsub a b)))
465 ;; Sanity check.
466 (should (equal (m "2020-09-07") '(date 737675)))
467
468 ;; Test with standard business days (Mon-Fri):
469 (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-08"))) ; Mon->Tue
470 (should (equal (b+ (m "2020-09-08") 1) (m "2020-09-09"))) ; Tue->Wed
471 (should (equal (b+ (m "2020-09-09") 1) (m "2020-09-10"))) ; Wed->Thu
472 (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-11"))) ; Thu->Fri
473 (should (equal (b+ (m "2020-09-11") 1) (m "2020-09-14"))) ; Fri->Mon
474
475 (should (equal (b+ (m "2020-09-07") 4) (m "2020-09-11"))) ; Mon->Fri
476 (should (equal (b+ (m "2020-09-07") 6) (m "2020-09-15"))) ; Mon->Tue
477
478 (should (equal (b+ (m "2020-09-12") 1) (m "2020-09-14"))) ; Sat->Mon
479 (should (equal (b+ (m "2020-09-13") 1) (m "2020-09-14"))) ; Sun->Mon
480
481 (should (equal (b- (m "2020-09-11") 1) (m "2020-09-10"))) ; Fri->Thu
482 (should (equal (b- (m "2020-09-10") 1) (m "2020-09-09"))) ; Thu->Wed
483 (should (equal (b- (m "2020-09-09") 1) (m "2020-09-08"))) ; Wed->Tue
484 (should (equal (b- (m "2020-09-08") 1) (m "2020-09-07"))) ; Tue->Mon
485 (should (equal (b- (m "2020-09-07") 1) (m "2020-09-04"))) ; Mon->Fri
486
487 (should (equal (b- (m "2020-09-11") 4) (m "2020-09-07"))) ; Fri->Mon
488 (should (equal (b- (m "2020-09-15") 6) (m "2020-09-07"))) ; Tue->Mon
489
490 (should (equal (b- (m "2020-09-12") 1) (m "2020-09-11"))) ; Sat->Fri
491 (should (equal (b- (m "2020-09-13") 1) (m "2020-09-11"))) ; Sun->Fri
492
493 ;; Stepping fractional days
494 (should (equal (b+ (m "2020-09-08 21:00") '(frac 1 2))
495 (m "2020-09-09 09:00")))
496 (should (equal (b+ (m "2020-09-11 21:00") '(frac 1 2))
497 (m "2020-09-14 09:00")))
498 (should (equal (b- (m "2020-09-08 21:00") '(frac 1 2))
499 (m "2020-09-08 09:00")))
500 (should (equal (b- (m "2020-09-14 06:00") '(frac 1 2))
501 (m "2020-09-11 18:00")))
502
503 ;; Test with a couple of extra days off:
504 (let ((var-Holidays (list 'vec
505 '(var sat var-sat) '(var sun var-sun)
506 (m "2020-09-09") (m "2020-09-11"))))
507
508 (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-08"))) ; Mon->Tue
509 (should (equal (b+ (m "2020-09-08") 1) (m "2020-09-10"))) ; Tue->Thu
510 (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-14"))) ; Thu->Mon
511 (should (equal (b+ (m "2020-09-14") 1) (m "2020-09-15"))) ; Mon->Tue
512 (should (equal (b+ (m "2020-09-15") 1) (m "2020-09-16"))) ; Tue->Wed
513
514 (should (equal (b- (m "2020-09-16") 1) (m "2020-09-15"))) ; Wed->Tue
515 (should (equal (b- (m "2020-09-15") 1) (m "2020-09-14"))) ; Tue->Mon
516 (should (equal (b- (m "2020-09-14") 1) (m "2020-09-10"))) ; Mon->Thu
517 (should (equal (b- (m "2020-09-10") 1) (m "2020-09-08"))) ; Thu->Tue
518 (should (equal (b- (m "2020-09-08") 1) (m "2020-09-07"))) ; Tue->Mon
519 )
520
521 ;; Test with odd non-business weekdays (Tue, Wed, Sat):
522 (let ((var-Holidays '(vec (var tue var-tue)
523 (var wed var-wed)
524 (var sat var-sat))))
525 (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-10"))) ; Mon->Thu
526 (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-11"))) ; Thu->Fri
527 (should (equal (b+ (m "2020-09-11") 1) (m "2020-09-13"))) ; Fri->Sun
528 (should (equal (b+ (m "2020-09-13") 1) (m "2020-09-14"))) ; Sun->Mon
529
530 (should (equal (b- (m "2020-09-14") 1) (m "2020-09-13"))) ; Mon->Sun
531 (should (equal (b- (m "2020-09-13") 1) (m "2020-09-11"))) ; Sun->Fri
532 (should (equal (b- (m "2020-09-11") 1) (m "2020-09-10"))) ; Fri->Thu
533 (should (equal (b- (m "2020-09-10") 1) (m "2020-09-07"))) ; Thu->Mon
534 )
535 ))
536
537(ert-deftest calc-unix-date ()
538 (let* ((d-1970-01-01 (math-parse-date "1970-01-01"))
539 (d-2020-09-07 (math-parse-date "2020-09-07"))
540 (d-1991-01-09-0600 (math-parse-date "1991-01-09 06:00")))
541 ;; calcFunc-unixtime (command "t U") converts a date value to Unix time,
542 ;; and a number to a date.
543 (should (equal d-1970-01-01 '(date 719163)))
544 (should (equal (calcFunc-unixtime d-1970-01-01 0) 0))
545 (should (equal (calc-tests--calc-to-number (cadr (calcFunc-unixtime 0 0)))
546 (cadr d-1970-01-01)))
547 (should (equal (calcFunc-unixtime d-2020-09-07 0)
548 (* (- (cadr d-2020-09-07)
549 (cadr d-1970-01-01))
550 86400)))
551 (should (equal (calcFunc-unixtime d-1991-01-09-0600 0)
552 663400800))
553 (should (equal (calc-tests--calc-to-number
554 (cadr (calcFunc-unixtime 663400800 0)))
555 726841.25))
556
557 (let ((calc-date-format '(U)))
558 ;; Test parsing Unix time.
559 (should (equal (calc-tests--calc-to-number
560 (cadr (math-parse-date "0")))
561 719163))
562 (should (equal (calc-tests--calc-to-number
563 (cadr (math-parse-date "469324800")))
564 (+ 719163 (/ 469324800 86400))))
565 (should (equal (calc-tests--calc-to-number
566 (cadr (math-parse-date "663400800")))
567 726841.25))
568
569 ;; Test formatting Unix time.
570 (should (equal (math-format-date d-1970-01-01) "0"))
571 (should (equal (math-format-date d-2020-09-07)
572 (number-to-string (* (- (cadr d-2020-09-07)
573 (cadr d-1970-01-01))
574 86400))))
575 (should (equal (math-format-date d-1991-01-09-0600) "663400800")))))
576
461(provide 'calc-tests) 577(provide 'calc-tests)
462;;; calc-tests.el ends here 578;;; calc-tests.el ends here
463 579
diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el
index 8b9c1c5fcb5..5f63f6831b3 100644
--- a/test/lisp/electric-tests.el
+++ b/test/lisp/electric-tests.el
@@ -887,7 +887,8 @@ baz\"\""
887 (should (equal (buffer-string) "int main () {\n \n}")))) 887 (should (equal (buffer-string) "int main () {\n \n}"))))
888 888
889(ert-deftest electric-layout-control-reindentation () 889(ert-deftest electric-layout-control-reindentation ()
890 "Same as `e-l-int-main-kernel-style', but checking Bug#35254." 890 "Same as `emacs-lisp-int-main-kernel-style', but checking
891Bug#35254."
891 (ert-with-test-buffer () 892 (ert-with-test-buffer ()
892 (plainer-c-mode) 893 (plainer-c-mode)
893 (electric-layout-local-mode 1) 894 (electric-layout-local-mode 1)
diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el
index 12164b46ec3..fbc71e0ec86 100644
--- a/test/lisp/emacs-lisp/backtrace-tests.el
+++ b/test/lisp/emacs-lisp/backtrace-tests.el
@@ -41,7 +41,7 @@
41 (backtrace-mode) 41 (backtrace-mode)
42 (setq backtrace-frames (backtrace-get-frames)) 42 (setq backtrace-frames (backtrace-get-frames))
43 (let ((this-index)) 43 (let ((this-index))
44 ;; Discard all past `backtrace-tests-make-backtrace'. 44 ;; Discard all past `backtrace-tests--make-backtrace'.
45 (dotimes (index (length backtrace-frames)) 45 (dotimes (index (length backtrace-frames))
46 (when (eq (backtrace-frame-fun (nth index backtrace-frames)) 46 (when (eq (backtrace-frame-fun (nth index backtrace-frames))
47 'backtrace-tests--make-backtrace) 47 'backtrace-tests--make-backtrace)
diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el
index 04a7b2f5a0f..6db07b1b707 100644
--- a/test/lisp/emacs-lisp/edebug-tests.el
+++ b/test/lisp/emacs-lisp/edebug-tests.el
@@ -210,7 +210,7 @@ All other elements will be nil."
210(defvar edebug-tests-thunks nil 210(defvar edebug-tests-thunks nil
211 "List containing thunks to run after each command in a keyboard macro.") 211 "List containing thunks to run after each command in a keyboard macro.")
212(defvar edebug-tests-kbd-macro-index nil 212(defvar edebug-tests-kbd-macro-index nil
213 "Index into `edebug-tests-run-unpacked-kbd-macro's current keyboard macro.") 213 "Index into `edebug-tests-run-kbd-macro's current keyboard macro.")
214 214
215(defun edebug-tests-run-macro (kbdmac &rest thunks) 215(defun edebug-tests-run-macro (kbdmac &rest thunks)
216 "Run a keyboard macro and execute a thunk after each command in it. 216 "Run a keyboard macro and execute a thunk after each command in it.
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index 2e9c6adc947..3829f505010 100644
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -960,7 +960,7 @@ unquoted file names."
960 (let ((linkname (expand-file-name "link" nospecial-dir))) 960 (let ((linkname (expand-file-name "link" nospecial-dir)))
961 (should-error (make-symbolic-link tmpfile linkname)))))))) 961 (should-error (make-symbolic-link tmpfile linkname))))))))
962 962
963;; See `files-tests--file-name-non-special--subprocess'. 963;; See `files-tests-file-name-non-special--subprocess'.
964;; (ert-deftest files-tests-file-name-non-special-process-file ()) 964;; (ert-deftest files-tests-file-name-non-special-process-file ())
965 965
966(ert-deftest files-tests-file-name-non-special-rename-file () 966(ert-deftest files-tests-file-name-non-special-rename-file ()
@@ -1104,7 +1104,7 @@ unquoted file names."
1104 (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) 1104 (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
1105 (should (equal (vc-registered nospecial) (vc-registered tmpfile))))) 1105 (should (equal (vc-registered nospecial) (vc-registered tmpfile)))))
1106 1106
1107;; See test `files-tests--file-name-non-special--buffers'. 1107;; See test `files-tests-file-name-non-special--buffers'.
1108;; (ert-deftest files-tests-file-name-non-special-verify-visited-file-modtime ()) 1108;; (ert-deftest files-tests-file-name-non-special-verify-visited-file-modtime ())
1109 1109
1110(ert-deftest files-tests-file-name-non-special-write-region () 1110(ert-deftest files-tests-file-name-non-special-write-region ()
diff --git a/test/lisp/gnus/gnus-util-tests.el b/test/lisp/gnus/gnus-util-tests.el
index ec58032e84e..47f0a9cf761 100644
--- a/test/lisp/gnus/gnus-util-tests.el
+++ b/test/lisp/gnus/gnus-util-tests.el
@@ -151,8 +151,10 @@
151 (should (equal "Zg==" (gnus-base64-repad "Zg"))) 151 (should (equal "Zg==" (gnus-base64-repad "Zg")))
152 (should (equal "Zg==" (gnus-base64-repad "Zg===="))) 152 (should (equal "Zg==" (gnus-base64-repad "Zg====")))
153 153
154 (should (equal (gnus-base64-repad " ") "")) 154 (should-error (gnus-base64-repad " ")
155 (should (equal (gnus-base64-repad "Zg== ") "Zg==")) 155 :type 'error)
156 (should-error (gnus-base64-repad "Zg== ")
157 :type 'error)
156 (should-error (gnus-base64-repad "Z?\x00g==") 158 (should-error (gnus-base64-repad "Z?\x00g==")
157 :type 'error) 159 :type 'error)
158 ;; line-length 160 ;; line-length
@@ -162,9 +164,10 @@
162 (should-error (gnus-base64-repad "Zm9v\r\nYmFy" t) 164 (should-error (gnus-base64-repad "Zm9v\r\nYmFy" t)
163 :type 'error) 165 :type 'error)
164 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9vYmFy" t))) 166 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9vYmFy" t)))
165 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy" nil))) 167 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy")))
166 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy\n" nil))) 168 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy\n")))
167 (should (equal (gnus-base64-repad "Zm9v\r\n YmFy\r\n" nil) "Zm9vYmFy")) 169 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\n YmFy\r\n")))
170 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v \r\n\tYmFy")))
168 (should-error (gnus-base64-repad "Zm9v\r\nYmFy" nil 3) 171 (should-error (gnus-base64-repad "Zm9v\r\nYmFy" nil 3)
169 :type 'error)) 172 :type 'error))
170 173
diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el
index 4c745ea6d73..427018520c8 100644
--- a/test/lisp/gnus/mml-sec-tests.el
+++ b/test/lisp/gnus/mml-sec-tests.el
@@ -67,7 +67,6 @@ instead of gpg-agent."
67 (condition-case error 67 (condition-case error
68 (let ((epg-gpg-home-directory 68 (let ((epg-gpg-home-directory
69 (expand-file-name "test/data/mml-sec" source-directory)) 69 (expand-file-name "test/data/mml-sec" source-directory))
70 (mml-secure-allow-signing-with-unknown-recipient t)
71 (mml-smime-use 'epg) 70 (mml-smime-use 'epg)
72 ;; Create debug output in empty epg-debug-buffer. 71 ;; Create debug output in empty epg-debug-buffer.
73 (epg-debug t) 72 (epg-debug t)
@@ -762,37 +761,6 @@ Use sign-with-sender and encrypt-to-self."
762 method "no-exp@example.org" "sub@example.org" 2 nil)) 761 method "no-exp@example.org" "sub@example.org" 2 nil))
763 ))))) 762 )))))
764 763
765(ert-deftest mml-secure-sign-verify-2 ()
766 "Sign message without sender; then verify and test for expected result."
767 (skip-unless (test-conf))
768 (mml-secure-test-key-fixture
769 (lambda ()
770 (dolist (method (sign-standards) nil)
771 (let ((mml-secure-openpgp-sign-with-sender nil)
772 (mml-secure-smime-sign-with-sender nil))
773 ;; A single signing key for sender sub@example.org is customized
774 ;; in the fixture, but not used here.
775 ;; By default, gpg uses the first secret key in the keyring, which
776 ;; is 02372A42CA6D40FB (OpenPGP) or
777 ;; 0E58229B80EE33959FF718FEEF25402B479DC6E2 (S/MIME) here.
778 (mml-secure-test-en-decrypt
779 method "uid1@example.org" "sub@example.org" 0 nil)
780
781 ;; From sub@example.org, sign with specified key:
782 (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB"))
783 (mml-secure-smime-signers
784 '("D06AA118653CC38E9D0CAF56ED7A2135E1582177")))
785 (mml-secure-test-en-decrypt
786 method "no-exp@example.org" "sub@example.org" 1 nil))
787
788 ;; From sub@example.org, sign with different specified key:
789 (let ((mml-secure-openpgp-signers '("C3999CF1268DBEA2"))
790 (mml-secure-smime-signers
791 '("0E58229B80EE33959FF718FEEF25402B479DC6E2")))
792 (mml-secure-test-en-decrypt
793 method "no-exp@example.org" "sub@example.org" 1 nil))
794 )))))
795
796(ert-deftest mml-secure-sign-verify-3 () 764(ert-deftest mml-secure-sign-verify-3 ()
797 "Try to sign message with expired OpenPGP subkey, which raises an error. 765 "Try to sign message with expired OpenPGP subkey, which raises an error.
798With Ma Gnus v0.14 and earlier a signature would be created with a wrong key." 766With Ma Gnus v0.14 and earlier a signature would be created with a wrong key."
diff --git a/test/lisp/mail/uudecode-tests.el b/test/lisp/mail/uudecode-tests.el
index 61c20075633..4c9650f556c 100644
--- a/test/lisp/mail/uudecode-tests.el
+++ b/test/lisp/mail/uudecode-tests.el
@@ -43,12 +43,12 @@
43 (uudecode-tests-read-file 43 (uudecode-tests-read-file
44 (expand-file-name "uuencoded.txt" uudecode-tests-data-dir)) 44 (expand-file-name "uuencoded.txt" uudecode-tests-data-dir))
45 "Uuencoded data for bookmark-tests.el 45 "Uuencoded data for bookmark-tests.el
46Same as `bookmark-tests-decoded-str' but uuencoded.") 46Same as `uudecode-tests-decoded-str' but uuencoded.")
47(defvar uudecode-tests-decoded-str 47(defvar uudecode-tests-decoded-str
48 (uudecode-tests-read-file 48 (uudecode-tests-read-file
49 (expand-file-name "uudecoded.txt" uudecode-tests-data-dir)) 49 (expand-file-name "uudecoded.txt" uudecode-tests-data-dir))
50 "Plain text data for bookmark-tests.el 50 "Plain text data for bookmark-tests.el
51Same as `bookmark-tests-encoded-str' but plain text.") 51Same as `uudecode-tests-encoded-str' but plain text.")
52 52
53(ert-deftest uudecode-tests-decode-region-internal () 53(ert-deftest uudecode-tests-decode-region-internal ()
54 ;; Write to buffer 54 ;; Write to buffer
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 @@
1<?xml version="1.0"?>
2<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
3<node>
4 <interface name="org.freedesktop.DBus.Introspectable">
5 <method name="Introspect">
6 <arg name="xml" type="s" direction="out"/>
7 </method>
8 </interface>
9 <interface name="org.freedesktop.DBus.Properties">
10 <method name="Get">
11 <arg name="interface" type="s" direction="in"/>
12 <arg name="name" type="s" direction="in"/>
13 <arg name="value" type="v" direction="out"/>
14 </method>
15 <method name="Set">
16 <arg name="interface" type="s" direction="in"/>
17 <arg name="name" type="s" direction="in"/>
18 <arg name="value" type="v" direction="in"/>
19 </method>
20 <method name="GetAll">
21 <arg name="interface" type="s" direction="in"/>
22 <arg name="properties" type="a{sv}" direction="out"/>
23 </method>
24 <signal name="PropertiesChanged">
25 <arg name="interface" type="s"/>
26 <arg name="changed_properties" type="a{sv}"/>
27 <arg name="invalidated_properties" type="as"/>
28 </signal>
29 </interface>
30 <interface name="org.gnu.Emacs.TestDBus.Interface">
31 <method name="Connect">
32 <arg name="uuid" type="s" direction="in"/>
33 <arg name="mode" type="y" direction="in"/>
34 <arg name="options" type="a{sv}" direction="in"/>
35 <arg name="interface" type="s" direction="out"/>
36 </method>
37 <method name="DeprecatedMethod0">
38 <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
39 </method>
40 <method name="DeprecatedMethod1">
41 <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
42 </method>
43 <property name="Connected" type="b" access="read"/>
44 <property name="Player" type="o" access="read"/>
45 <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
46 </interface>
47 <node name="node0"/>
48 <node name="node1"/>
49</node>
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 74c0dddcf52..7ebef5d2609 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -46,6 +46,13 @@
46(defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface" 46(defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface"
47 "Test interface.") 47 "Test interface.")
48 48
49(defconst dbus--tests-dir
50 (file-truename
51 (expand-file-name "dbus-resources"
52 (file-name-directory (or load-file-name
53 buffer-file-name))))
54 "Directory containing introspection test data file.")
55
49(defun dbus--test-availability (bus) 56(defun dbus--test-availability (bus)
50 "Test availability of D-Bus BUS." 57 "Test availability of D-Bus BUS."
51 (should (dbus-list-names bus)) 58 (should (dbus-list-names bus))
@@ -309,7 +316,7 @@
309 (dbus-check-arguments :session dbus--test-service :double "string") 316 (dbus-check-arguments :session dbus--test-service :double "string")
310 :type 'wrong-type-argument) 317 :type 'wrong-type-argument)
311 318
312 ;; `:unix-fd'. UNIX file descriptors are transfered out-of-band. 319 ;; `:unix-fd'. UNIX file descriptors are transferred out-of-band.
313 ;; We do not support this, and so we cannot do much testing here for 320 ;; We do not support this, and so we cannot do much testing here for
314 ;; `:unix-fd' being an argument (which is an index to the file 321 ;; `:unix-fd' being an argument (which is an index to the file
315 ;; descriptor in the array of file descriptors that accompany the 322 ;; descriptor in the array of file descriptors that accompany the
@@ -359,11 +366,11 @@
359 (should 366 (should
360 (dbus-check-arguments 367 (dbus-check-arguments
361 :session dbus--test-service '(:variant (:array "string")))) 368 :session dbus--test-service '(:variant (:array "string"))))
362 ;; No or more than one element. 369 ;; Empty variant.
363 ;; FIXME. 370 (should-error
364 ;; (should-error 371 (dbus-check-arguments :session dbus--test-service '(:variant))
365 ;; (dbus-check-arguments :session dbus--test-service '(:variant)) 372 :type 'wrong-type-argument)
366 ;; :type 'wrong-type-argument) 373 ;; More than one element.
367 (should-error 374 (should-error
368 (dbus-check-arguments 375 (dbus-check-arguments
369 :session dbus--test-service 376 :session dbus--test-service
@@ -375,20 +382,22 @@
375 (should 382 (should
376 (dbus-check-arguments 383 (dbus-check-arguments
377 :session dbus--test-service 384 :session dbus--test-service
378 '(:array (:dict-entry :string "string" :boolean t)))) 385 '(:array (:dict-entry :string "string" :boolean nil))))
379 ;; This is an alternative syntax. FIXME: Shall this be supported? 386 ;; This is an alternative syntax. FIXME: Shall this be supported?
380 (should 387 (should
381 (dbus-check-arguments 388 (dbus-check-arguments
382 :session dbus--test-service 389 :session dbus--test-service
383 '(:array :dict-entry (:string "string" :boolean t)))) 390 '(:array :dict-entry (:string "string" :boolean t))))
384 ;; FIXME: Must be errors. 391 ;; Empty dict-entry.
385 ;; (should 392 (should-error
386 ;; (dbus-check-arguments 393 (dbus-check-arguments
387 ;; :session dbus--test-service '(:array (:dict-entry)))) 394 :session dbus--test-service '(:array (:dict-entry)))
388 ;; (should 395 :type 'wrong-type-argument)
389 ;; (dbus-check-arguments 396 ;; One element.
390 ;; :session dbus--test-service '(:array (:dict-entry :string "string")))) 397 (should-error
391 ;; Not two elements. 398 (dbus-check-arguments
399 :session dbus--test-service '(:array (:dict-entry :string "string")))
400 :type 'wrong-type-argument)
392 (should-error 401 (should-error
393 (dbus-check-arguments 402 (dbus-check-arguments
394 :session dbus--test-service 403 :session dbus--test-service
@@ -405,25 +414,27 @@
405 (dbus-check-arguments 414 (dbus-check-arguments
406 :session dbus--test-service '(:dict-entry :string "string" :boolean t)) 415 :session dbus--test-service '(:dict-entry :string "string" :boolean t))
407 :type 'wrong-type-argument) 416 :type 'wrong-type-argument)
408 ;; FIXME:! This doesn't look right. 417 ;; Different dict entry types are not ched. FIXME: Add check.
409 ;; Different dict entry types can be part of an array ??? 418 ;; (should-error
410 (should 419 ;; (dbus-check-arguments
411 (dbus-check-arguments 420 ;; :session dbus--test-service
412 :session dbus--test-service 421 ;; '(:array
413 '(:array 422 ;; (:dict-entry :string "string1" :boolean t)
414 (:dict-entry :string "string1" :boolean t) 423 ;; (:dict-entry :string "string2" :object-path "/object/path")))
415 (:dict-entry :string "string2" :object-path "/object/path")))) 424 ;; :type 'wrong-type-argument)
416 425
417 ;; `:struct'. There is no restriction what could be an element of a struct. 426 ;; `:struct'. There is no restriction what could be an element of a struct.
418 ;; Empty struct. FIXME: Is this right?
419 ;; (should (dbus-check-arguments :session dbus--test-service '(:struct)))
420 (should 427 (should
421 (dbus-check-arguments 428 (dbus-check-arguments
422 :session dbus--test-service 429 :session dbus--test-service
423 '(:struct 430 '(:struct
424 :string "string" 431 :string "string"
425 :object-path "/object/path" 432 :object-path "/object/path"
426 (:variant (:array :unix-fd 1 :unix-fd 2 :unix-fd 3 :unix-fd 4)))))) 433 (:variant (:array :unix-fd 1 :unix-fd 2 :unix-fd 3 :unix-fd 4)))))
434 ;; Empty struct.
435 (should-error
436 (dbus-check-arguments :session dbus--test-service '(:struct))
437 :type 'wrong-type-argument))
427 438
428(defun dbus--test-register-service (bus) 439(defun dbus--test-register-service (bus)
429 "Check service registration at BUS." 440 "Check service registration at BUS."
@@ -625,6 +636,63 @@ This includes initialization and closing the bus."
625 ;; Cleanup. 636 ;; Cleanup.
626 (dbus-unregister-service :session dbus--test-service))) 637 (dbus-unregister-service :session dbus--test-service)))
627 638
639(defun dbus--test-method-reentry-handler (&rest _args)
640 "Method handler for `dbus-test04-method-reentry'."
641 (dbus-get-all-managed-objects :session dbus--test-service dbus--test-path)
642 42)
643
644(ert-deftest dbus-test04-method-reentry ()
645 "Check receiving method call while awaiting response.
646Ensure that incoming method calls are handled when call to `dbus-call-method'
647is in progress."
648 :tags '(:expensive-test)
649 ;; Simulate application registration. (Bug#43251)
650 (skip-unless dbus--test-enabled-session-bus)
651 (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
652
653 (unwind-protect
654 (let ((method "Reentry"))
655 (should
656 (equal
657 (dbus-register-method
658 :session dbus--test-service dbus--test-path
659 dbus--test-interface method #'dbus--test-method-reentry-handler)
660 `((:method :session ,dbus--test-interface ,method)
661 (,dbus--test-service ,dbus--test-path
662 dbus--test-method-reentry-handler))))
663
664 (should
665 (=
666 (dbus-call-method
667 :session dbus--test-service dbus--test-path
668 dbus--test-interface method)
669 42)))
670
671 ;; Cleanup.
672 (dbus-unregister-service :session dbus--test-service)))
673
674(ert-deftest dbus-test04-call-method-timeout ()
675 "Verify `dbus-call-method' request timeout."
676 :tags '(:expensive-test)
677 (skip-unless dbus--test-enabled-session-bus)
678 (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
679 (dbus-register-service :session dbus--test-service)
680
681 (unwind-protect
682 (let ((start (current-time)))
683 ;; Test timeout override for method call.
684 (should-error
685 (dbus-call-method
686 :session dbus--test-service dbus--test-path
687 dbus-interface-introspectable "Introspect" :timeout 2500)
688 :type 'dbus-error)
689
690 (should
691 (< 2.4 (float-time (time-since start)) 2.7)))
692
693 ;; Cleanup.
694 (dbus-unregister-service :session dbus--test-service)))
695
628(defvar dbus--test-signal-received nil 696(defvar dbus--test-signal-received nil
629 "Received signal value in `dbus--test-signal-handler'.") 697 "Received signal value in `dbus--test-signal-handler'.")
630 698
@@ -1069,6 +1137,702 @@ This includes initialization and closing the bus."
1069 ;; Cleanup. 1137 ;; Cleanup.
1070 (dbus-unregister-service :session dbus--test-service))) 1138 (dbus-unregister-service :session dbus--test-service)))
1071 1139
1140(defsubst dbus--test-run-property-test (selector name value expected)
1141 "Generate a property test: register, set, get, getall sequence.
1142This is a helper function for the macro `dbus--test-property'.
1143The argument SELECTOR indicates whether the test should expand to
1144`dbus-register-property' (if SELECTOR is `register') or
1145`dbus-set-property' (if SELECTOR is `set').
1146The argument NAME is the property name.
1147The argument VALUE is the value to register or set.
1148The argument EXPECTED is a transformed VALUE representing the
1149form `dbus-get-property' should return."
1150 (cond
1151 ((eq selector 'register)
1152 (should
1153 (equal
1154 (dbus-register-property
1155 :session dbus--test-service dbus--test-path dbus--test-interface name
1156 :readwrite value)
1157 `((:property :session ,dbus--test-interface ,name)
1158 (,dbus--test-service ,dbus--test-path)))))
1159
1160 ((eq selector 'set)
1161 (should
1162 (equal
1163 (dbus-set-property
1164 :session dbus--test-service dbus--test-path dbus--test-interface name
1165 value)
1166 expected)))
1167
1168 (t (signal 'wrong-type-argument "Selector should be 'register or 'set.")))
1169
1170 (should
1171 (equal
1172 (dbus-get-property
1173 :session dbus--test-service dbus--test-path dbus--test-interface name)
1174 expected))
1175
1176 (let ((result
1177 (dbus-get-all-properties
1178 :session dbus--test-service dbus--test-path dbus--test-interface)))
1179 (should (equal (cdr (assoc name result)) expected)))
1180
1181 (let ((result
1182 (dbus-get-all-managed-objects :session dbus--test-service "/"))
1183 result1)
1184 (should (setq result1 (cadr (assoc dbus--test-path result))))
1185 (should (setq result1 (cadr (assoc dbus--test-interface result1))))
1186 (should (equal (cdr (assoc name result1)) expected))))
1187
1188(defsubst dbus--test-property (name &rest value-list)
1189 "Test a D-Bus property named by string argument NAME.
1190The argument VALUE-LIST is a sequence of pairs, where each pair
1191represents a value form and an expected returned value form. The
1192first pair in VALUES is used for `dbus-register-property'.
1193Subsequent pairs of the list are tested with `dbus-set-property'."
1194 (let ((values (car value-list)))
1195 (dbus--test-run-property-test
1196 'register name (car values) (cdr values)))
1197 (dolist (values (cdr value-list))
1198 (dbus--test-run-property-test
1199 'set name (car values) (cdr values))))
1200
1201(ert-deftest dbus-test06-property-types ()
1202 "Check property access and mutation for an own service."
1203 (skip-unless dbus--test-enabled-session-bus)
1204 (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
1205 (dbus-register-service :session dbus--test-service)
1206
1207 (unwind-protect
1208 (progn
1209 (dbus--test-property
1210 "ByteArray"
1211 '((:array :byte 1 :byte 2 :byte 3) . (1 2 3))
1212 '((:array :byte 4 :byte 5 :byte 6) . (4 5 6)))
1213
1214 (dbus--test-property
1215 "StringArray"
1216 '((:array "one" "two" :string "three") . ("one" "two" "three"))
1217 '((:array :string "four" :string "five" "six") . ("four" "five" "six")))
1218
1219 (dbus--test-property
1220 "ObjectArray"
1221 '((:array
1222 :object-path "/node00"
1223 :object-path "/node01"
1224 :object-path "/node0/node02")
1225 . ("/node00" "/node01" "/node0/node02"))
1226 '((:array
1227 :object-path "/node10"
1228 :object-path "/node11"
1229 :object-path "/node0/node12")
1230 . ("/node10" "/node11" "/node0/node12")))
1231
1232 (dbus--test-property
1233 "Dictionary"
1234 '((:array
1235 :dict-entry (:string "four" (:variant :string "value of four"))
1236 :dict-entry ("five" (:variant :object-path "/node0"))
1237 :dict-entry ("six" (:variant (:array :byte 4 :byte 5 :byte 6))))
1238 . (("four"
1239 ("value of four"))
1240 ("five"
1241 ("/node0"))
1242 ("six"
1243 ((4 5 6)))))
1244 '((:array
1245 :dict-entry
1246 (:string "key0" (:variant (:array :byte 7 :byte 8 :byte 9)))
1247 :dict-entry ("key1" (:variant :string "value"))
1248 :dict-entry ("key2" (:variant :object-path "/node0/node1")))
1249 . (("key0"
1250 ((7 8 9)))
1251 ("key1"
1252 ("value"))
1253 ("key2"
1254 ("/node0/node1")))))
1255
1256 (dbus--test-property ; Syntax emphasizing :dict compound type.
1257 "Dictionary"
1258 '((:array
1259 (:dict-entry :string "seven" (:variant :string "value of seven"))
1260 (:dict-entry "eight" (:variant :object-path "/node8"))
1261 (:dict-entry "nine" (:variant (:array :byte 9 :byte 27 :byte 81))))
1262 . (("seven"
1263 ("value of seven"))
1264 ("eight"
1265 ("/node8"))
1266 ("nine"
1267 ((9 27 81)))))
1268 '((:array
1269 (:dict-entry
1270 :string "key4" (:variant (:array :byte 7 :byte 49 :byte 125)))
1271 (:dict-entry "key5" (:variant :string "obsolete"))
1272 (:dict-entry "key6" (:variant :object-path "/node6/node7")))
1273 . (("key4"
1274 ((7 49 125)))
1275 ("key5"
1276 ("obsolete"))
1277 ("key6"
1278 ("/node6/node7")))))
1279
1280 (dbus--test-property
1281 "ByteDictionary"
1282 '((:array
1283 (:dict-entry :byte 8 (:variant :string "byte-eight"))
1284 (:dict-entry :byte 16 (:variant :object-path "/byte/sixteen"))
1285 (:dict-entry :byte 48 (:variant (:array :byte 8 :byte 9 :byte 10))))
1286 . (( 8 ("byte-eight"))
1287 (16 ("/byte/sixteen"))
1288 (48 ((8 9 10))))))
1289
1290 (dbus--test-property
1291 "Variant"
1292 '((:variant "Variant string") . ("Variant string"))
1293 '((:variant :byte 42) . (42))
1294 '((:variant :uint32 1000000) . (1000000))
1295 '((:variant :object-path "/variant/path") . ("/variant/path"))
1296 '((:variant :signature "a{sa{sv}}") . ("a{sa{sv}}"))
1297 '((:variant
1298 (:struct
1299 42 "string" (:object-path "/structure/path") (:variant "last")))
1300 . ((42 "string" ("/structure/path") ("last")))))
1301
1302 ;; Test that :read prevents writes.
1303 (should
1304 (equal
1305 (dbus-register-property
1306 :session dbus--test-service dbus--test-path dbus--test-interface
1307 "StringArray" :read '(:array "one" "two" :string "three"))
1308 `((:property :session ,dbus--test-interface "StringArray")
1309 (,dbus--test-service ,dbus--test-path))))
1310
1311 (should-error ; Cannot set property with :read access.
1312 (dbus-set-property
1313 :session dbus--test-service dbus--test-path dbus--test-interface
1314 "StringArray" '(:array "seven" "eight" :string "nine"))
1315 :type 'dbus-error)
1316
1317 (should ; Property value preserved on error.
1318 (equal
1319 (dbus-get-property
1320 :session dbus--test-service dbus--test-path dbus--test-interface
1321 "StringArray")
1322 '("one" "two" "three")))
1323
1324 ;; Test mismatched types in array.
1325 (should-error
1326 (dbus-register-property
1327 :session dbus--test-service dbus--test-path dbus--test-interface
1328 "MixedArray" :readwrite
1329 '(:array
1330 :object-path "/node00"
1331 :string "/node01"
1332 :object-path "/node0/node02"))
1333 :type 'wrong-type-argument)
1334
1335 ;; Test in-range integer values.
1336 (should
1337 (equal
1338 (dbus-register-property
1339 :session dbus--test-service dbus--test-path dbus--test-interface
1340 "ByteValue" :readwrite :byte 255)
1341 `((:property :session ,dbus--test-interface "ByteValue")
1342 (,dbus--test-service ,dbus--test-path))))
1343
1344 (should
1345 (=
1346 (dbus-get-property
1347 :session dbus--test-service dbus--test-path dbus--test-interface
1348 "ByteValue")
1349 255))
1350
1351 (should
1352 (equal
1353 (dbus-register-property
1354 :session dbus--test-service dbus--test-path dbus--test-interface
1355 "ShortValue" :readwrite :int16 32767)
1356 `((:property :session ,dbus--test-interface "ShortValue")
1357 (,dbus--test-service ,dbus--test-path))))
1358
1359 (should
1360 (=
1361 (dbus-get-property
1362 :session dbus--test-service dbus--test-path dbus--test-interface
1363 "ShortValue")
1364 32767))
1365
1366 (should
1367 (equal
1368 (dbus-register-property
1369 :session dbus--test-service dbus--test-path dbus--test-interface
1370 "UShortValue" :readwrite :uint16 65535)
1371 `((:property :session ,dbus--test-interface "UShortValue")
1372 (,dbus--test-service ,dbus--test-path))))
1373
1374 (should
1375 (=
1376 (dbus-get-property
1377 :session dbus--test-service dbus--test-path dbus--test-interface
1378 "UShortValue")
1379 65535))
1380
1381 (should
1382 (equal
1383 (dbus-register-property
1384 :session dbus--test-service dbus--test-path dbus--test-interface
1385 "IntValue" :readwrite :int32 2147483647)
1386 `((:property :session ,dbus--test-interface "IntValue")
1387 (,dbus--test-service ,dbus--test-path))))
1388
1389 (should
1390 (=
1391 (dbus-get-property
1392 :session dbus--test-service dbus--test-path
1393 dbus--test-interface "IntValue")
1394 2147483647))
1395
1396 (should
1397 (equal
1398 (dbus-register-property
1399 :session dbus--test-service dbus--test-path dbus--test-interface
1400 "UIntValue" :readwrite :uint32 4294967295)
1401 `((:property :session ,dbus--test-interface "UIntValue")
1402 (,dbus--test-service ,dbus--test-path))))
1403
1404 (should
1405 (=
1406 (dbus-get-property
1407 :session dbus--test-service dbus--test-path dbus--test-interface
1408 "UIntValue")
1409 4294967295))
1410
1411 (should
1412 (equal
1413 (dbus-register-property
1414 :session dbus--test-service dbus--test-path dbus--test-interface
1415 "LongValue" :readwrite :int64 9223372036854775807)
1416 `((:property :session ,dbus--test-interface "LongValue")
1417 (,dbus--test-service ,dbus--test-path))))
1418
1419 (should
1420 (=
1421 (dbus-get-property
1422 :session dbus--test-service dbus--test-path dbus--test-interface
1423 "LongValue")
1424 9223372036854775807))
1425
1426 (should
1427 (equal
1428 (dbus-register-property
1429 :session dbus--test-service dbus--test-path dbus--test-interface
1430 "ULongValue" :readwrite :uint64 18446744073709551615)
1431 `((:property :session ,dbus--test-interface "ULongValue")
1432 (,dbus--test-service ,dbus--test-path))))
1433
1434 (should
1435 (=
1436 (dbus-get-property
1437 :session dbus--test-service dbus--test-path dbus--test-interface
1438 "ULongValue")
1439 18446744073709551615))
1440
1441 ;; Test integer overflow.
1442 (should
1443 (=
1444 (dbus-set-property
1445 :session dbus--test-service dbus--test-path dbus--test-interface
1446 "ByteValue" :byte 520)
1447 8))
1448
1449 (should
1450 (=
1451 (dbus-get-property
1452 :session dbus--test-service dbus--test-path dbus--test-interface
1453 "ByteValue")
1454 8))
1455
1456 (should-error
1457 (dbus-register-property
1458 :session dbus--test-service dbus--test-path dbus--test-interface
1459 "ShortValue" :readwrite :int16 32800)
1460 :type 'args-out-of-range)
1461
1462 (should-error
1463 (dbus-register-property
1464 :session dbus--test-service dbus--test-path dbus--test-interface
1465 "UShortValue" :readwrite :uint16 65600)
1466 :type 'args-out-of-range)
1467
1468 (should-error
1469 (dbus-register-property
1470 :session dbus--test-service dbus--test-path dbus--test-interface
1471 "IntValue" :readwrite :int32 2147483700)
1472 :type 'args-out-of-range)
1473
1474 (should-error
1475 (dbus-register-property
1476 :session dbus--test-service dbus--test-path dbus--test-interface
1477 "UIntValue" :readwrite :uint32 4294967300)
1478 :type 'args-out-of-range)
1479
1480 (should-error
1481 (dbus-register-property
1482 :session dbus--test-service dbus--test-path dbus--test-interface
1483 "LongValue" :readwrite :int64 9223372036854775900)
1484 :type 'args-out-of-range)
1485
1486 (should-error
1487 (dbus-register-property
1488 :session dbus--test-service dbus--test-path dbus--test-interface
1489 "ULongValue" :readwrite :uint64 18446744073709551700)
1490 :type 'args-out-of-range)
1491
1492 ;; dbus-set-property may change property type.
1493 (should
1494 (=
1495 (dbus-set-property
1496 :session dbus--test-service dbus--test-path dbus--test-interface
1497 "ByteValue" 1024)
1498 1024))
1499
1500 (should
1501 (=
1502 (dbus-get-property
1503 :session dbus--test-service dbus--test-path dbus--test-interface
1504 "ByteValue")
1505 1024))
1506
1507 (should ; Another change property type test.
1508 (equal
1509 (dbus-set-property
1510 :session dbus--test-service dbus--test-path dbus--test-interface
1511 "ByteValue" :boolean t)
1512 t))
1513
1514 (should
1515 (eq
1516 (dbus-get-property
1517 :session dbus--test-service dbus--test-path dbus--test-interface
1518 "ByteValue")
1519 t))
1520
1521 ;; Test invalid type specification.
1522 (should-error
1523 (dbus-register-property
1524 :session dbus--test-service dbus--test-path dbus--test-interface
1525 "InvalidType" :readwrite :keyword 128)
1526 :type 'wrong-type-argument))
1527
1528 ;; Cleanup.
1529 (dbus-unregister-service :session dbus--test-service)))
1530
1531(defun dbus--test-introspect ()
1532 "Return test introspection string."
1533 (when (string-equal dbus--test-path (dbus-event-path-name last-input-event))
1534 (with-temp-buffer
1535 (insert-file-contents-literally
1536 (expand-file-name "org.gnu.Emacs.TestDBus.xml" dbus--tests-dir))
1537 (buffer-string))))
1538
1539(defsubst dbus--test-validate-interface
1540 (iface-name expected-properties expected-methods expected-signals
1541 expected-annotations)
1542 "Validate an interface definition for `dbus-test07-introspection'.
1543The argument IFACE-NAME is a string naming the interface to validate.
1544The arguments EXPECTED-PROPERTIES, EXPECTED-METHODS, EXPECTED-SIGNALS, and
1545EXPECTED-ANNOTATIONS represent the names of the interface's properties,
1546methods, signals, and annotations, respectively."
1547
1548 (let ((interface
1549 (dbus-introspect-get-interface
1550 :session dbus--test-service dbus--test-path iface-name)))
1551 (pcase-let ((`(interface ((name . ,name)) . ,rest) interface))
1552 (should
1553 (string-equal name iface-name))
1554 (should
1555 (string-equal name (dbus-introspect-get-attribute interface "name")))
1556
1557 (let (properties methods signals annotations)
1558 (mapc (lambda (x)
1559 (let ((name (dbus-introspect-get-attribute x "name")))
1560 (cond
1561 ((eq 'property (car x)) (push name properties))
1562 ((eq 'method (car x)) (push name methods))
1563 ((eq 'signal (car x)) (push name signals))
1564 ((eq 'annotation (car x)) (push name annotations)))))
1565 rest)
1566
1567 (should
1568 (equal
1569 (nreverse properties)
1570 expected-properties))
1571 (should
1572 (equal
1573 (nreverse methods)
1574 expected-methods))
1575 (should
1576 (equal
1577 (nreverse signals)
1578 expected-signals))
1579 (should
1580 (equal
1581 (nreverse annotations)
1582 expected-annotations))))))
1583
1584(defsubst dbus--test-validate-annotations (annotations expected-annotations)
1585 "Validate a list of D-Bus ANNOTATIONS.
1586Ensure each string in EXPECTED-ANNOTATIONS names an element of ANNOTATIONS.
1587And ensure each ANNOTATIONS has a value attribute marked \"true\"."
1588 (mapc
1589 (lambda (annotation)
1590 (let ((name (dbus-introspect-get-attribute annotation "name"))
1591 (value (dbus-introspect-get-attribute annotation "value")))
1592 (should
1593 (member name expected-annotations))
1594 (should
1595 (equal value "true"))))
1596 annotations))
1597
1598(defsubst dbus--test-validate-property
1599 (interface property-name _expected-annotations &rest expected-args)
1600 "Validate a property definition for `dbus-test07-introspection'.
1601
1602The argument INTERFACE is a string naming the interface owning PROPERTY-NAME.
1603The argument PROPERTY-NAME is a string naming the property to validate.
1604The arguments EXPECTED-ANNOTATIONS is a list of strings matching
1605the annotation names defined for the method or signal.
1606The argument EXPECTED-ARGS is a list of expected arguments for the property."
1607 (let* ((property
1608 (dbus-introspect-get-property
1609 :session dbus--test-service dbus--test-path interface property-name))
1610 (name (dbus-introspect-get-attribute property "name"))
1611 (type (dbus-introspect-get-attribute property "type"))
1612 (access (dbus-introspect-get-attribute property "access"))
1613 (expected (assoc-string name expected-args)))
1614 (should expected)
1615
1616 (should
1617 (string-equal name property-name))
1618
1619 (should
1620 (string-equal
1621 (nth 0 expected)
1622 name))
1623
1624 (should
1625 (string-equal
1626 (nth 1 expected)
1627 type))
1628
1629 (should
1630 (string-equal
1631 (nth 2 expected)
1632 access))))
1633
1634(defsubst dbus--test-validate-m-or-s (tree expected-annotations expected-args)
1635 "Validate a method or signal definition for `dbus-test07-introspection'.
1636The argument TREE is an sexp returned from either `dbus-introspect-get-method'
1637or `dbus-introspect-get-signal'
1638The arguments EXPECTED-ANNOTATIONS is a list of strings matching
1639the annotation names defined for the method or signal.
1640The argument EXPECTED-ARGS is a list of expected arguments for
1641the method or signal."
1642 (let (args annotations)
1643 (mapc (lambda (elem)
1644 (cond
1645 ((eq 'arg (car elem)) (push elem args))
1646 ((eq 'annotation (car elem)) (push elem annotations))))
1647 tree)
1648 (should
1649 (equal
1650 (nreverse args)
1651 expected-args))
1652 (dbus--test-validate-annotations annotations expected-annotations)))
1653
1654(defsubst dbus--test-validate-signal
1655 (interface signal-name expected-annotations &rest expected-args)
1656 "Validate a signal definition for `dbus-test07-introspection'.
1657
1658The argument INTERFACE is a string naming the interface owning SIGNAL-NAME.
1659The argument SIGNAL-NAME is a string naming the signal to validate.
1660The arguments EXPECTED-ANNOTATIONS is a list of strings matching
1661the annotation names defined for the signal.
1662The argument EXPECTED-ARGS is a list of expected arguments for the signal."
1663 (let ((signal
1664 (dbus-introspect-get-signal
1665 :session dbus--test-service dbus--test-path interface signal-name)))
1666 (pcase-let ((`(signal ((name . ,name)) . ,rest) signal))
1667 (should
1668 (string-equal name signal-name))
1669 (should
1670 (string-equal name (dbus-introspect-get-attribute signal "name")))
1671 (dbus--test-validate-m-or-s rest expected-annotations expected-args))))
1672
1673(defsubst dbus--test-validate-method
1674 (interface method-name expected-annotations &rest expected-args)
1675 "Validate a method definition for `dbus-test07-introspection'.
1676
1677The argument INTERFACE is a string naming the interface owning METHOD-NAME.
1678The argument METHOD-NAME is a string naming the method to validate.
1679The arguments EXPECTED-ANNOTATIONS is a list of strings matching
1680the annotation names defined for the method.
1681The argument EXPECTED-ARGS is a list of expected arguments for the method."
1682 (let ((method
1683 (dbus-introspect-get-method
1684 :session dbus--test-service dbus--test-path interface method-name)))
1685 (pcase-let ((`(method ((name . ,name)) . ,rest) method))
1686 (should
1687 (string-equal name method-name))
1688 (should
1689 (string-equal name (dbus-introspect-get-attribute method "name")))
1690 (dbus--test-validate-m-or-s rest expected-annotations expected-args))))
1691
1692(ert-deftest dbus-test07-introspection ()
1693 "Register an Introspection interface then query it."
1694 (skip-unless dbus--test-enabled-session-bus)
1695 (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
1696 (dbus-register-service :session dbus--test-service)
1697
1698 ;; Prepare introspection response.
1699 (dbus-register-method
1700 :session dbus--test-service dbus--test-path dbus-interface-introspectable
1701 "Introspect" 'dbus--test-introspect)
1702 (dbus-register-method
1703 :session dbus--test-service (concat dbus--test-path "/node0")
1704 dbus-interface-introspectable
1705 "Introspect" 'dbus--test-introspect)
1706 (dbus-register-method
1707 :session dbus--test-service (concat dbus--test-path "/node1")
1708 dbus-interface-introspectable
1709 "Introspect" 'dbus--test-introspect)
1710 (unwind-protect
1711 (let ((start (current-time)))
1712 ;; dbus-introspect-get-node-names
1713 (should
1714 (equal
1715 (dbus-introspect-get-node-names
1716 :session dbus--test-service dbus--test-path)
1717 '("node0" "node1")))
1718
1719 ;; dbus-introspect-get-all-nodes
1720 (should
1721 (equal
1722 (dbus-introspect-get-all-nodes
1723 :session dbus--test-service dbus--test-path)
1724 (list dbus--test-path
1725 (concat dbus--test-path "/node0")
1726 (concat dbus--test-path "/node1"))))
1727
1728 ;; dbus-introspect-get-interface-names
1729 (let ((interfaces
1730 (dbus-introspect-get-interface-names
1731 :session dbus--test-service dbus--test-path)))
1732
1733 (should
1734 (equal
1735 interfaces
1736 `(,dbus-interface-introspectable
1737 ,dbus-interface-properties
1738 ,dbus--test-interface)))
1739
1740 (dbus--test-validate-interface
1741 dbus-interface-introspectable nil '("Introspect") nil nil)
1742
1743 ;; dbus-introspect-get-interface via `dbus--test-validate-interface'.
1744 (dbus--test-validate-interface
1745 dbus-interface-properties nil
1746 '("Get" "Set" "GetAll") '("PropertiesChanged") nil)
1747
1748 (dbus--test-validate-interface
1749 dbus--test-interface '("Connected" "Player")
1750 '("Connect" "DeprecatedMethod0" "DeprecatedMethod1") nil
1751 `(,dbus-annotation-deprecated)))
1752
1753 ;; dbus-introspect-get-method-names
1754 (let ((methods
1755 (dbus-introspect-get-method-names
1756 :session dbus--test-service dbus--test-path
1757 dbus--test-interface)))
1758 (should
1759 (equal
1760 methods
1761 '("Connect" "DeprecatedMethod0" "DeprecatedMethod1")))
1762
1763 ;; dbus-introspect-get-method via `dbus--test-validate-method'.
1764 (dbus--test-validate-method
1765 dbus--test-interface "Connect" nil
1766 '(arg ((name . "uuid") (type . "s") (direction . "in")))
1767 '(arg ((name . "mode") (type . "y") (direction . "in")))
1768 '(arg ((name . "options") (type . "a{sv}") (direction . "in")))
1769 '(arg ((name . "interface") (type . "s") (direction . "out"))))
1770
1771 (dbus--test-validate-method
1772 dbus--test-interface "DeprecatedMethod0"
1773 `(,dbus-annotation-deprecated))
1774
1775 (dbus--test-validate-method
1776 dbus--test-interface "DeprecatedMethod1"
1777 `(,dbus-annotation-deprecated)))
1778
1779 ;; dbus-introspect-get-signal-names
1780 (let ((signals
1781 (dbus-introspect-get-signal-names
1782 :session dbus--test-service dbus--test-path
1783 dbus-interface-properties)))
1784 (should
1785 (equal
1786 signals
1787 '("PropertiesChanged")))
1788
1789 ;; dbus-introspect-get-signal via `dbus--test-validate-signal'.
1790 (dbus--test-validate-signal
1791 dbus-interface-properties "PropertiesChanged" nil
1792 '(arg ((name . "interface") (type . "s")))
1793 '(arg ((name . "changed_properties") (type . "a{sv}")))
1794 '(arg ((name . "invalidated_properties") (type . "as")))))
1795
1796 ;; dbus-intropct-get-property-names
1797 (let ((properties
1798 (dbus-introspect-get-property-names
1799 :session dbus--test-service dbus--test-path
1800 dbus--test-interface)))
1801 (should
1802 (equal
1803 properties
1804 '("Connected" "Player")))
1805
1806 ;; dbus-introspect-get-property via `dbus--test-validate-property'.
1807 (dbus--test-validate-property
1808 dbus--test-interface "Connected" nil
1809 '("Connected" "b" "read")
1810 '("Player" "o" "read")))
1811
1812 ;; Elapsed time over a second suggests timeouts.
1813 (should
1814 (< 0.0 (float-time (time-since start)) 1.0)))
1815
1816 ;; Cleanup.
1817 (dbus-unregister-service :session dbus--test-service)))
1818
1819(ert-deftest dbus-test07-introspection-timeout ()
1820 "Verify introspection request timeouts."
1821 :tags '(:expensive-test)
1822 (skip-unless dbus--test-enabled-session-bus)
1823 (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
1824 (dbus-register-service :session dbus--test-service)
1825
1826 (unwind-protect
1827 (let ((start (current-time)))
1828 (dbus-introspect-xml :session dbus--test-service dbus--test-path)
1829 ;; Introspection internal timeout is one second.
1830 (should
1831 (< 1.0 (float-time (time-since start)))))
1832
1833 ;; Cleanup.
1834 (dbus-unregister-service :session dbus--test-service)))
1835
1072(defun dbus-test-all (&optional interactive) 1836(defun dbus-test-all (&optional interactive)
1073 "Run all tests for \\[dbus]." 1837 "Run all tests for \\[dbus]."
1074 (interactive "p") 1838 (interactive "p")
diff --git a/test/lisp/obsolete/cl-tests.el b/test/lisp/obsolete/cl-tests.el
index 37061df0a7a..3f3fda3638e 100644
--- a/test/lisp/obsolete/cl-tests.el
+++ b/test/lisp/obsolete/cl-tests.el
@@ -21,7 +21,8 @@
21 21
22;;; Code: 22;;; Code:
23 23
24(require 'cl) 24(with-no-warnings
25 (require 'cl))
25(require 'ert) 26(require 'ert)
26 27
27 28
diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el
index 6b3e63653be..bc77443ff4f 100644
--- a/test/lisp/progmodes/python-tests.el
+++ b/test/lisp/progmodes/python-tests.el
@@ -339,7 +339,7 @@ def func(arg):
339 # I don't do much 339 # I don't do much
340 return arg 340 return arg
341 # This comment is badly indented because the user forced so. 341 # This comment is badly indented because the user forced so.
342 # At this line python.el wont dedent, user is always right. 342 # At this line python.el won't dedent, user is always right.
343 343
344comment_wins_over_ender = True 344comment_wins_over_ender = True
345 345
@@ -358,7 +358,7 @@ comment_wins_over_ender = True
358 ;; The return keyword do make indentation lose a level... 358 ;; The return keyword do make indentation lose a level...
359 (should (= (python-indent-calculate-indentation) 0)) 359 (should (= (python-indent-calculate-indentation) 0))
360 ;; ...but the current indentation was forced by the user. 360 ;; ...but the current indentation was forced by the user.
361 (python-tests-look-at "# At this line python.el wont dedent") 361 (python-tests-look-at "# At this line python.el won't dedent")
362 (should (eq (car (python-indent-context)) :after-comment)) 362 (should (eq (car (python-indent-context)) :after-comment))
363 (should (= (python-indent-calculate-indentation) 4)) 363 (should (= (python-indent-calculate-indentation) 4))
364 ;; Should behave the same for blank lines: potentially a comment. 364 ;; Should behave the same for blank lines: potentially a comment.
diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el
index 457de91c149..d4b316811e6 100644
--- a/test/lisp/simple-tests.el
+++ b/test/lisp/simple-tests.el
@@ -44,7 +44,7 @@
44;;; `count-words' 44;;; `count-words'
45(ert-deftest simple-test-count-words-bug-41761 () 45(ert-deftest simple-test-count-words-bug-41761 ()
46 (with-temp-buffer 46 (with-temp-buffer
47 (dotimes (i 10) (insert (propertize "test " 'field (cons nil nil)))) 47 (dotimes (_i 10) (insert (propertize "test " 'field (cons nil nil))))
48 (should (= (count-words (point-min) (point-max)) 10)))) 48 (should (= (count-words (point-min) (point-max)) 10))))
49 49
50 50
diff --git a/test/lisp/vc/vc-bzr-tests.el b/test/lisp/vc/vc-bzr-tests.el
index b68a6945129..408d6e8e23d 100644
--- a/test/lisp/vc/vc-bzr-tests.el
+++ b/test/lisp/vc/vc-bzr-tests.el
@@ -131,7 +131,6 @@
131 (make-directory bzrdir) 131 (make-directory bzrdir)
132 (expand-file-name "foo.el" bzrdir))) 132 (expand-file-name "foo.el" bzrdir)))
133 (default-directory (file-name-as-directory bzrdir)) 133 (default-directory (file-name-as-directory bzrdir))
134 (generated-autoload-file (expand-file-name "loaddefs.el" bzrdir))
135 (process-environment (cons (format "HOME=%s" homedir) 134 (process-environment (cons (format "HOME=%s" homedir)
136 process-environment))) 135 process-environment)))
137 (unwind-protect 136 (unwind-protect
@@ -148,7 +147,9 @@
148 ;; causes bzr status to fail. This simulates a broken bzr 147 ;; causes bzr status to fail. This simulates a broken bzr
149 ;; installation. 148 ;; installation.
150 (delete-file ".bzr/checkout/dirstate") 149 (delete-file ".bzr/checkout/dirstate")
151 (should (progn (update-directory-autoloads default-directory) 150 (should (progn (make-directory-autoloads
151 default-directory
152 (expand-file-name "loaddefs.el" bzrdir))
152 t))) 153 t)))
153 (delete-directory homedir t)))) 154 (delete-directory homedir t))))
154 155
diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el
index b89e8c876e2..f876967bf98 100644
--- a/test/lisp/wdired-tests.el
+++ b/test/lisp/wdired-tests.el
@@ -178,6 +178,22 @@ wdired-get-filename before and after editing."
178 (server-force-delete) 178 (server-force-delete)
179 (delete-directory test-dir t)))) 179 (delete-directory test-dir t))))
180 180
181(ert-deftest wdired-test-bug39280 ()
182 "Test for https://debbugs.gnu.org/39280."
183 (let* ((test-dir (make-temp-file "test-dir" 'dir))
184 (fname "foo")
185 (full-fname (expand-file-name fname test-dir)))
186 (make-empty-file full-fname)
187 (let ((buf (find-file-noselect test-dir)))
188 (unwind-protect
189 (with-current-buffer buf
190 (dired-toggle-read-only)
191 (dolist (old '(t nil))
192 (should (equal fname (wdired-get-filename 'nodir old)))
193 (should (equal full-fname (wdired-get-filename nil old))))
194 (wdired-finish-edit))
195 (if buf (kill-buffer buf))
196 (delete-directory test-dir t)))))
181 197
182(provide 'wdired-tests) 198(provide 'wdired-tests)
183;;; wdired-tests.el ends here 199;;; wdired-tests.el ends here