diff options
| author | Andrea Corallo | 2020-10-04 19:45:05 +0200 |
|---|---|---|
| committer | Andrea Corallo | 2020-10-04 19:45:05 +0200 |
| commit | 44ef24342fd8a2ac876212124ebf38673acda35a (patch) | |
| tree | 793dc4ba4197559b4bc65339d713c0807a7b2ca9 /test/lisp | |
| parent | afb765ab3cab7b6582d0def543b23603cd076445 (diff) | |
| parent | d8665e6d3473403c90a0831e83439a013d0012d3 (diff) | |
| download | emacs-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.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 |
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 |
| 891 | Bug#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. |
| 798 | With Ma Gnus v0.14 and earlier a signature would be created with a wrong key." | 766 | 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 @@ | |||
| 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 |
| 46 | Same as `bookmark-tests-decoded-str' but uuencoded.") | 46 | Same 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 |
| 51 | Same as `bookmark-tests-encoded-str' but plain text.") | 51 | Same 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. | ||
| 646 | Ensure that incoming method calls are handled when call to `dbus-call-method' | ||
| 647 | is 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. | ||
| 1142 | This is a helper function for the macro `dbus--test-property'. | ||
| 1143 | The 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'). | ||
| 1146 | The argument NAME is the property name. | ||
| 1147 | The argument VALUE is the value to register or set. | ||
| 1148 | The argument EXPECTED is a transformed VALUE representing the | ||
| 1149 | form `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. | ||
| 1190 | The argument VALUE-LIST is a sequence of pairs, where each pair | ||
| 1191 | represents a value form and an expected returned value form. The | ||
| 1192 | first pair in VALUES is used for `dbus-register-property'. | ||
| 1193 | Subsequent 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'. | ||
| 1543 | The argument IFACE-NAME is a string naming the interface to validate. | ||
| 1544 | The arguments EXPECTED-PROPERTIES, EXPECTED-METHODS, EXPECTED-SIGNALS, and | ||
| 1545 | EXPECTED-ANNOTATIONS represent the names of the interface's properties, | ||
| 1546 | methods, 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. | ||
| 1586 | Ensure each string in EXPECTED-ANNOTATIONS names an element of ANNOTATIONS. | ||
| 1587 | And 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 | |||
| 1602 | The argument INTERFACE is a string naming the interface owning PROPERTY-NAME. | ||
| 1603 | The argument PROPERTY-NAME is a string naming the property to validate. | ||
| 1604 | The arguments EXPECTED-ANNOTATIONS is a list of strings matching | ||
| 1605 | the annotation names defined for the method or signal. | ||
| 1606 | The 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'. | ||
| 1636 | The argument TREE is an sexp returned from either `dbus-introspect-get-method' | ||
| 1637 | or `dbus-introspect-get-signal' | ||
| 1638 | The arguments EXPECTED-ANNOTATIONS is a list of strings matching | ||
| 1639 | the annotation names defined for the method or signal. | ||
| 1640 | The argument EXPECTED-ARGS is a list of expected arguments for | ||
| 1641 | the 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 | |||
| 1658 | The argument INTERFACE is a string naming the interface owning SIGNAL-NAME. | ||
| 1659 | The argument SIGNAL-NAME is a string naming the signal to validate. | ||
| 1660 | The arguments EXPECTED-ANNOTATIONS is a list of strings matching | ||
| 1661 | the annotation names defined for the signal. | ||
| 1662 | The 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 | |||
| 1677 | The argument INTERFACE is a string naming the interface owning METHOD-NAME. | ||
| 1678 | The argument METHOD-NAME is a string naming the method to validate. | ||
| 1679 | The arguments EXPECTED-ANNOTATIONS is a list of strings matching | ||
| 1680 | the annotation names defined for the method. | ||
| 1681 | The 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 | ||
| 344 | comment_wins_over_ender = True | 344 | comment_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 |