diff options
| author | Andrea Corallo <akrl@sdf.org> | 2020-10-04 19:45:05 +0200 |
|---|---|---|
| committer | Andrea Corallo <akrl@sdf.org> | 2020-10-04 19:45:05 +0200 |
| commit | 44ef24342fd8a2ac876212124ebf38673acda35a (patch) | |
| tree | 793dc4ba4197559b4bc65339d713c0807a7b2ca9 /test | |
| parent | afb765ab3cab7b6582d0def543b23603cd076445 (diff) | |
| parent | d8665e6d3473403c90a0831e83439a013d0012d3 (diff) | |
Merge remote-tracking branch 'savannah/master' into HEAD
Diffstat (limited to 'test')
| -rw-r--r-- | test/data/syntax-comments.txt | 68 | ||||
| -rw-r--r-- | test/lisp/calc/calc-tests.el | 116 | ||||
| -rw-r--r-- | test/lisp/electric-tests.el | 3 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/backtrace-tests.el | 2 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/edebug-tests.el | 2 | ||||
| -rw-r--r-- | test/lisp/files-tests.el | 4 | ||||
| -rw-r--r-- | test/lisp/gnus/gnus-util-tests.el | 13 | ||||
| -rw-r--r-- | test/lisp/gnus/mml-sec-tests.el | 32 | ||||
| -rw-r--r-- | test/lisp/mail/uudecode-tests.el | 4 | ||||
| -rw-r--r-- | test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml | 49 | ||||
| -rw-r--r-- | test/lisp/net/dbus-tests.el | 816 | ||||
| -rw-r--r-- | test/lisp/obsolete/cl-tests.el | 3 | ||||
| -rw-r--r-- | test/lisp/progmodes/python-tests.el | 4 | ||||
| -rw-r--r-- | test/lisp/simple-tests.el | 2 | ||||
| -rw-r--r-- | test/lisp/vc/vc-bzr-tests.el | 5 | ||||
| -rw-r--r-- | test/lisp/wdired-tests.el | 16 | ||||
| -rw-r--r-- | test/manual/cedet/tests/testnsp.cpp | 2 | ||||
| -rw-r--r-- | test/src/coding-tests.el | 2 | ||||
| -rw-r--r-- | test/src/indent-tests.el | 59 | ||||
| -rw-r--r-- | test/src/regex-resources/BOOST.tests | 4 | ||||
| -rw-r--r-- | test/src/syntax-tests.el | 349 |
21 files changed, 1475 insertions, 80 deletions
diff --git a/test/data/syntax-comments.txt b/test/data/syntax-comments.txt new file mode 100644 index 00000000000..6f595e4d8dc --- /dev/null +++ b/test/data/syntax-comments.txt @@ -0,0 +1,68 @@ +/* This file is a test file for tests of the comment handling in src/syntax.c. + This includes the testing of comments which figure in parse-partial-sexp + and scan-lists. */ + +/* Straight C comments */ +1/* comment */1 +2/**/2 +3// comment +3 +4// +4 +5/*/5 +6*/6 +7/* \*/7 +8*/8 +9/* \\*/9 +10*/10 +11// \ +12 +11 +13// \\ +14 +13 +15/* /*/15 + +/* C Comments within lists */ +59}59 +50{ /*70 comment */71 }50 +51{ /**/ }51 +52{ //72 comment +73}52 +53{ // +}53 +54{ //74 \ +}54 +55{/* */}55 +56{ /*76 \*/ }56 +57*/77 +58}58 +60{ /*78 \\*/79}60 + + +/* Straight Pascal comments (not nested) */ +20}20 +21{ Comment }21 +22{}22 +23{ +}23 +24{ +25{25 +}24 +26{ \}26 + + +/* Straight Lisp comments (not nested) */ +30 +30 +31; Comment +31 +32;;;;;;;;; +32 +33; \ +33 + +Local Variables: +mode: fundamental +eval: (set-syntax-table (make-syntax-table)) +End: 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." (calcFunc-choose '(frac -15 2) 3)) (calc-tests--choose -7.5 3)))) +(ert-deftest calc-business-days () + (cl-flet ((m (s) (math-parse-date s)) + (b+ (a b) (calcFunc-badd a b)) + (b- (a b) (calcFunc-bsub a b))) + ;; Sanity check. + (should (equal (m "2020-09-07") '(date 737675))) + + ;; Test with standard business days (Mon-Fri): + (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-08"))) ; Mon->Tue + (should (equal (b+ (m "2020-09-08") 1) (m "2020-09-09"))) ; Tue->Wed + (should (equal (b+ (m "2020-09-09") 1) (m "2020-09-10"))) ; Wed->Thu + (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-11"))) ; Thu->Fri + (should (equal (b+ (m "2020-09-11") 1) (m "2020-09-14"))) ; Fri->Mon + + (should (equal (b+ (m "2020-09-07") 4) (m "2020-09-11"))) ; Mon->Fri + (should (equal (b+ (m "2020-09-07") 6) (m "2020-09-15"))) ; Mon->Tue + + (should (equal (b+ (m "2020-09-12") 1) (m "2020-09-14"))) ; Sat->Mon + (should (equal (b+ (m "2020-09-13") 1) (m "2020-09-14"))) ; Sun->Mon + + (should (equal (b- (m "2020-09-11") 1) (m "2020-09-10"))) ; Fri->Thu + (should (equal (b- (m "2020-09-10") 1) (m "2020-09-09"))) ; Thu->Wed + (should (equal (b- (m "2020-09-09") 1) (m "2020-09-08"))) ; Wed->Tue + (should (equal (b- (m "2020-09-08") 1) (m "2020-09-07"))) ; Tue->Mon + (should (equal (b- (m "2020-09-07") 1) (m "2020-09-04"))) ; Mon->Fri + + (should (equal (b- (m "2020-09-11") 4) (m "2020-09-07"))) ; Fri->Mon + (should (equal (b- (m "2020-09-15") 6) (m "2020-09-07"))) ; Tue->Mon + + (should (equal (b- (m "2020-09-12") 1) (m "2020-09-11"))) ; Sat->Fri + (should (equal (b- (m "2020-09-13") 1) (m "2020-09-11"))) ; Sun->Fri + + ;; Stepping fractional days + (should (equal (b+ (m "2020-09-08 21:00") '(frac 1 2)) + (m "2020-09-09 09:00"))) + (should (equal (b+ (m "2020-09-11 21:00") '(frac 1 2)) + (m "2020-09-14 09:00"))) + (should (equal (b- (m "2020-09-08 21:00") '(frac 1 2)) + (m "2020-09-08 09:00"))) + (should (equal (b- (m "2020-09-14 06:00") '(frac 1 2)) + (m "2020-09-11 18:00"))) + + ;; Test with a couple of extra days off: + (let ((var-Holidays (list 'vec + '(var sat var-sat) '(var sun var-sun) + (m "2020-09-09") (m "2020-09-11")))) + + (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-08"))) ; Mon->Tue + (should (equal (b+ (m "2020-09-08") 1) (m "2020-09-10"))) ; Tue->Thu + (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-14"))) ; Thu->Mon + (should (equal (b+ (m "2020-09-14") 1) (m "2020-09-15"))) ; Mon->Tue + (should (equal (b+ (m "2020-09-15") 1) (m "2020-09-16"))) ; Tue->Wed + + (should (equal (b- (m "2020-09-16") 1) (m "2020-09-15"))) ; Wed->Tue + (should (equal (b- (m "2020-09-15") 1) (m "2020-09-14"))) ; Tue->Mon + (should (equal (b- (m "2020-09-14") 1) (m "2020-09-10"))) ; Mon->Thu + (should (equal (b- (m "2020-09-10") 1) (m "2020-09-08"))) ; Thu->Tue + (should (equal (b- (m "2020-09-08") 1) (m "2020-09-07"))) ; Tue->Mon + ) + + ;; Test with odd non-business weekdays (Tue, Wed, Sat): + (let ((var-Holidays '(vec (var tue var-tue) + (var wed var-wed) + (var sat var-sat)))) + (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-10"))) ; Mon->Thu + (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-11"))) ; Thu->Fri + (should (equal (b+ (m "2020-09-11") 1) (m "2020-09-13"))) ; Fri->Sun + (should (equal (b+ (m "2020-09-13") 1) (m "2020-09-14"))) ; Sun->Mon + + (should (equal (b- (m "2020-09-14") 1) (m "2020-09-13"))) ; Mon->Sun + (should (equal (b- (m "2020-09-13") 1) (m "2020-09-11"))) ; Sun->Fri + (should (equal (b- (m "2020-09-11") 1) (m "2020-09-10"))) ; Fri->Thu + (should (equal (b- (m "2020-09-10") 1) (m "2020-09-07"))) ; Thu->Mon + ) + )) + +(ert-deftest calc-unix-date () + (let* ((d-1970-01-01 (math-parse-date "1970-01-01")) + (d-2020-09-07 (math-parse-date "2020-09-07")) + (d-1991-01-09-0600 (math-parse-date "1991-01-09 06:00"))) + ;; calcFunc-unixtime (command "t U") converts a date value to Unix time, + ;; and a number to a date. + (should (equal d-1970-01-01 '(date 719163))) + (should (equal (calcFunc-unixtime d-1970-01-01 0) 0)) + (should (equal (calc-tests--calc-to-number (cadr (calcFunc-unixtime 0 0))) + (cadr d-1970-01-01))) + (should (equal (calcFunc-unixtime d-2020-09-07 0) + (* (- (cadr d-2020-09-07) + (cadr d-1970-01-01)) + 86400))) + (should (equal (calcFunc-unixtime d-1991-01-09-0600 0) + 663400800)) + (should (equal (calc-tests--calc-to-number + (cadr (calcFunc-unixtime 663400800 0))) + 726841.25)) + + (let ((calc-date-format '(U))) + ;; Test parsing Unix time. + (should (equal (calc-tests--calc-to-number + (cadr (math-parse-date "0"))) + 719163)) + (should (equal (calc-tests--calc-to-number + (cadr (math-parse-date "469324800"))) + (+ 719163 (/ 469324800 86400)))) + (should (equal (calc-tests--calc-to-number + (cadr (math-parse-date "663400800"))) + 726841.25)) + + ;; Test formatting Unix time. + (should (equal (math-format-date d-1970-01-01) "0")) + (should (equal (math-format-date d-2020-09-07) + (number-to-string (* (- (cadr d-2020-09-07) + (cadr d-1970-01-01)) + 86400)))) + (should (equal (math-format-date d-1991-01-09-0600) "663400800"))))) + (provide 'calc-tests) ;;; calc-tests.el ends here 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\"\"" (should (equal (buffer-string) "int main () {\n \n}")))) (ert-deftest electric-layout-control-reindentation () - "Same as `e-l-int-main-kernel-style', but checking Bug#35254." + "Same as `emacs-lisp-int-main-kernel-style', but checking +Bug#35254." (ert-with-test-buffer () (plainer-c-mode) (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 @@ (backtrace-mode) (setq backtrace-frames (backtrace-get-frames)) (let ((this-index)) - ;; Discard all past `backtrace-tests-make-backtrace'. + ;; Discard all past `backtrace-tests--make-backtrace'. (dotimes (index (length backtrace-frames)) (when (eq (backtrace-frame-fun (nth index backtrace-frames)) '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." (defvar edebug-tests-thunks nil "List containing thunks to run after each command in a keyboard macro.") (defvar edebug-tests-kbd-macro-index nil - "Index into `edebug-tests-run-unpacked-kbd-macro's current keyboard macro.") + "Index into `edebug-tests-run-kbd-macro's current keyboard macro.") (defun edebug-tests-run-macro (kbdmac &rest thunks) "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." (let ((linkname (expand-file-name "link" nospecial-dir))) (should-error (make-symbolic-link tmpfile linkname)))))))) -;; See `files-tests--file-name-non-special--subprocess'. +;; See `files-tests-file-name-non-special--subprocess'. ;; (ert-deftest files-tests-file-name-non-special-process-file ()) (ert-deftest files-tests-file-name-non-special-rename-file () @@ -1104,7 +1104,7 @@ unquoted file names." (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) (should (equal (vc-registered nospecial) (vc-registered tmpfile))))) -;; See test `files-tests--file-name-non-special--buffers'. +;; See test `files-tests-file-name-non-special--buffers'. ;; (ert-deftest files-tests-file-name-non-special-verify-visited-file-modtime ()) (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 @@ (should (equal "Zg==" (gnus-base64-repad "Zg"))) (should (equal "Zg==" (gnus-base64-repad "Zg===="))) - (should (equal (gnus-base64-repad " ") "")) - (should (equal (gnus-base64-repad "Zg== ") "Zg==")) + (should-error (gnus-base64-repad " ") + :type 'error) + (should-error (gnus-base64-repad "Zg== ") + :type 'error) (should-error (gnus-base64-repad "Z?\x00g==") :type 'error) ;; line-length @@ -162,9 +164,10 @@ (should-error (gnus-base64-repad "Zm9v\r\nYmFy" t) :type 'error) (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9vYmFy" t))) - (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy" nil))) - (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy\n" nil))) - (should (equal (gnus-base64-repad "Zm9v\r\n YmFy\r\n" nil) "Zm9vYmFy")) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy"))) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy\n"))) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\n YmFy\r\n"))) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v \r\n\tYmFy"))) (should-error (gnus-base64-repad "Zm9v\r\nYmFy" nil 3) :type 'error)) 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." (condition-case error (let ((epg-gpg-home-directory (expand-file-name "test/data/mml-sec" source-directory)) - (mml-secure-allow-signing-with-unknown-recipient t) (mml-smime-use 'epg) ;; Create debug output in empty epg-debug-buffer. (epg-debug t) @@ -762,37 +761,6 @@ Use sign-with-sender and encrypt-to-self." method "no-exp@example.org" "sub@example.org" 2 nil)) ))))) -(ert-deftest mml-secure-sign-verify-2 () - "Sign message without sender; then verify and test for expected result." - (skip-unless (test-conf)) - (mml-secure-test-key-fixture - (lambda () - (dolist (method (sign-standards) nil) - (let ((mml-secure-openpgp-sign-with-sender nil) - (mml-secure-smime-sign-with-sender nil)) - ;; A single signing key for sender sub@example.org is customized - ;; in the fixture, but not used here. - ;; By default, gpg uses the first secret key in the keyring, which - ;; is 02372A42CA6D40FB (OpenPGP) or - ;; 0E58229B80EE33959FF718FEEF25402B479DC6E2 (S/MIME) here. - (mml-secure-test-en-decrypt - method "uid1@example.org" "sub@example.org" 0 nil) - - ;; From sub@example.org, sign with specified key: - (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB")) - (mml-secure-smime-signers - '("D06AA118653CC38E9D0CAF56ED7A2135E1582177"))) - (mml-secure-test-en-decrypt - method "no-exp@example.org" "sub@example.org" 1 nil)) - - ;; From sub@example.org, sign with different specified key: - (let ((mml-secure-openpgp-signers '("C3999CF1268DBEA2")) - (mml-secure-smime-signers - '("0E58229B80EE33959FF718FEEF25402B479DC6E2"))) - (mml-secure-test-en-decrypt - method "no-exp@example.org" "sub@example.org" 1 nil)) - ))))) - (ert-deftest mml-secure-sign-verify-3 () "Try to sign message with expired OpenPGP subkey, which raises an error. With 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 @@ (uudecode-tests-read-file (expand-file-name "uuencoded.txt" uudecode-tests-data-dir)) "Uuencoded data for bookmark-tests.el -Same as `bookmark-tests-decoded-str' but uuencoded.") +Same as `uudecode-tests-decoded-str' but uuencoded.") (defvar uudecode-tests-decoded-str (uudecode-tests-read-file (expand-file-name "uudecoded.txt" uudecode-tests-data-dir)) "Plain text data for bookmark-tests.el -Same as `bookmark-tests-encoded-str' but plain text.") +Same as `uudecode-tests-encoded-str' but plain text.") (ert-deftest uudecode-tests-decode-region-internal () ;; 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 @@ +<?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 74c0dddcf52..7ebef5d2609 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -46,6 +46,13 @@ (defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface" "Test interface.") +(defconst dbus--tests-dir + (file-truename + (expand-file-name "dbus-resources" + (file-name-directory (or load-file-name + buffer-file-name)))) + "Directory containing introspection test data file.") + (defun dbus--test-availability (bus) "Test availability of D-Bus BUS." (should (dbus-list-names bus)) @@ -309,7 +316,7 @@ (dbus-check-arguments :session dbus--test-service :double "string") :type 'wrong-type-argument) - ;; `:unix-fd'. UNIX file descriptors are transfered out-of-band. + ;; `: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 @@ -359,11 +366,11 @@ (should (dbus-check-arguments :session dbus--test-service '(:variant (:array "string")))) - ;; No or more than one element. - ;; FIXME. - ;; (should-error - ;; (dbus-check-arguments :session dbus--test-service '(:variant)) - ;; :type 'wrong-type-argument) + ;; 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 @@ -375,20 +382,22 @@ (should (dbus-check-arguments :session dbus--test-service - '(:array (:dict-entry :string "string" :boolean t)))) + '(:array (:dict-entry :string "string" :boolean nil)))) ;; This is an alternative syntax. FIXME: Shall this be supported? (should (dbus-check-arguments :session dbus--test-service '(:array :dict-entry (:string "string" :boolean t)))) - ;; FIXME: Must be errors. - ;; (should - ;; (dbus-check-arguments - ;; :session dbus--test-service '(:array (:dict-entry)))) - ;; (should - ;; (dbus-check-arguments - ;; :session dbus--test-service '(:array (:dict-entry :string "string")))) - ;; Not two elements. + ;; 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 @@ -405,25 +414,27 @@ (dbus-check-arguments :session dbus--test-service '(:dict-entry :string "string" :boolean t)) :type 'wrong-type-argument) - ;; FIXME:! This doesn't look right. - ;; Different dict entry types can be part of an array ??? - (should - (dbus-check-arguments - :session dbus--test-service - '(:array - (:dict-entry :string "string1" :boolean t) - (:dict-entry :string "string2" :object-path "/object/path")))) + ;; Different dict entry types are not ched. FIXME: Add check. + ;; (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. - ;; Empty struct. FIXME: Is this right? - ;; (should (dbus-check-arguments :session dbus--test-service '(: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)))))) + (: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)) (defun dbus--test-register-service (bus) "Check service registration at BUS." @@ -625,6 +636,63 @@ This includes initialization and closing the bus." ;; 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'.") @@ -1069,6 +1137,702 @@ This includes initialization and closing the bus." ;; 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 + (expand-file-name "org.gnu.Emacs.TestDBus.xml" dbus--tests-dir)) + (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))) + (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." (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 @@ ;;; Code: -(require 'cl) +(with-no-warnings + (require 'cl)) (require 'ert) 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): # I don't do much return arg # This comment is badly indented because the user forced so. - # At this line python.el wont dedent, user is always right. + # At this line python.el won't dedent, user is always right. comment_wins_over_ender = True @@ -358,7 +358,7 @@ comment_wins_over_ender = True ;; The return keyword do make indentation lose a level... (should (= (python-indent-calculate-indentation) 0)) ;; ...but the current indentation was forced by the user. - (python-tests-look-at "# At this line python.el wont dedent") + (python-tests-look-at "# At this line python.el won't dedent") (should (eq (car (python-indent-context)) :after-comment)) (should (= (python-indent-calculate-indentation) 4)) ;; 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 @@ ;;; `count-words' (ert-deftest simple-test-count-words-bug-41761 () (with-temp-buffer - (dotimes (i 10) (insert (propertize "test " 'field (cons nil nil)))) + (dotimes (_i 10) (insert (propertize "test " 'field (cons nil nil)))) (should (= (count-words (point-min) (point-max)) 10)))) 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 @@ (make-directory bzrdir) (expand-file-name "foo.el" bzrdir))) (default-directory (file-name-as-directory bzrdir)) - (generated-autoload-file (expand-file-name "loaddefs.el" bzrdir)) (process-environment (cons (format "HOME=%s" homedir) process-environment))) (unwind-protect @@ -148,7 +147,9 @@ ;; causes bzr status to fail. This simulates a broken bzr ;; installation. (delete-file ".bzr/checkout/dirstate") - (should (progn (update-directory-autoloads default-directory) + (should (progn (make-directory-autoloads + default-directory + (expand-file-name "loaddefs.el" bzrdir)) t))) (delete-directory homedir t)))) 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." (server-force-delete) (delete-directory test-dir t)))) +(ert-deftest wdired-test-bug39280 () + "Test for https://debbugs.gnu.org/39280." + (let* ((test-dir (make-temp-file "test-dir" 'dir)) + (fname "foo") + (full-fname (expand-file-name fname test-dir))) + (make-empty-file full-fname) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (dired-toggle-read-only) + (dolist (old '(t nil)) + (should (equal fname (wdired-get-filename 'nodir old))) + (should (equal full-fname (wdired-get-filename nil old)))) + (wdired-finish-edit)) + (if buf (kill-buffer buf)) + (delete-directory test-dir t))))) (provide 'wdired-tests) ;;; wdired-tests.el ends here diff --git a/test/manual/cedet/tests/testnsp.cpp b/test/manual/cedet/tests/testnsp.cpp index fce707bf20b..b72a44c8ca8 100644 --- a/test/manual/cedet/tests/testnsp.cpp +++ b/test/manual/cedet/tests/testnsp.cpp @@ -93,7 +93,7 @@ void foo(void) { ; // #4# ( "Mumble" "get" ) } -// What happens if a type your looking for is scoped withing a type, +// What happens if a type your looking for is scoped within a type, // but you are one level into the completion so the originating scope // excludes the type of the variable you are completing through? // Thanks Martin Stein for this nice example. diff --git a/test/src/coding-tests.el b/test/src/coding-tests.el index c438ae22ce3..82883a045c8 100644 --- a/test/src/coding-tests.el +++ b/test/src/coding-tests.el @@ -143,7 +143,7 @@ ;; Optional 5th arg TRANSLATOR is a function to translate the original ;; file contents to match with the expected result of decoding. For ;; instance, when a file of dos eol-type is read by unix eol-type, -;; `decode-test-lf-to-crlf' must be specified. +;; `coding-tests-lf-to-crlf' must be specified. (defun coding-tests (content-type write-coding read-coding detected-coding &optional translator) diff --git a/test/src/indent-tests.el b/test/src/indent-tests.el new file mode 100644 index 00000000000..7d1a6ce6dc3 --- /dev/null +++ b/test/src/indent-tests.el @@ -0,0 +1,59 @@ +;;; indent-tests.el --- tests for src/indent.c -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; 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. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `https://www.gnu.org/licenses/'. + +;;; Commentary: + +;;; Code: + +(ert-deftest indent-tests-move-to-column-invis-1tab () + "Test `move-to-column' when a TAB is followed by invisible text." + (should + (string= + (with-temp-buffer + (insert "\tLine starting with INVISIBLE text after TAB\n") + (add-text-properties 2 21 '(invisible t)) + (goto-char (point-min)) + (move-to-column 7 t) + (buffer-substring-no-properties 1 8)) + " "))) + +(ert-deftest indent-tests-move-to-column-invis-2tabs () + "Test `move-to-column' when 2 TABs are followed by invisible text." + (should + (string= + (with-temp-buffer + (insert "\t\tLine starting with INVISIBLE text after TAB\n") + (add-text-properties 3 22 '(invisible t)) + (goto-char (point-min)) + (move-to-column 12 t) + (buffer-substring-no-properties 1 11)) + "\t \tLine"))) + +(ert-deftest indent-tests-move-to-column-invis-between-tabs () + "Test `move-to-column' when 2 TABs are mixed with invisible text." + (should + (string= + (with-temp-buffer + (insert "\txxx\tLine starting with INVISIBLE text after TAB\n") + (add-text-properties 6 25 '(invisible t)) + (add-text-properties 2 5 '(invisible t)) + (goto-char (point-min)) + (move-to-column 12 t) + (buffer-substring-no-properties 1 14)) + "\txxx \tLine"))) diff --git a/test/src/regex-resources/BOOST.tests b/test/src/regex-resources/BOOST.tests index 98fd3b6abf3..756fa00486b 100644 --- a/test/src/regex-resources/BOOST.tests +++ b/test/src/regex-resources/BOOST.tests @@ -93,7 +93,7 @@ aa\) ! . \0 0 1 ; -; now move on to the repetion ops, +; now move on to the repetition ops, ; starting with operator * - match_default normal REG_EXTENDED a* b 0 0 @@ -275,7 +275,7 @@ a(b*)c\1d abbcbbbd -1 -1 ^(.)\1 abc -1 -1 a([bc])\1d abcdabbd 4 8 5 6 ; strictly speaking this is at best ambiguous, at worst wrong, this is what most -; re implimentations will match though. +; re implementations will match though. a(([bc])\2)*d abbccd 0 6 3 5 3 4 a(([bc])\2)*d abbcbd -1 -1 diff --git a/test/src/syntax-tests.el b/test/src/syntax-tests.el index 65c56b3b29d..56e03380579 100644 --- a/test/src/syntax-tests.el +++ b/test/src/syntax-tests.el @@ -82,4 +82,353 @@ also has open paren syntax (see Bug#24870)." (should (equal (parse-partial-sexp pointC pointX nil nil ppsC) ppsX))))) + +;;; Commentary: +;; The next bit tests the handling of comments in syntax.c, in +;; particular the functions `forward-comment' and `scan-lists' and +;; `parse-partial-sexp' (in so far as they relate to comments). + +;; It is intended to enhance this bit to test nested comments +;; (2020-10-01). + +;; This bit uses the data file test/data/syntax-comments.txt. + +(defun syntax-comments-point (n forw) + "Return the buffer offset corresponding to the \"label\" N. +N is a decimal number which appears in the data file, usually +twice, as \"labels\". It can also be a negative number or zero. +FORW is t when we're using the label at BOL, nil for the one at EOL. + +If the label N doesn't exist in the current buffer, an exception +is thrown. + +When FORW is t and N positive, we return the position after the +first occurrence of label N at BOL in the data file. With FORW +nil, we return the position before the last occurrence of the +label at EOL in the data file. + +When N is negative, we return instead the position of the end of +line that the -N label is on. When it is zero, we return POINT." + (if (zerop n) + (point) + (let ((str (format "%d" (abs n)))) + (save-excursion + (if forw + (progn + (goto-char (point-min)) + (re-search-forward + (concat "^\\(" str "\\)\\([^0-9\n]\\|$\\)")) + (if (< n 0) + (progn (end-of-line) (point)) + (match-end 1))) + (goto-char (point-max)) + (re-search-backward + (concat "\\(^\\|[^0-9]\\)\\(" str "\\)$")) + (if (< n 0) + (progn (end-of-line) (point)) + (match-beginning 2))))))) + +(defun syntax-comments-midpoint (n) + "Return the buffer offset corresponding to the \"label\" N. +N is a positive decimal number which should appear in the buffer +exactly once. The label need not be at the beginning or end of a +line. + +The return value is the position just before the label. + +If the label N doesn't exist in the current buffer, an exception +is thrown." + (let ((str (format "%d" n))) + (save-excursion + (goto-char (point-min)) + (re-search-forward + (concat "\\(^\\|[^0-9]\\)\\(" str "\\)\\([^0-9\n]\\|$\\)")) + (match-beginning 2)))) + +(eval-and-compile + (defvar syntax-comments-section)) + +(defmacro syntax-comments (-type- -dir- res start &optional stop) + "Create an ERT test to test (forward-comment 1/-1). +The test uses a fixed name data file, which it visits. It calls +entry and exit functions to set up and tear down syntax entries +for comment characters. The test is given a name based on the +global variable `syntax-comments-section', the direction of +movement and the value of START. + +-TYPE- (unquoted) is a symbol from whose name the entry and exit +function names are derived by appending \"-in\" and \"-out\". + +-DIR- (unquoted) is `forward' or `backward', the direction +`forward-comment' is attempted. + +RES, t or nil, is the expected result from `forward-comment'. + +START and STOP are decimal numbers corresponding to labels in the +data file marking the start and expected stop positions. See +`syntax-comments-point' for a precise specification. If STOP is +missing or nil, the value of START is assumed for it." + (declare (debug t)) + (let ((forw + (cond + ((eq -dir- 'forward) t) + ((eq -dir- 'backward) nil) + (t (error "Invalid -dir- argument \"%s\" to `syntax-comments'" -dir-)))) + (start-str (format "%d" (abs start))) + (type -type-)) + `(ert-deftest ,(intern (concat "syntax-comments-" + syntax-comments-section + (if forw "-f" "-b") start-str)) + () + (with-current-buffer + (find-file + ,(expand-file-name "data/syntax-comments.txt" + (getenv "EMACS_TEST_DIRECTORY"))) + (,(intern (concat (symbol-name type) "-in"))) + (goto-char (syntax-comments-point ,start ,forw)) + (let ((stop (syntax-comments-point ,(or stop start) ,(not forw)))) + (should (eq (forward-comment ,(if forw 1 -1)) ,res)) + (should (eq (point) stop))) + (,(intern (concat (symbol-name type) "-out"))))))) + +(defmacro syntax-br-comments (-type- -dir- res -start- &optional stop) + "Create an ERT test to test (scan-lists <position> 1/-1 0). +This is to test the interface between scan-lists and the internal +comment routines in syntax.c. + +The test uses a fixed name data file, which it visits. It calls +entry and exit functions to set up and tear down syntax entries +for comment and paren characters. The test is given a name based +on the global variable `syntax-comments-section', the direction +of movement and the value of -START-. + +-TYPE- (unquoted) is a symbol from whose name the entry and exit +function names are derived by appending \"-in\" and \"-out\". + +-DIR- (unquoted) is `forward' or `backward', the direction +`scan-lists' is attempted. + +RES is t if `scan-lists' is expected to return, nil if it is +expected to raise a `scan-error' exception. + +-START- and STOP are decimal numbers corresponding to labels in the +data file marking the start and expected stop positions. See +`syntax-comments-point' for a precise specification. If STOP is +missing or nil, the value of -START- is assumed for it." + (declare (debug t)) + (let* ((forw + (cond + ((eq -dir- 'forward) t) + ((eq -dir- 'backward) nil) + (t (error "Invalid -dir- argument \"%s\" to `syntax-comments'" -dir-)))) + (start -start-) + (start-str (format "%d" (abs start))) + (type -type-)) + `(ert-deftest ,(intern (concat "syntax-br-comments-" + syntax-comments-section + (if forw "-f" "-b") start-str)) + () + (with-current-buffer + (find-file + ,(expand-file-name "data/syntax-comments.txt" + (getenv "EMACS_TEST_DIRECTORY"))) + (,(intern (concat (symbol-name type) "-in"))) + (let ((start-pos (syntax-comments-point ,start ,forw)) + ,@(if res + `((stop-pos (syntax-comments-point + ,(or stop start) ,(not forw)))))) + ,(if res + `(should + (eq (scan-lists start-pos ,(if forw 1 -1) 0) + stop-pos)) + `(should-error (scan-lists start-pos ,(if forw 1 -1) 0) + :type 'scan-error))) + (,(intern (concat (symbol-name type) "-out"))))))) + +(defmacro syntax-pps-comments (-type- -start- open close &optional -stop-) + "Create an ERT test to test `parse-partial-sexp' with comments. +This is to test the interface between `parse-partial-sexp' and +the internal comment routines in syntax.c. + +The test uses a fixed name data file, which it visits. It calls +entry and exit functions to set up and tear down syntax entries +for comment and paren characters. The test is given a name based +on the global variable `syntax-comments-section', and the value +of -START-. + +The generated test calls `parse-partial-sexp' three times, the +first two with COMMENTSTOP set to `syntax-table' so as to stop +after the start and end of the comment. The third call is +expected to stop at the brace/paren matching the one where the +test started. + +-TYPE- (unquoted) is a symbol from whose name the entry and exit +function names are derived by appending \"-in\" and \"-out\". + +-START- and -STOP- are decimal numbers corresponding to labels in +the data file marking the start and expected stop positions. See +`syntax-comments-point' for a precise specification. If -STOP- +is missing or nil, the value of -START- is assumed for it. + +OPEN and CLOSE are decimal numbers corresponding to labels in the +data file marking just after the comment opener and closer where +the `parse-partial-sexp's are expected to stop. See +`syntax-comments-midpoint' for a precise specification." + (declare (debug t)) + (let* ((type -type-) + (start -start-) + (start-str (format "%d" start)) + (stop (or -stop- start))) + `(ert-deftest ,(intern (concat "syntax-pps-comments-" + syntax-comments-section + "-" start-str)) + () + (with-current-buffer + (find-file + ,(expand-file-name "data/syntax-comments.txt" + (getenv "EMACS_TEST_DIRECTORY"))) + (,(intern (concat (symbol-name type) "-in"))) + (let ((start-pos (syntax-comments-point ,start t)) + (open-pos (syntax-comments-midpoint ,open)) + (close-pos (syntax-comments-midpoint ,close)) + (stop-pos (syntax-comments-point ,stop nil)) + s) + (setq s (parse-partial-sexp + start-pos (point-max) 0 nil nil 'syntax-table)) + (should (eq (point) open-pos)) + (setq s (parse-partial-sexp + (point) (point-max) 0 nil s 'syntax-table)) + (should (eq (point) close-pos)) + (setq s (parse-partial-sexp (point) (point-max) 0 nil s)) + (should (eq (point) stop-pos))) + (,(intern (concat (symbol-name type) "-out"))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; "Pascal" style comments - single character delimiters, the closing +;; delimiter not being newline. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun {-in () + (setq parse-sexp-ignore-comments t) + (setq comment-end-can-be-escaped nil) + (modify-syntax-entry ?{ "<") + (modify-syntax-entry ?} ">")) +(defun {-out () + (modify-syntax-entry ?{ "(}") + (modify-syntax-entry ?} "){")) +(eval-and-compile + (setq syntax-comments-section "pascal")) + +(syntax-comments { forward nil 20 0) +(syntax-comments { backward nil 20 0) +(syntax-comments { forward t 21) +(syntax-comments { backward t 21) +(syntax-comments { forward t 22) +(syntax-comments { backward t 22) + +(syntax-comments { forward t 23) +(syntax-comments { backward t 23) +(syntax-comments { forward t 24) +(syntax-comments { backward t 24) +(syntax-comments { forward t 26) +(syntax-comments { backward t 26) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; "Lisp" style comments - single character opening delimiters on line +;; comments. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun \;-in () + (setq parse-sexp-ignore-comments t) + (setq comment-end-can-be-escaped nil) + (modify-syntax-entry ?\n ">") + (modify-syntax-entry ?\; "<")) +(defun \;-out () + (modify-syntax-entry ?\n " ") + (modify-syntax-entry ?\; ".")) +(eval-and-compile + (setq syntax-comments-section "lisp")) + +(syntax-comments \; backward nil 30 30) +(syntax-comments \; forward t 31) +(syntax-comments \; backward t 31) +(syntax-comments \; forward t 32) +(syntax-comments \; backward t 32) +(syntax-comments \; forward t 33) +(syntax-comments \; backward t 33) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Emacs 27 "C" style comments - `comment-end-can-be-escaped' is non-nil. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun /*-in () + (setq parse-sexp-ignore-comments t) + (setq comment-end-can-be-escaped t) + (modify-syntax-entry ?/ ". 124b") + (modify-syntax-entry ?* ". 23") + (modify-syntax-entry ?\n "> b")) +(defun /*-out () + (setq comment-end-can-be-escaped nil) + (modify-syntax-entry ?/ ".") + (modify-syntax-entry ?* ".") + (modify-syntax-entry ?\n " ")) +(eval-and-compile + (setq syntax-comments-section "c")) + +(syntax-comments /* forward t 1) +(syntax-comments /* backward t 1) +(syntax-comments /* forward t 2) +(syntax-comments /* backward t 2) +(syntax-comments /* forward t 3) +(syntax-comments /* backward t 3) + +(syntax-comments /* forward t 4) +(syntax-comments /* backward t 4) +(syntax-comments /* forward t 5 6) +(syntax-comments /* backward nil 5 0) +(syntax-comments /* forward nil 6 0) +(syntax-comments /* backward t 6 5) + +(syntax-comments /* forward t 7 8) +(syntax-comments /* backward nil 7 0) +(syntax-comments /* forward nil 8 0) +(syntax-comments /* backward t 8 7) +(syntax-comments /* forward t 9) +(syntax-comments /* backward t 9) + +(syntax-comments /* forward nil 10 0) +(syntax-comments /* backward nil 10 0) +(syntax-comments /* forward t 11) +(syntax-comments /* backward t 11) + +(syntax-comments /* forward t 13 14) +(syntax-comments /* backward nil 13 -14) +(syntax-comments /* forward t 15) +(syntax-comments /* backward t 15) + +;; Emacs 27 "C" style comments inside brace lists. +(syntax-br-comments /* forward t 50) +(syntax-br-comments /* backward t 50) +(syntax-br-comments /* forward t 51) +(syntax-br-comments /* backward t 51) +(syntax-br-comments /* forward t 52) +(syntax-br-comments /* backward t 52) + +(syntax-br-comments /* forward t 53) +(syntax-br-comments /* backward t 53) +(syntax-br-comments /* forward t 54 20) +(syntax-br-comments /* backward t 54) +(syntax-br-comments /* forward t 55) +(syntax-br-comments /* backward t 55) + +(syntax-br-comments /* forward t 56 58) +(syntax-br-comments /* backward t 58 56) +(syntax-br-comments /* backward nil 59) +(syntax-br-comments /* forward t 60) +(syntax-br-comments /* backward t 60) + +;; Emacs 27 "C" style comments parsed by `parse-partial-sexp'. +(syntax-pps-comments /* 50 70 71) +(syntax-pps-comments /* 52 72 73) +(syntax-pps-comments /* 54 74 55 20) +(syntax-pps-comments /* 56 76 77 58) +(syntax-pps-comments /* 60 78 79) + ;;; syntax-tests.el ends here |
