aboutsummaryrefslogtreecommitdiffstats
path: root/test
diff options
context:
space:
mode:
Diffstat (limited to 'test')
-rw-r--r--test/data/syntax-comments.txt68
-rw-r--r--test/lisp/calc/calc-tests.el116
-rw-r--r--test/lisp/electric-tests.el3
-rw-r--r--test/lisp/emacs-lisp/backtrace-tests.el2
-rw-r--r--test/lisp/emacs-lisp/edebug-tests.el2
-rw-r--r--test/lisp/files-tests.el4
-rw-r--r--test/lisp/gnus/gnus-util-tests.el13
-rw-r--r--test/lisp/gnus/mml-sec-tests.el32
-rw-r--r--test/lisp/mail/uudecode-tests.el4
-rw-r--r--test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml49
-rw-r--r--test/lisp/net/dbus-tests.el816
-rw-r--r--test/lisp/obsolete/cl-tests.el3
-rw-r--r--test/lisp/progmodes/python-tests.el4
-rw-r--r--test/lisp/simple-tests.el2
-rw-r--r--test/lisp/vc/vc-bzr-tests.el5
-rw-r--r--test/lisp/wdired-tests.el16
-rw-r--r--test/manual/cedet/tests/testnsp.cpp2
-rw-r--r--test/src/coding-tests.el2
-rw-r--r--test/src/indent-tests.el59
-rw-r--r--test/src/regex-resources/BOOST.tests4
-rw-r--r--test/src/syntax-tests.el349
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 @@
1/* This file is a test file for tests of the comment handling in src/syntax.c.
2 This includes the testing of comments which figure in parse-partial-sexp
3 and scan-lists. */
4
5/* Straight C comments */
61/* comment */1
72/**/2
83// comment
93
104//
114
125/*/5
136*/6
147/* \*/7
158*/8
169/* \\*/9
1710*/10
1811// \
1912
2011
2113// \\
2214
2313
2415/* /*/15
25
26/* C Comments within lists */
2759}59
2850{ /*70 comment */71 }50
2951{ /**/ }51
3052{ //72 comment
3173}52
3253{ //
33}53
3454{ //74 \
35}54
3655{/* */}55
3756{ /*76 \*/ }56
3857*/77
3958}58
4060{ /*78 \\*/79}60
41
42
43/* Straight Pascal comments (not nested) */
4420}20
4521{ Comment }21
4622{}22
4723{
48}23
4924{
5025{25
51}24
5226{ \}26
53
54
55/* Straight Lisp comments (not nested) */
5630
5730
5831; Comment
5931
6032;;;;;;;;;
6132
6233; \
6333
64
65Local Variables:
66mode: fundamental
67eval: (set-syntax-table (make-syntax-table))
68End:
diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el
index dce82b6f536..0df96a0e2db 100644
--- a/test/lisp/calc/calc-tests.el
+++ b/test/lisp/calc/calc-tests.el
@@ -458,6 +458,122 @@ An existing calc stack is reused, otherwise a new one is created."
458 (calcFunc-choose '(frac -15 2) 3)) 458 (calcFunc-choose '(frac -15 2) 3))
459 (calc-tests--choose -7.5 3)))) 459 (calc-tests--choose -7.5 3))))
460 460
461(ert-deftest calc-business-days ()
462 (cl-flet ((m (s) (math-parse-date s))
463 (b+ (a b) (calcFunc-badd a b))
464 (b- (a b) (calcFunc-bsub a b)))
465 ;; Sanity check.
466 (should (equal (m "2020-09-07") '(date 737675)))
467
468 ;; Test with standard business days (Mon-Fri):
469 (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-08"))) ; Mon->Tue
470 (should (equal (b+ (m "2020-09-08") 1) (m "2020-09-09"))) ; Tue->Wed
471 (should (equal (b+ (m "2020-09-09") 1) (m "2020-09-10"))) ; Wed->Thu
472 (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-11"))) ; Thu->Fri
473 (should (equal (b+ (m "2020-09-11") 1) (m "2020-09-14"))) ; Fri->Mon
474
475 (should (equal (b+ (m "2020-09-07") 4) (m "2020-09-11"))) ; Mon->Fri
476 (should (equal (b+ (m "2020-09-07") 6) (m "2020-09-15"))) ; Mon->Tue
477
478 (should (equal (b+ (m "2020-09-12") 1) (m "2020-09-14"))) ; Sat->Mon
479 (should (equal (b+ (m "2020-09-13") 1) (m "2020-09-14"))) ; Sun->Mon
480
481 (should (equal (b- (m "2020-09-11") 1) (m "2020-09-10"))) ; Fri->Thu
482 (should (equal (b- (m "2020-09-10") 1) (m "2020-09-09"))) ; Thu->Wed
483 (should (equal (b- (m "2020-09-09") 1) (m "2020-09-08"))) ; Wed->Tue
484 (should (equal (b- (m "2020-09-08") 1) (m "2020-09-07"))) ; Tue->Mon
485 (should (equal (b- (m "2020-09-07") 1) (m "2020-09-04"))) ; Mon->Fri
486
487 (should (equal (b- (m "2020-09-11") 4) (m "2020-09-07"))) ; Fri->Mon
488 (should (equal (b- (m "2020-09-15") 6) (m "2020-09-07"))) ; Tue->Mon
489
490 (should (equal (b- (m "2020-09-12") 1) (m "2020-09-11"))) ; Sat->Fri
491 (should (equal (b- (m "2020-09-13") 1) (m "2020-09-11"))) ; Sun->Fri
492
493 ;; Stepping fractional days
494 (should (equal (b+ (m "2020-09-08 21:00") '(frac 1 2))
495 (m "2020-09-09 09:00")))
496 (should (equal (b+ (m "2020-09-11 21:00") '(frac 1 2))
497 (m "2020-09-14 09:00")))
498 (should (equal (b- (m "2020-09-08 21:00") '(frac 1 2))
499 (m "2020-09-08 09:00")))
500 (should (equal (b- (m "2020-09-14 06:00") '(frac 1 2))
501 (m "2020-09-11 18:00")))
502
503 ;; Test with a couple of extra days off:
504 (let ((var-Holidays (list 'vec
505 '(var sat var-sat) '(var sun var-sun)
506 (m "2020-09-09") (m "2020-09-11"))))
507
508 (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-08"))) ; Mon->Tue
509 (should (equal (b+ (m "2020-09-08") 1) (m "2020-09-10"))) ; Tue->Thu
510 (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-14"))) ; Thu->Mon
511 (should (equal (b+ (m "2020-09-14") 1) (m "2020-09-15"))) ; Mon->Tue
512 (should (equal (b+ (m "2020-09-15") 1) (m "2020-09-16"))) ; Tue->Wed
513
514 (should (equal (b- (m "2020-09-16") 1) (m "2020-09-15"))) ; Wed->Tue
515 (should (equal (b- (m "2020-09-15") 1) (m "2020-09-14"))) ; Tue->Mon
516 (should (equal (b- (m "2020-09-14") 1) (m "2020-09-10"))) ; Mon->Thu
517 (should (equal (b- (m "2020-09-10") 1) (m "2020-09-08"))) ; Thu->Tue
518 (should (equal (b- (m "2020-09-08") 1) (m "2020-09-07"))) ; Tue->Mon
519 )
520
521 ;; Test with odd non-business weekdays (Tue, Wed, Sat):
522 (let ((var-Holidays '(vec (var tue var-tue)
523 (var wed var-wed)
524 (var sat var-sat))))
525 (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-10"))) ; Mon->Thu
526 (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-11"))) ; Thu->Fri
527 (should (equal (b+ (m "2020-09-11") 1) (m "2020-09-13"))) ; Fri->Sun
528 (should (equal (b+ (m "2020-09-13") 1) (m "2020-09-14"))) ; Sun->Mon
529
530 (should (equal (b- (m "2020-09-14") 1) (m "2020-09-13"))) ; Mon->Sun
531 (should (equal (b- (m "2020-09-13") 1) (m "2020-09-11"))) ; Sun->Fri
532 (should (equal (b- (m "2020-09-11") 1) (m "2020-09-10"))) ; Fri->Thu
533 (should (equal (b- (m "2020-09-10") 1) (m "2020-09-07"))) ; Thu->Mon
534 )
535 ))
536
537(ert-deftest calc-unix-date ()
538 (let* ((d-1970-01-01 (math-parse-date "1970-01-01"))
539 (d-2020-09-07 (math-parse-date "2020-09-07"))
540 (d-1991-01-09-0600 (math-parse-date "1991-01-09 06:00")))
541 ;; calcFunc-unixtime (command "t U") converts a date value to Unix time,
542 ;; and a number to a date.
543 (should (equal d-1970-01-01 '(date 719163)))
544 (should (equal (calcFunc-unixtime d-1970-01-01 0) 0))
545 (should (equal (calc-tests--calc-to-number (cadr (calcFunc-unixtime 0 0)))
546 (cadr d-1970-01-01)))
547 (should (equal (calcFunc-unixtime d-2020-09-07 0)
548 (* (- (cadr d-2020-09-07)
549 (cadr d-1970-01-01))
550 86400)))
551 (should (equal (calcFunc-unixtime d-1991-01-09-0600 0)
552 663400800))
553 (should (equal (calc-tests--calc-to-number
554 (cadr (calcFunc-unixtime 663400800 0)))
555 726841.25))
556
557 (let ((calc-date-format '(U)))
558 ;; Test parsing Unix time.
559 (should (equal (calc-tests--calc-to-number
560 (cadr (math-parse-date "0")))
561 719163))
562 (should (equal (calc-tests--calc-to-number
563 (cadr (math-parse-date "469324800")))
564 (+ 719163 (/ 469324800 86400))))
565 (should (equal (calc-tests--calc-to-number
566 (cadr (math-parse-date "663400800")))
567 726841.25))
568
569 ;; Test formatting Unix time.
570 (should (equal (math-format-date d-1970-01-01) "0"))
571 (should (equal (math-format-date d-2020-09-07)
572 (number-to-string (* (- (cadr d-2020-09-07)
573 (cadr d-1970-01-01))
574 86400))))
575 (should (equal (math-format-date d-1991-01-09-0600) "663400800")))))
576
461(provide 'calc-tests) 577(provide 'calc-tests)
462;;; calc-tests.el ends here 578;;; calc-tests.el ends here
463 579
diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el
index 8b9c1c5fcb5..5f63f6831b3 100644
--- a/test/lisp/electric-tests.el
+++ b/test/lisp/electric-tests.el
@@ -887,7 +887,8 @@ baz\"\""
887 (should (equal (buffer-string) "int main () {\n \n}")))) 887 (should (equal (buffer-string) "int main () {\n \n}"))))
888 888
889(ert-deftest electric-layout-control-reindentation () 889(ert-deftest electric-layout-control-reindentation ()
890 "Same as `e-l-int-main-kernel-style', but checking Bug#35254." 890 "Same as `emacs-lisp-int-main-kernel-style', but checking
891Bug#35254."
891 (ert-with-test-buffer () 892 (ert-with-test-buffer ()
892 (plainer-c-mode) 893 (plainer-c-mode)
893 (electric-layout-local-mode 1) 894 (electric-layout-local-mode 1)
diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el
index 12164b46ec3..fbc71e0ec86 100644
--- a/test/lisp/emacs-lisp/backtrace-tests.el
+++ b/test/lisp/emacs-lisp/backtrace-tests.el
@@ -41,7 +41,7 @@
41 (backtrace-mode) 41 (backtrace-mode)
42 (setq backtrace-frames (backtrace-get-frames)) 42 (setq backtrace-frames (backtrace-get-frames))
43 (let ((this-index)) 43 (let ((this-index))
44 ;; Discard all past `backtrace-tests-make-backtrace'. 44 ;; Discard all past `backtrace-tests--make-backtrace'.
45 (dotimes (index (length backtrace-frames)) 45 (dotimes (index (length backtrace-frames))
46 (when (eq (backtrace-frame-fun (nth index backtrace-frames)) 46 (when (eq (backtrace-frame-fun (nth index backtrace-frames))
47 'backtrace-tests--make-backtrace) 47 'backtrace-tests--make-backtrace)
diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el
index 04a7b2f5a0f..6db07b1b707 100644
--- a/test/lisp/emacs-lisp/edebug-tests.el
+++ b/test/lisp/emacs-lisp/edebug-tests.el
@@ -210,7 +210,7 @@ All other elements will be nil."
210(defvar edebug-tests-thunks nil 210(defvar edebug-tests-thunks nil
211 "List containing thunks to run after each command in a keyboard macro.") 211 "List containing thunks to run after each command in a keyboard macro.")
212(defvar edebug-tests-kbd-macro-index nil 212(defvar edebug-tests-kbd-macro-index nil
213 "Index into `edebug-tests-run-unpacked-kbd-macro's current keyboard macro.") 213 "Index into `edebug-tests-run-kbd-macro's current keyboard macro.")
214 214
215(defun edebug-tests-run-macro (kbdmac &rest thunks) 215(defun edebug-tests-run-macro (kbdmac &rest thunks)
216 "Run a keyboard macro and execute a thunk after each command in it. 216 "Run a keyboard macro and execute a thunk after each command in it.
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index 2e9c6adc947..3829f505010 100644
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -960,7 +960,7 @@ unquoted file names."
960 (let ((linkname (expand-file-name "link" nospecial-dir))) 960 (let ((linkname (expand-file-name "link" nospecial-dir)))
961 (should-error (make-symbolic-link tmpfile linkname)))))))) 961 (should-error (make-symbolic-link tmpfile linkname))))))))
962 962
963;; See `files-tests--file-name-non-special--subprocess'. 963;; See `files-tests-file-name-non-special--subprocess'.
964;; (ert-deftest files-tests-file-name-non-special-process-file ()) 964;; (ert-deftest files-tests-file-name-non-special-process-file ())
965 965
966(ert-deftest files-tests-file-name-non-special-rename-file () 966(ert-deftest files-tests-file-name-non-special-rename-file ()
@@ -1104,7 +1104,7 @@ unquoted file names."
1104 (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) 1104 (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
1105 (should (equal (vc-registered nospecial) (vc-registered tmpfile))))) 1105 (should (equal (vc-registered nospecial) (vc-registered tmpfile)))))
1106 1106
1107;; See test `files-tests--file-name-non-special--buffers'. 1107;; See test `files-tests-file-name-non-special--buffers'.
1108;; (ert-deftest files-tests-file-name-non-special-verify-visited-file-modtime ()) 1108;; (ert-deftest files-tests-file-name-non-special-verify-visited-file-modtime ())
1109 1109
1110(ert-deftest files-tests-file-name-non-special-write-region () 1110(ert-deftest files-tests-file-name-non-special-write-region ()
diff --git a/test/lisp/gnus/gnus-util-tests.el b/test/lisp/gnus/gnus-util-tests.el
index ec58032e84e..47f0a9cf761 100644
--- a/test/lisp/gnus/gnus-util-tests.el
+++ b/test/lisp/gnus/gnus-util-tests.el
@@ -151,8 +151,10 @@
151 (should (equal "Zg==" (gnus-base64-repad "Zg"))) 151 (should (equal "Zg==" (gnus-base64-repad "Zg")))
152 (should (equal "Zg==" (gnus-base64-repad "Zg===="))) 152 (should (equal "Zg==" (gnus-base64-repad "Zg====")))
153 153
154 (should (equal (gnus-base64-repad " ") "")) 154 (should-error (gnus-base64-repad " ")
155 (should (equal (gnus-base64-repad "Zg== ") "Zg==")) 155 :type 'error)
156 (should-error (gnus-base64-repad "Zg== ")
157 :type 'error)
156 (should-error (gnus-base64-repad "Z?\x00g==") 158 (should-error (gnus-base64-repad "Z?\x00g==")
157 :type 'error) 159 :type 'error)
158 ;; line-length 160 ;; line-length
@@ -162,9 +164,10 @@
162 (should-error (gnus-base64-repad "Zm9v\r\nYmFy" t) 164 (should-error (gnus-base64-repad "Zm9v\r\nYmFy" t)
163 :type 'error) 165 :type 'error)
164 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9vYmFy" t))) 166 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9vYmFy" t)))
165 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy" nil))) 167 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy")))
166 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy\n" nil))) 168 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy\n")))
167 (should (equal (gnus-base64-repad "Zm9v\r\n YmFy\r\n" nil) "Zm9vYmFy")) 169 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\n YmFy\r\n")))
170 (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v \r\n\tYmFy")))
168 (should-error (gnus-base64-repad "Zm9v\r\nYmFy" nil 3) 171 (should-error (gnus-base64-repad "Zm9v\r\nYmFy" nil 3)
169 :type 'error)) 172 :type 'error))
170 173
diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el
index 4c745ea6d73..427018520c8 100644
--- a/test/lisp/gnus/mml-sec-tests.el
+++ b/test/lisp/gnus/mml-sec-tests.el
@@ -67,7 +67,6 @@ instead of gpg-agent."
67 (condition-case error 67 (condition-case error
68 (let ((epg-gpg-home-directory 68 (let ((epg-gpg-home-directory
69 (expand-file-name "test/data/mml-sec" source-directory)) 69 (expand-file-name "test/data/mml-sec" source-directory))
70 (mml-secure-allow-signing-with-unknown-recipient t)
71 (mml-smime-use 'epg) 70 (mml-smime-use 'epg)
72 ;; Create debug output in empty epg-debug-buffer. 71 ;; Create debug output in empty epg-debug-buffer.
73 (epg-debug t) 72 (epg-debug t)
@@ -762,37 +761,6 @@ Use sign-with-sender and encrypt-to-self."
762 method "no-exp@example.org" "sub@example.org" 2 nil)) 761 method "no-exp@example.org" "sub@example.org" 2 nil))
763 ))))) 762 )))))
764 763
765(ert-deftest mml-secure-sign-verify-2 ()
766 "Sign message without sender; then verify and test for expected result."
767 (skip-unless (test-conf))
768 (mml-secure-test-key-fixture
769 (lambda ()
770 (dolist (method (sign-standards) nil)
771 (let ((mml-secure-openpgp-sign-with-sender nil)
772 (mml-secure-smime-sign-with-sender nil))
773 ;; A single signing key for sender sub@example.org is customized
774 ;; in the fixture, but not used here.
775 ;; By default, gpg uses the first secret key in the keyring, which
776 ;; is 02372A42CA6D40FB (OpenPGP) or
777 ;; 0E58229B80EE33959FF718FEEF25402B479DC6E2 (S/MIME) here.
778 (mml-secure-test-en-decrypt
779 method "uid1@example.org" "sub@example.org" 0 nil)
780
781 ;; From sub@example.org, sign with specified key:
782 (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB"))
783 (mml-secure-smime-signers
784 '("D06AA118653CC38E9D0CAF56ED7A2135E1582177")))
785 (mml-secure-test-en-decrypt
786 method "no-exp@example.org" "sub@example.org" 1 nil))
787
788 ;; From sub@example.org, sign with different specified key:
789 (let ((mml-secure-openpgp-signers '("C3999CF1268DBEA2"))
790 (mml-secure-smime-signers
791 '("0E58229B80EE33959FF718FEEF25402B479DC6E2")))
792 (mml-secure-test-en-decrypt
793 method "no-exp@example.org" "sub@example.org" 1 nil))
794 )))))
795
796(ert-deftest mml-secure-sign-verify-3 () 764(ert-deftest mml-secure-sign-verify-3 ()
797 "Try to sign message with expired OpenPGP subkey, which raises an error. 765 "Try to sign message with expired OpenPGP subkey, which raises an error.
798With Ma Gnus v0.14 and earlier a signature would be created with a wrong key." 766With Ma Gnus v0.14 and earlier a signature would be created with a wrong key."
diff --git a/test/lisp/mail/uudecode-tests.el b/test/lisp/mail/uudecode-tests.el
index 61c20075633..4c9650f556c 100644
--- a/test/lisp/mail/uudecode-tests.el
+++ b/test/lisp/mail/uudecode-tests.el
@@ -43,12 +43,12 @@
43 (uudecode-tests-read-file 43 (uudecode-tests-read-file
44 (expand-file-name "uuencoded.txt" uudecode-tests-data-dir)) 44 (expand-file-name "uuencoded.txt" uudecode-tests-data-dir))
45 "Uuencoded data for bookmark-tests.el 45 "Uuencoded data for bookmark-tests.el
46Same as `bookmark-tests-decoded-str' but uuencoded.") 46Same as `uudecode-tests-decoded-str' but uuencoded.")
47(defvar uudecode-tests-decoded-str 47(defvar uudecode-tests-decoded-str
48 (uudecode-tests-read-file 48 (uudecode-tests-read-file
49 (expand-file-name "uudecoded.txt" uudecode-tests-data-dir)) 49 (expand-file-name "uudecoded.txt" uudecode-tests-data-dir))
50 "Plain text data for bookmark-tests.el 50 "Plain text data for bookmark-tests.el
51Same as `bookmark-tests-encoded-str' but plain text.") 51Same as `uudecode-tests-encoded-str' but plain text.")
52 52
53(ert-deftest uudecode-tests-decode-region-internal () 53(ert-deftest uudecode-tests-decode-region-internal ()
54 ;; Write to buffer 54 ;; Write to buffer
diff --git a/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml b/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml
new file mode 100644
index 00000000000..620f10510f2
--- /dev/null
+++ b/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml
@@ -0,0 +1,49 @@
1<?xml version="1.0"?>
2<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
3<node>
4 <interface name="org.freedesktop.DBus.Introspectable">
5 <method name="Introspect">
6 <arg name="xml" type="s" direction="out"/>
7 </method>
8 </interface>
9 <interface name="org.freedesktop.DBus.Properties">
10 <method name="Get">
11 <arg name="interface" type="s" direction="in"/>
12 <arg name="name" type="s" direction="in"/>
13 <arg name="value" type="v" direction="out"/>
14 </method>
15 <method name="Set">
16 <arg name="interface" type="s" direction="in"/>
17 <arg name="name" type="s" direction="in"/>
18 <arg name="value" type="v" direction="in"/>
19 </method>
20 <method name="GetAll">
21 <arg name="interface" type="s" direction="in"/>
22 <arg name="properties" type="a{sv}" direction="out"/>
23 </method>
24 <signal name="PropertiesChanged">
25 <arg name="interface" type="s"/>
26 <arg name="changed_properties" type="a{sv}"/>
27 <arg name="invalidated_properties" type="as"/>
28 </signal>
29 </interface>
30 <interface name="org.gnu.Emacs.TestDBus.Interface">
31 <method name="Connect">
32 <arg name="uuid" type="s" direction="in"/>
33 <arg name="mode" type="y" direction="in"/>
34 <arg name="options" type="a{sv}" direction="in"/>
35 <arg name="interface" type="s" direction="out"/>
36 </method>
37 <method name="DeprecatedMethod0">
38 <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
39 </method>
40 <method name="DeprecatedMethod1">
41 <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
42 </method>
43 <property name="Connected" type="b" access="read"/>
44 <property name="Player" type="o" access="read"/>
45 <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
46 </interface>
47 <node name="node0"/>
48 <node name="node1"/>
49</node>
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 74c0dddcf52..7ebef5d2609 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -46,6 +46,13 @@
46(defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface" 46(defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface"
47 "Test interface.") 47 "Test interface.")
48 48
49(defconst dbus--tests-dir
50 (file-truename
51 (expand-file-name "dbus-resources"
52 (file-name-directory (or load-file-name
53 buffer-file-name))))
54 "Directory containing introspection test data file.")
55
49(defun dbus--test-availability (bus) 56(defun dbus--test-availability (bus)
50 "Test availability of D-Bus BUS." 57 "Test availability of D-Bus BUS."
51 (should (dbus-list-names bus)) 58 (should (dbus-list-names bus))
@@ -309,7 +316,7 @@
309 (dbus-check-arguments :session dbus--test-service :double "string") 316 (dbus-check-arguments :session dbus--test-service :double "string")
310 :type 'wrong-type-argument) 317 :type 'wrong-type-argument)
311 318
312 ;; `:unix-fd'. UNIX file descriptors are transfered out-of-band. 319 ;; `:unix-fd'. UNIX file descriptors are transferred out-of-band.
313 ;; We do not support this, and so we cannot do much testing here for 320 ;; We do not support this, and so we cannot do much testing here for
314 ;; `:unix-fd' being an argument (which is an index to the file 321 ;; `:unix-fd' being an argument (which is an index to the file
315 ;; descriptor in the array of file descriptors that accompany the 322 ;; descriptor in the array of file descriptors that accompany the
@@ -359,11 +366,11 @@
359 (should 366 (should
360 (dbus-check-arguments 367 (dbus-check-arguments
361 :session dbus--test-service '(:variant (:array "string")))) 368 :session dbus--test-service '(:variant (:array "string"))))
362 ;; No or more than one element. 369 ;; Empty variant.
363 ;; FIXME. 370 (should-error
364 ;; (should-error 371 (dbus-check-arguments :session dbus--test-service '(:variant))
365 ;; (dbus-check-arguments :session dbus--test-service '(:variant)) 372 :type 'wrong-type-argument)
366 ;; :type 'wrong-type-argument) 373 ;; More than one element.
367 (should-error 374 (should-error
368 (dbus-check-arguments 375 (dbus-check-arguments
369 :session dbus--test-service 376 :session dbus--test-service
@@ -375,20 +382,22 @@
375 (should 382 (should
376 (dbus-check-arguments 383 (dbus-check-arguments
377 :session dbus--test-service 384 :session dbus--test-service
378 '(:array (:dict-entry :string "string" :boolean t)))) 385 '(:array (:dict-entry :string "string" :boolean nil))))
379 ;; This is an alternative syntax. FIXME: Shall this be supported? 386 ;; This is an alternative syntax. FIXME: Shall this be supported?
380 (should 387 (should
381 (dbus-check-arguments 388 (dbus-check-arguments
382 :session dbus--test-service 389 :session dbus--test-service
383 '(:array :dict-entry (:string "string" :boolean t)))) 390 '(:array :dict-entry (:string "string" :boolean t))))
384 ;; FIXME: Must be errors. 391 ;; Empty dict-entry.
385 ;; (should 392 (should-error
386 ;; (dbus-check-arguments 393 (dbus-check-arguments
387 ;; :session dbus--test-service '(:array (:dict-entry)))) 394 :session dbus--test-service '(:array (:dict-entry)))
388 ;; (should 395 :type 'wrong-type-argument)
389 ;; (dbus-check-arguments 396 ;; One element.
390 ;; :session dbus--test-service '(:array (:dict-entry :string "string")))) 397 (should-error
391 ;; Not two elements. 398 (dbus-check-arguments
399 :session dbus--test-service '(:array (:dict-entry :string "string")))
400 :type 'wrong-type-argument)
392 (should-error 401 (should-error
393 (dbus-check-arguments 402 (dbus-check-arguments
394 :session dbus--test-service 403 :session dbus--test-service
@@ -405,25 +414,27 @@
405 (dbus-check-arguments 414 (dbus-check-arguments
406 :session dbus--test-service '(:dict-entry :string "string" :boolean t)) 415 :session dbus--test-service '(:dict-entry :string "string" :boolean t))
407 :type 'wrong-type-argument) 416 :type 'wrong-type-argument)
408 ;; FIXME:! This doesn't look right. 417 ;; Different dict entry types are not ched. FIXME: Add check.
409 ;; Different dict entry types can be part of an array ??? 418 ;; (should-error
410 (should 419 ;; (dbus-check-arguments
411 (dbus-check-arguments 420 ;; :session dbus--test-service
412 :session dbus--test-service 421 ;; '(:array
413 '(:array 422 ;; (:dict-entry :string "string1" :boolean t)
414 (:dict-entry :string "string1" :boolean t) 423 ;; (:dict-entry :string "string2" :object-path "/object/path")))
415 (:dict-entry :string "string2" :object-path "/object/path")))) 424 ;; :type 'wrong-type-argument)
416 425
417 ;; `:struct'. There is no restriction what could be an element of a struct. 426 ;; `:struct'. There is no restriction what could be an element of a struct.
418 ;; Empty struct. FIXME: Is this right?
419 ;; (should (dbus-check-arguments :session dbus--test-service '(:struct)))
420 (should 427 (should
421 (dbus-check-arguments 428 (dbus-check-arguments
422 :session dbus--test-service 429 :session dbus--test-service
423 '(:struct 430 '(:struct
424 :string "string" 431 :string "string"
425 :object-path "/object/path" 432 :object-path "/object/path"
426 (:variant (:array :unix-fd 1 :unix-fd 2 :unix-fd 3 :unix-fd 4)))))) 433 (:variant (:array :unix-fd 1 :unix-fd 2 :unix-fd 3 :unix-fd 4)))))
434 ;; Empty struct.
435 (should-error
436 (dbus-check-arguments :session dbus--test-service '(:struct))
437 :type 'wrong-type-argument))
427 438
428(defun dbus--test-register-service (bus) 439(defun dbus--test-register-service (bus)
429 "Check service registration at BUS." 440 "Check service registration at BUS."
@@ -625,6 +636,63 @@ This includes initialization and closing the bus."
625 ;; Cleanup. 636 ;; Cleanup.
626 (dbus-unregister-service :session dbus--test-service))) 637 (dbus-unregister-service :session dbus--test-service)))
627 638
639(defun dbus--test-method-reentry-handler (&rest _args)
640 "Method handler for `dbus-test04-method-reentry'."
641 (dbus-get-all-managed-objects :session dbus--test-service dbus--test-path)
642 42)
643
644(ert-deftest dbus-test04-method-reentry ()
645 "Check receiving method call while awaiting response.
646Ensure that incoming method calls are handled when call to `dbus-call-method'
647is in progress."
648 :tags '(:expensive-test)
649 ;; Simulate application registration. (Bug#43251)
650 (skip-unless dbus--test-enabled-session-bus)
651 (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
652
653 (unwind-protect
654 (let ((method "Reentry"))
655 (should
656 (equal
657 (dbus-register-method
658 :session dbus--test-service dbus--test-path
659 dbus--test-interface method #'dbus--test-method-reentry-handler)
660 `((:method :session ,dbus--test-interface ,method)
661 (,dbus--test-service ,dbus--test-path
662 dbus--test-method-reentry-handler))))
663
664 (should
665 (=
666 (dbus-call-method
667 :session dbus--test-service dbus--test-path
668 dbus--test-interface method)
669 42)))
670
671 ;; Cleanup.
672 (dbus-unregister-service :session dbus--test-service)))
673
674(ert-deftest dbus-test04-call-method-timeout ()
675 "Verify `dbus-call-method' request timeout."
676 :tags '(:expensive-test)
677 (skip-unless dbus--test-enabled-session-bus)
678 (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
679 (dbus-register-service :session dbus--test-service)
680
681 (unwind-protect
682 (let ((start (current-time)))
683 ;; Test timeout override for method call.
684 (should-error
685 (dbus-call-method
686 :session dbus--test-service dbus--test-path
687 dbus-interface-introspectable "Introspect" :timeout 2500)
688 :type 'dbus-error)
689
690 (should
691 (< 2.4 (float-time (time-since start)) 2.7)))
692
693 ;; Cleanup.
694 (dbus-unregister-service :session dbus--test-service)))
695
628(defvar dbus--test-signal-received nil 696(defvar dbus--test-signal-received nil
629 "Received signal value in `dbus--test-signal-handler'.") 697 "Received signal value in `dbus--test-signal-handler'.")
630 698
@@ -1069,6 +1137,702 @@ This includes initialization and closing the bus."
1069 ;; Cleanup. 1137 ;; Cleanup.
1070 (dbus-unregister-service :session dbus--test-service))) 1138 (dbus-unregister-service :session dbus--test-service)))
1071 1139
1140(defsubst dbus--test-run-property-test (selector name value expected)
1141 "Generate a property test: register, set, get, getall sequence.
1142This is a helper function for the macro `dbus--test-property'.
1143The argument SELECTOR indicates whether the test should expand to
1144`dbus-register-property' (if SELECTOR is `register') or
1145`dbus-set-property' (if SELECTOR is `set').
1146The argument NAME is the property name.
1147The argument VALUE is the value to register or set.
1148The argument EXPECTED is a transformed VALUE representing the
1149form `dbus-get-property' should return."
1150 (cond
1151 ((eq selector 'register)
1152 (should
1153 (equal
1154 (dbus-register-property
1155 :session dbus--test-service dbus--test-path dbus--test-interface name
1156 :readwrite value)
1157 `((:property :session ,dbus--test-interface ,name)
1158 (,dbus--test-service ,dbus--test-path)))))
1159
1160 ((eq selector 'set)
1161 (should
1162 (equal
1163 (dbus-set-property
1164 :session dbus--test-service dbus--test-path dbus--test-interface name
1165 value)
1166 expected)))
1167
1168 (t (signal 'wrong-type-argument "Selector should be 'register or 'set.")))
1169
1170 (should
1171 (equal
1172 (dbus-get-property
1173 :session dbus--test-service dbus--test-path dbus--test-interface name)
1174 expected))
1175
1176 (let ((result
1177 (dbus-get-all-properties
1178 :session dbus--test-service dbus--test-path dbus--test-interface)))
1179 (should (equal (cdr (assoc name result)) expected)))
1180
1181 (let ((result
1182 (dbus-get-all-managed-objects :session dbus--test-service "/"))
1183 result1)
1184 (should (setq result1 (cadr (assoc dbus--test-path result))))
1185 (should (setq result1 (cadr (assoc dbus--test-interface result1))))
1186 (should (equal (cdr (assoc name result1)) expected))))
1187
1188(defsubst dbus--test-property (name &rest value-list)
1189 "Test a D-Bus property named by string argument NAME.
1190The argument VALUE-LIST is a sequence of pairs, where each pair
1191represents a value form and an expected returned value form. The
1192first pair in VALUES is used for `dbus-register-property'.
1193Subsequent pairs of the list are tested with `dbus-set-property'."
1194 (let ((values (car value-list)))
1195 (dbus--test-run-property-test
1196 'register name (car values) (cdr values)))
1197 (dolist (values (cdr value-list))
1198 (dbus--test-run-property-test
1199 'set name (car values) (cdr values))))
1200
1201(ert-deftest dbus-test06-property-types ()
1202 "Check property access and mutation for an own service."
1203 (skip-unless dbus--test-enabled-session-bus)
1204 (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
1205 (dbus-register-service :session dbus--test-service)
1206
1207 (unwind-protect
1208 (progn
1209 (dbus--test-property
1210 "ByteArray"
1211 '((:array :byte 1 :byte 2 :byte 3) . (1 2 3))
1212 '((:array :byte 4 :byte 5 :byte 6) . (4 5 6)))
1213
1214 (dbus--test-property
1215 "StringArray"
1216 '((:array "one" "two" :string "three") . ("one" "two" "three"))
1217 '((:array :string "four" :string "five" "six") . ("four" "five" "six")))
1218
1219 (dbus--test-property
1220 "ObjectArray"
1221 '((:array
1222 :object-path "/node00"
1223 :object-path "/node01"
1224 :object-path "/node0/node02")
1225 . ("/node00" "/node01" "/node0/node02"))
1226 '((:array
1227 :object-path "/node10"
1228 :object-path "/node11"
1229 :object-path "/node0/node12")
1230 . ("/node10" "/node11" "/node0/node12")))
1231
1232 (dbus--test-property
1233 "Dictionary"
1234 '((:array
1235 :dict-entry (:string "four" (:variant :string "value of four"))
1236 :dict-entry ("five" (:variant :object-path "/node0"))
1237 :dict-entry ("six" (:variant (:array :byte 4 :byte 5 :byte 6))))
1238 . (("four"
1239 ("value of four"))
1240 ("five"
1241 ("/node0"))
1242 ("six"
1243 ((4 5 6)))))
1244 '((:array
1245 :dict-entry
1246 (:string "key0" (:variant (:array :byte 7 :byte 8 :byte 9)))
1247 :dict-entry ("key1" (:variant :string "value"))
1248 :dict-entry ("key2" (:variant :object-path "/node0/node1")))
1249 . (("key0"
1250 ((7 8 9)))
1251 ("key1"
1252 ("value"))
1253 ("key2"
1254 ("/node0/node1")))))
1255
1256 (dbus--test-property ; Syntax emphasizing :dict compound type.
1257 "Dictionary"
1258 '((:array
1259 (:dict-entry :string "seven" (:variant :string "value of seven"))
1260 (:dict-entry "eight" (:variant :object-path "/node8"))
1261 (:dict-entry "nine" (:variant (:array :byte 9 :byte 27 :byte 81))))
1262 . (("seven"
1263 ("value of seven"))
1264 ("eight"
1265 ("/node8"))
1266 ("nine"
1267 ((9 27 81)))))
1268 '((:array
1269 (:dict-entry
1270 :string "key4" (:variant (:array :byte 7 :byte 49 :byte 125)))
1271 (:dict-entry "key5" (:variant :string "obsolete"))
1272 (:dict-entry "key6" (:variant :object-path "/node6/node7")))
1273 . (("key4"
1274 ((7 49 125)))
1275 ("key5"
1276 ("obsolete"))
1277 ("key6"
1278 ("/node6/node7")))))
1279
1280 (dbus--test-property
1281 "ByteDictionary"
1282 '((:array
1283 (:dict-entry :byte 8 (:variant :string "byte-eight"))
1284 (:dict-entry :byte 16 (:variant :object-path "/byte/sixteen"))
1285 (:dict-entry :byte 48 (:variant (:array :byte 8 :byte 9 :byte 10))))
1286 . (( 8 ("byte-eight"))
1287 (16 ("/byte/sixteen"))
1288 (48 ((8 9 10))))))
1289
1290 (dbus--test-property
1291 "Variant"
1292 '((:variant "Variant string") . ("Variant string"))
1293 '((:variant :byte 42) . (42))
1294 '((:variant :uint32 1000000) . (1000000))
1295 '((:variant :object-path "/variant/path") . ("/variant/path"))
1296 '((:variant :signature "a{sa{sv}}") . ("a{sa{sv}}"))
1297 '((:variant
1298 (:struct
1299 42 "string" (:object-path "/structure/path") (:variant "last")))
1300 . ((42 "string" ("/structure/path") ("last")))))
1301
1302 ;; Test that :read prevents writes.
1303 (should
1304 (equal
1305 (dbus-register-property
1306 :session dbus--test-service dbus--test-path dbus--test-interface
1307 "StringArray" :read '(:array "one" "two" :string "three"))
1308 `((:property :session ,dbus--test-interface "StringArray")
1309 (,dbus--test-service ,dbus--test-path))))
1310
1311 (should-error ; Cannot set property with :read access.
1312 (dbus-set-property
1313 :session dbus--test-service dbus--test-path dbus--test-interface
1314 "StringArray" '(:array "seven" "eight" :string "nine"))
1315 :type 'dbus-error)
1316
1317 (should ; Property value preserved on error.
1318 (equal
1319 (dbus-get-property
1320 :session dbus--test-service dbus--test-path dbus--test-interface
1321 "StringArray")
1322 '("one" "two" "three")))
1323
1324 ;; Test mismatched types in array.
1325 (should-error
1326 (dbus-register-property
1327 :session dbus--test-service dbus--test-path dbus--test-interface
1328 "MixedArray" :readwrite
1329 '(:array
1330 :object-path "/node00"
1331 :string "/node01"
1332 :object-path "/node0/node02"))
1333 :type 'wrong-type-argument)
1334
1335 ;; Test in-range integer values.
1336 (should
1337 (equal
1338 (dbus-register-property
1339 :session dbus--test-service dbus--test-path dbus--test-interface
1340 "ByteValue" :readwrite :byte 255)
1341 `((:property :session ,dbus--test-interface "ByteValue")
1342 (,dbus--test-service ,dbus--test-path))))
1343
1344 (should
1345 (=
1346 (dbus-get-property
1347 :session dbus--test-service dbus--test-path dbus--test-interface
1348 "ByteValue")
1349 255))
1350
1351 (should
1352 (equal
1353 (dbus-register-property
1354 :session dbus--test-service dbus--test-path dbus--test-interface
1355 "ShortValue" :readwrite :int16 32767)
1356 `((:property :session ,dbus--test-interface "ShortValue")
1357 (,dbus--test-service ,dbus--test-path))))
1358
1359 (should
1360 (=
1361 (dbus-get-property
1362 :session dbus--test-service dbus--test-path dbus--test-interface
1363 "ShortValue")
1364 32767))
1365
1366 (should
1367 (equal
1368 (dbus-register-property
1369 :session dbus--test-service dbus--test-path dbus--test-interface
1370 "UShortValue" :readwrite :uint16 65535)
1371 `((:property :session ,dbus--test-interface "UShortValue")
1372 (,dbus--test-service ,dbus--test-path))))
1373
1374 (should
1375 (=
1376 (dbus-get-property
1377 :session dbus--test-service dbus--test-path dbus--test-interface
1378 "UShortValue")
1379 65535))
1380
1381 (should
1382 (equal
1383 (dbus-register-property
1384 :session dbus--test-service dbus--test-path dbus--test-interface
1385 "IntValue" :readwrite :int32 2147483647)
1386 `((:property :session ,dbus--test-interface "IntValue")
1387 (,dbus--test-service ,dbus--test-path))))
1388
1389 (should
1390 (=
1391 (dbus-get-property
1392 :session dbus--test-service dbus--test-path
1393 dbus--test-interface "IntValue")
1394 2147483647))
1395
1396 (should
1397 (equal
1398 (dbus-register-property
1399 :session dbus--test-service dbus--test-path dbus--test-interface
1400 "UIntValue" :readwrite :uint32 4294967295)
1401 `((:property :session ,dbus--test-interface "UIntValue")
1402 (,dbus--test-service ,dbus--test-path))))
1403
1404 (should
1405 (=
1406 (dbus-get-property
1407 :session dbus--test-service dbus--test-path dbus--test-interface
1408 "UIntValue")
1409 4294967295))
1410
1411 (should
1412 (equal
1413 (dbus-register-property
1414 :session dbus--test-service dbus--test-path dbus--test-interface
1415 "LongValue" :readwrite :int64 9223372036854775807)
1416 `((:property :session ,dbus--test-interface "LongValue")
1417 (,dbus--test-service ,dbus--test-path))))
1418
1419 (should
1420 (=
1421 (dbus-get-property
1422 :session dbus--test-service dbus--test-path dbus--test-interface
1423 "LongValue")
1424 9223372036854775807))
1425
1426 (should
1427 (equal
1428 (dbus-register-property
1429 :session dbus--test-service dbus--test-path dbus--test-interface
1430 "ULongValue" :readwrite :uint64 18446744073709551615)
1431 `((:property :session ,dbus--test-interface "ULongValue")
1432 (,dbus--test-service ,dbus--test-path))))
1433
1434 (should
1435 (=
1436 (dbus-get-property
1437 :session dbus--test-service dbus--test-path dbus--test-interface
1438 "ULongValue")
1439 18446744073709551615))
1440
1441 ;; Test integer overflow.
1442 (should
1443 (=
1444 (dbus-set-property
1445 :session dbus--test-service dbus--test-path dbus--test-interface
1446 "ByteValue" :byte 520)
1447 8))
1448
1449 (should
1450 (=
1451 (dbus-get-property
1452 :session dbus--test-service dbus--test-path dbus--test-interface
1453 "ByteValue")
1454 8))
1455
1456 (should-error
1457 (dbus-register-property
1458 :session dbus--test-service dbus--test-path dbus--test-interface
1459 "ShortValue" :readwrite :int16 32800)
1460 :type 'args-out-of-range)
1461
1462 (should-error
1463 (dbus-register-property
1464 :session dbus--test-service dbus--test-path dbus--test-interface
1465 "UShortValue" :readwrite :uint16 65600)
1466 :type 'args-out-of-range)
1467
1468 (should-error
1469 (dbus-register-property
1470 :session dbus--test-service dbus--test-path dbus--test-interface
1471 "IntValue" :readwrite :int32 2147483700)
1472 :type 'args-out-of-range)
1473
1474 (should-error
1475 (dbus-register-property
1476 :session dbus--test-service dbus--test-path dbus--test-interface
1477 "UIntValue" :readwrite :uint32 4294967300)
1478 :type 'args-out-of-range)
1479
1480 (should-error
1481 (dbus-register-property
1482 :session dbus--test-service dbus--test-path dbus--test-interface
1483 "LongValue" :readwrite :int64 9223372036854775900)
1484 :type 'args-out-of-range)
1485
1486 (should-error
1487 (dbus-register-property
1488 :session dbus--test-service dbus--test-path dbus--test-interface
1489 "ULongValue" :readwrite :uint64 18446744073709551700)
1490 :type 'args-out-of-range)
1491
1492 ;; dbus-set-property may change property type.
1493 (should
1494 (=
1495 (dbus-set-property
1496 :session dbus--test-service dbus--test-path dbus--test-interface
1497 "ByteValue" 1024)
1498 1024))
1499
1500 (should
1501 (=
1502 (dbus-get-property
1503 :session dbus--test-service dbus--test-path dbus--test-interface
1504 "ByteValue")
1505 1024))
1506
1507 (should ; Another change property type test.
1508 (equal
1509 (dbus-set-property
1510 :session dbus--test-service dbus--test-path dbus--test-interface
1511 "ByteValue" :boolean t)
1512 t))
1513
1514 (should
1515 (eq
1516 (dbus-get-property
1517 :session dbus--test-service dbus--test-path dbus--test-interface
1518 "ByteValue")
1519 t))
1520
1521 ;; Test invalid type specification.
1522 (should-error
1523 (dbus-register-property
1524 :session dbus--test-service dbus--test-path dbus--test-interface
1525 "InvalidType" :readwrite :keyword 128)
1526 :type 'wrong-type-argument))
1527
1528 ;; Cleanup.
1529 (dbus-unregister-service :session dbus--test-service)))
1530
1531(defun dbus--test-introspect ()
1532 "Return test introspection string."
1533 (when (string-equal dbus--test-path (dbus-event-path-name last-input-event))
1534 (with-temp-buffer
1535 (insert-file-contents-literally
1536 (expand-file-name "org.gnu.Emacs.TestDBus.xml" dbus--tests-dir))
1537 (buffer-string))))
1538
1539(defsubst dbus--test-validate-interface
1540 (iface-name expected-properties expected-methods expected-signals
1541 expected-annotations)
1542 "Validate an interface definition for `dbus-test07-introspection'.
1543The argument IFACE-NAME is a string naming the interface to validate.
1544The arguments EXPECTED-PROPERTIES, EXPECTED-METHODS, EXPECTED-SIGNALS, and
1545EXPECTED-ANNOTATIONS represent the names of the interface's properties,
1546methods, signals, and annotations, respectively."
1547
1548 (let ((interface
1549 (dbus-introspect-get-interface
1550 :session dbus--test-service dbus--test-path iface-name)))
1551 (pcase-let ((`(interface ((name . ,name)) . ,rest) interface))
1552 (should
1553 (string-equal name iface-name))
1554 (should
1555 (string-equal name (dbus-introspect-get-attribute interface "name")))
1556
1557 (let (properties methods signals annotations)
1558 (mapc (lambda (x)
1559 (let ((name (dbus-introspect-get-attribute x "name")))
1560 (cond
1561 ((eq 'property (car x)) (push name properties))
1562 ((eq 'method (car x)) (push name methods))
1563 ((eq 'signal (car x)) (push name signals))
1564 ((eq 'annotation (car x)) (push name annotations)))))
1565 rest)
1566
1567 (should
1568 (equal
1569 (nreverse properties)
1570 expected-properties))
1571 (should
1572 (equal
1573 (nreverse methods)
1574 expected-methods))
1575 (should
1576 (equal
1577 (nreverse signals)
1578 expected-signals))
1579 (should
1580 (equal
1581 (nreverse annotations)
1582 expected-annotations))))))
1583
1584(defsubst dbus--test-validate-annotations (annotations expected-annotations)
1585 "Validate a list of D-Bus ANNOTATIONS.
1586Ensure each string in EXPECTED-ANNOTATIONS names an element of ANNOTATIONS.
1587And ensure each ANNOTATIONS has a value attribute marked \"true\"."
1588 (mapc
1589 (lambda (annotation)
1590 (let ((name (dbus-introspect-get-attribute annotation "name"))
1591 (value (dbus-introspect-get-attribute annotation "value")))
1592 (should
1593 (member name expected-annotations))
1594 (should
1595 (equal value "true"))))
1596 annotations))
1597
1598(defsubst dbus--test-validate-property
1599 (interface property-name _expected-annotations &rest expected-args)
1600 "Validate a property definition for `dbus-test07-introspection'.
1601
1602The argument INTERFACE is a string naming the interface owning PROPERTY-NAME.
1603The argument PROPERTY-NAME is a string naming the property to validate.
1604The arguments EXPECTED-ANNOTATIONS is a list of strings matching
1605the annotation names defined for the method or signal.
1606The argument EXPECTED-ARGS is a list of expected arguments for the property."
1607 (let* ((property
1608 (dbus-introspect-get-property
1609 :session dbus--test-service dbus--test-path interface property-name))
1610 (name (dbus-introspect-get-attribute property "name"))
1611 (type (dbus-introspect-get-attribute property "type"))
1612 (access (dbus-introspect-get-attribute property "access"))
1613 (expected (assoc-string name expected-args)))
1614 (should expected)
1615
1616 (should
1617 (string-equal name property-name))
1618
1619 (should
1620 (string-equal
1621 (nth 0 expected)
1622 name))
1623
1624 (should
1625 (string-equal
1626 (nth 1 expected)
1627 type))
1628
1629 (should
1630 (string-equal
1631 (nth 2 expected)
1632 access))))
1633
1634(defsubst dbus--test-validate-m-or-s (tree expected-annotations expected-args)
1635 "Validate a method or signal definition for `dbus-test07-introspection'.
1636The argument TREE is an sexp returned from either `dbus-introspect-get-method'
1637or `dbus-introspect-get-signal'
1638The arguments EXPECTED-ANNOTATIONS is a list of strings matching
1639the annotation names defined for the method or signal.
1640The argument EXPECTED-ARGS is a list of expected arguments for
1641the method or signal."
1642 (let (args annotations)
1643 (mapc (lambda (elem)
1644 (cond
1645 ((eq 'arg (car elem)) (push elem args))
1646 ((eq 'annotation (car elem)) (push elem annotations))))
1647 tree)
1648 (should
1649 (equal
1650 (nreverse args)
1651 expected-args))
1652 (dbus--test-validate-annotations annotations expected-annotations)))
1653
1654(defsubst dbus--test-validate-signal
1655 (interface signal-name expected-annotations &rest expected-args)
1656 "Validate a signal definition for `dbus-test07-introspection'.
1657
1658The argument INTERFACE is a string naming the interface owning SIGNAL-NAME.
1659The argument SIGNAL-NAME is a string naming the signal to validate.
1660The arguments EXPECTED-ANNOTATIONS is a list of strings matching
1661the annotation names defined for the signal.
1662The argument EXPECTED-ARGS is a list of expected arguments for the signal."
1663 (let ((signal
1664 (dbus-introspect-get-signal
1665 :session dbus--test-service dbus--test-path interface signal-name)))
1666 (pcase-let ((`(signal ((name . ,name)) . ,rest) signal))
1667 (should
1668 (string-equal name signal-name))
1669 (should
1670 (string-equal name (dbus-introspect-get-attribute signal "name")))
1671 (dbus--test-validate-m-or-s rest expected-annotations expected-args))))
1672
1673(defsubst dbus--test-validate-method
1674 (interface method-name expected-annotations &rest expected-args)
1675 "Validate a method definition for `dbus-test07-introspection'.
1676
1677The argument INTERFACE is a string naming the interface owning METHOD-NAME.
1678The argument METHOD-NAME is a string naming the method to validate.
1679The arguments EXPECTED-ANNOTATIONS is a list of strings matching
1680the annotation names defined for the method.
1681The argument EXPECTED-ARGS is a list of expected arguments for the method."
1682 (let ((method
1683 (dbus-introspect-get-method
1684 :session dbus--test-service dbus--test-path interface method-name)))
1685 (pcase-let ((`(method ((name . ,name)) . ,rest) method))
1686 (should
1687 (string-equal name method-name))
1688 (should
1689 (string-equal name (dbus-introspect-get-attribute method "name")))
1690 (dbus--test-validate-m-or-s rest expected-annotations expected-args))))
1691
1692(ert-deftest dbus-test07-introspection ()
1693 "Register an Introspection interface then query it."
1694 (skip-unless dbus--test-enabled-session-bus)
1695 (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
1696 (dbus-register-service :session dbus--test-service)
1697
1698 ;; Prepare introspection response.
1699 (dbus-register-method
1700 :session dbus--test-service dbus--test-path dbus-interface-introspectable
1701 "Introspect" 'dbus--test-introspect)
1702 (dbus-register-method
1703 :session dbus--test-service (concat dbus--test-path "/node0")
1704 dbus-interface-introspectable
1705 "Introspect" 'dbus--test-introspect)
1706 (dbus-register-method
1707 :session dbus--test-service (concat dbus--test-path "/node1")
1708 dbus-interface-introspectable
1709 "Introspect" 'dbus--test-introspect)
1710 (unwind-protect
1711 (let ((start (current-time)))
1712 ;; dbus-introspect-get-node-names
1713 (should
1714 (equal
1715 (dbus-introspect-get-node-names
1716 :session dbus--test-service dbus--test-path)
1717 '("node0" "node1")))
1718
1719 ;; dbus-introspect-get-all-nodes
1720 (should
1721 (equal
1722 (dbus-introspect-get-all-nodes
1723 :session dbus--test-service dbus--test-path)
1724 (list dbus--test-path
1725 (concat dbus--test-path "/node0")
1726 (concat dbus--test-path "/node1"))))
1727
1728 ;; dbus-introspect-get-interface-names
1729 (let ((interfaces
1730 (dbus-introspect-get-interface-names
1731 :session dbus--test-service dbus--test-path)))
1732
1733 (should
1734 (equal
1735 interfaces
1736 `(,dbus-interface-introspectable
1737 ,dbus-interface-properties
1738 ,dbus--test-interface)))
1739
1740 (dbus--test-validate-interface
1741 dbus-interface-introspectable nil '("Introspect") nil nil)
1742
1743 ;; dbus-introspect-get-interface via `dbus--test-validate-interface'.
1744 (dbus--test-validate-interface
1745 dbus-interface-properties nil
1746 '("Get" "Set" "GetAll") '("PropertiesChanged") nil)
1747
1748 (dbus--test-validate-interface
1749 dbus--test-interface '("Connected" "Player")
1750 '("Connect" "DeprecatedMethod0" "DeprecatedMethod1") nil
1751 `(,dbus-annotation-deprecated)))
1752
1753 ;; dbus-introspect-get-method-names
1754 (let ((methods
1755 (dbus-introspect-get-method-names
1756 :session dbus--test-service dbus--test-path
1757 dbus--test-interface)))
1758 (should
1759 (equal
1760 methods
1761 '("Connect" "DeprecatedMethod0" "DeprecatedMethod1")))
1762
1763 ;; dbus-introspect-get-method via `dbus--test-validate-method'.
1764 (dbus--test-validate-method
1765 dbus--test-interface "Connect" nil
1766 '(arg ((name . "uuid") (type . "s") (direction . "in")))
1767 '(arg ((name . "mode") (type . "y") (direction . "in")))
1768 '(arg ((name . "options") (type . "a{sv}") (direction . "in")))
1769 '(arg ((name . "interface") (type . "s") (direction . "out"))))
1770
1771 (dbus--test-validate-method
1772 dbus--test-interface "DeprecatedMethod0"
1773 `(,dbus-annotation-deprecated))
1774
1775 (dbus--test-validate-method
1776 dbus--test-interface "DeprecatedMethod1"
1777 `(,dbus-annotation-deprecated)))
1778
1779 ;; dbus-introspect-get-signal-names
1780 (let ((signals
1781 (dbus-introspect-get-signal-names
1782 :session dbus--test-service dbus--test-path
1783 dbus-interface-properties)))
1784 (should
1785 (equal
1786 signals
1787 '("PropertiesChanged")))
1788
1789 ;; dbus-introspect-get-signal via `dbus--test-validate-signal'.
1790 (dbus--test-validate-signal
1791 dbus-interface-properties "PropertiesChanged" nil
1792 '(arg ((name . "interface") (type . "s")))
1793 '(arg ((name . "changed_properties") (type . "a{sv}")))
1794 '(arg ((name . "invalidated_properties") (type . "as")))))
1795
1796 ;; dbus-intropct-get-property-names
1797 (let ((properties
1798 (dbus-introspect-get-property-names
1799 :session dbus--test-service dbus--test-path
1800 dbus--test-interface)))
1801 (should
1802 (equal
1803 properties
1804 '("Connected" "Player")))
1805
1806 ;; dbus-introspect-get-property via `dbus--test-validate-property'.
1807 (dbus--test-validate-property
1808 dbus--test-interface "Connected" nil
1809 '("Connected" "b" "read")
1810 '("Player" "o" "read")))
1811
1812 ;; Elapsed time over a second suggests timeouts.
1813 (should
1814 (< 0.0 (float-time (time-since start)) 1.0)))
1815
1816 ;; Cleanup.
1817 (dbus-unregister-service :session dbus--test-service)))
1818
1819(ert-deftest dbus-test07-introspection-timeout ()
1820 "Verify introspection request timeouts."
1821 :tags '(:expensive-test)
1822 (skip-unless dbus--test-enabled-session-bus)
1823 (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
1824 (dbus-register-service :session dbus--test-service)
1825
1826 (unwind-protect
1827 (let ((start (current-time)))
1828 (dbus-introspect-xml :session dbus--test-service dbus--test-path)
1829 ;; Introspection internal timeout is one second.
1830 (should
1831 (< 1.0 (float-time (time-since start)))))
1832
1833 ;; Cleanup.
1834 (dbus-unregister-service :session dbus--test-service)))
1835
1072(defun dbus-test-all (&optional interactive) 1836(defun dbus-test-all (&optional interactive)
1073 "Run all tests for \\[dbus]." 1837 "Run all tests for \\[dbus]."
1074 (interactive "p") 1838 (interactive "p")
diff --git a/test/lisp/obsolete/cl-tests.el b/test/lisp/obsolete/cl-tests.el
index 37061df0a7a..3f3fda3638e 100644
--- a/test/lisp/obsolete/cl-tests.el
+++ b/test/lisp/obsolete/cl-tests.el
@@ -21,7 +21,8 @@
21 21
22;;; Code: 22;;; Code:
23 23
24(require 'cl) 24(with-no-warnings
25 (require 'cl))
25(require 'ert) 26(require 'ert)
26 27
27 28
diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el
index 6b3e63653be..bc77443ff4f 100644
--- a/test/lisp/progmodes/python-tests.el
+++ b/test/lisp/progmodes/python-tests.el
@@ -339,7 +339,7 @@ def func(arg):
339 # I don't do much 339 # I don't do much
340 return arg 340 return arg
341 # This comment is badly indented because the user forced so. 341 # This comment is badly indented because the user forced so.
342 # At this line python.el wont dedent, user is always right. 342 # At this line python.el won't dedent, user is always right.
343 343
344comment_wins_over_ender = True 344comment_wins_over_ender = True
345 345
@@ -358,7 +358,7 @@ comment_wins_over_ender = True
358 ;; The return keyword do make indentation lose a level... 358 ;; The return keyword do make indentation lose a level...
359 (should (= (python-indent-calculate-indentation) 0)) 359 (should (= (python-indent-calculate-indentation) 0))
360 ;; ...but the current indentation was forced by the user. 360 ;; ...but the current indentation was forced by the user.
361 (python-tests-look-at "# At this line python.el wont dedent") 361 (python-tests-look-at "# At this line python.el won't dedent")
362 (should (eq (car (python-indent-context)) :after-comment)) 362 (should (eq (car (python-indent-context)) :after-comment))
363 (should (= (python-indent-calculate-indentation) 4)) 363 (should (= (python-indent-calculate-indentation) 4))
364 ;; Should behave the same for blank lines: potentially a comment. 364 ;; Should behave the same for blank lines: potentially a comment.
diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el
index 457de91c149..d4b316811e6 100644
--- a/test/lisp/simple-tests.el
+++ b/test/lisp/simple-tests.el
@@ -44,7 +44,7 @@
44;;; `count-words' 44;;; `count-words'
45(ert-deftest simple-test-count-words-bug-41761 () 45(ert-deftest simple-test-count-words-bug-41761 ()
46 (with-temp-buffer 46 (with-temp-buffer
47 (dotimes (i 10) (insert (propertize "test " 'field (cons nil nil)))) 47 (dotimes (_i 10) (insert (propertize "test " 'field (cons nil nil))))
48 (should (= (count-words (point-min) (point-max)) 10)))) 48 (should (= (count-words (point-min) (point-max)) 10))))
49 49
50 50
diff --git a/test/lisp/vc/vc-bzr-tests.el b/test/lisp/vc/vc-bzr-tests.el
index b68a6945129..408d6e8e23d 100644
--- a/test/lisp/vc/vc-bzr-tests.el
+++ b/test/lisp/vc/vc-bzr-tests.el
@@ -131,7 +131,6 @@
131 (make-directory bzrdir) 131 (make-directory bzrdir)
132 (expand-file-name "foo.el" bzrdir))) 132 (expand-file-name "foo.el" bzrdir)))
133 (default-directory (file-name-as-directory bzrdir)) 133 (default-directory (file-name-as-directory bzrdir))
134 (generated-autoload-file (expand-file-name "loaddefs.el" bzrdir))
135 (process-environment (cons (format "HOME=%s" homedir) 134 (process-environment (cons (format "HOME=%s" homedir)
136 process-environment))) 135 process-environment)))
137 (unwind-protect 136 (unwind-protect
@@ -148,7 +147,9 @@
148 ;; causes bzr status to fail. This simulates a broken bzr 147 ;; causes bzr status to fail. This simulates a broken bzr
149 ;; installation. 148 ;; installation.
150 (delete-file ".bzr/checkout/dirstate") 149 (delete-file ".bzr/checkout/dirstate")
151 (should (progn (update-directory-autoloads default-directory) 150 (should (progn (make-directory-autoloads
151 default-directory
152 (expand-file-name "loaddefs.el" bzrdir))
152 t))) 153 t)))
153 (delete-directory homedir t)))) 154 (delete-directory homedir t))))
154 155
diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el
index b89e8c876e2..f876967bf98 100644
--- a/test/lisp/wdired-tests.el
+++ b/test/lisp/wdired-tests.el
@@ -178,6 +178,22 @@ wdired-get-filename before and after editing."
178 (server-force-delete) 178 (server-force-delete)
179 (delete-directory test-dir t)))) 179 (delete-directory test-dir t))))
180 180
181(ert-deftest wdired-test-bug39280 ()
182 "Test for https://debbugs.gnu.org/39280."
183 (let* ((test-dir (make-temp-file "test-dir" 'dir))
184 (fname "foo")
185 (full-fname (expand-file-name fname test-dir)))
186 (make-empty-file full-fname)
187 (let ((buf (find-file-noselect test-dir)))
188 (unwind-protect
189 (with-current-buffer buf
190 (dired-toggle-read-only)
191 (dolist (old '(t nil))
192 (should (equal fname (wdired-get-filename 'nodir old)))
193 (should (equal full-fname (wdired-get-filename nil old))))
194 (wdired-finish-edit))
195 (if buf (kill-buffer buf))
196 (delete-directory test-dir t)))))
181 197
182(provide 'wdired-tests) 198(provide 'wdired-tests)
183;;; wdired-tests.el ends here 199;;; wdired-tests.el ends here
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) {
93 ; // #4# ( "Mumble" "get" ) 93 ; // #4# ( "Mumble" "get" )
94} 94}
95 95
96// What happens if a type your looking for is scoped withing a type, 96// What happens if a type your looking for is scoped within a type,
97// but you are one level into the completion so the originating scope 97// but you are one level into the completion so the originating scope
98// excludes the type of the variable you are completing through? 98// excludes the type of the variable you are completing through?
99// Thanks Martin Stein for this nice example. 99// 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 @@
143;; Optional 5th arg TRANSLATOR is a function to translate the original 143;; Optional 5th arg TRANSLATOR is a function to translate the original
144;; file contents to match with the expected result of decoding. For 144;; file contents to match with the expected result of decoding. For
145;; instance, when a file of dos eol-type is read by unix eol-type, 145;; instance, when a file of dos eol-type is read by unix eol-type,
146;; `decode-test-lf-to-crlf' must be specified. 146;; `coding-tests-lf-to-crlf' must be specified.
147 147
148(defun coding-tests (content-type write-coding read-coding detected-coding 148(defun coding-tests (content-type write-coding read-coding detected-coding
149 &optional translator) 149 &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 @@
1;;; indent-tests.el --- tests for src/indent.c -*- lexical-binding:t -*-
2
3;; Copyright (C) 2020 Free Software Foundation, Inc.
4
5;; This file is part of GNU Emacs.
6
7;; This program is free software: you can redistribute it and/or
8;; modify it under the terms of the GNU General Public License as
9;; published by the Free Software Foundation, either version 3 of the
10;; License, or (at your option) any later version.
11;;
12;; This program is distributed in the hope that it will be useful, but
13;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15;; General Public License for more details.
16;;
17;; You should have received a copy of the GNU General Public License
18;; along with this program. If not, see `https://www.gnu.org/licenses/'.
19
20;;; Commentary:
21
22;;; Code:
23
24(ert-deftest indent-tests-move-to-column-invis-1tab ()
25 "Test `move-to-column' when a TAB is followed by invisible text."
26 (should
27 (string=
28 (with-temp-buffer
29 (insert "\tLine starting with INVISIBLE text after TAB\n")
30 (add-text-properties 2 21 '(invisible t))
31 (goto-char (point-min))
32 (move-to-column 7 t)
33 (buffer-substring-no-properties 1 8))
34 " ")))
35
36(ert-deftest indent-tests-move-to-column-invis-2tabs ()
37 "Test `move-to-column' when 2 TABs are followed by invisible text."
38 (should
39 (string=
40 (with-temp-buffer
41 (insert "\t\tLine starting with INVISIBLE text after TAB\n")
42 (add-text-properties 3 22 '(invisible t))
43 (goto-char (point-min))
44 (move-to-column 12 t)
45 (buffer-substring-no-properties 1 11))
46 "\t \tLine")))
47
48(ert-deftest indent-tests-move-to-column-invis-between-tabs ()
49 "Test `move-to-column' when 2 TABs are mixed with invisible text."
50 (should
51 (string=
52 (with-temp-buffer
53 (insert "\txxx\tLine starting with INVISIBLE text after TAB\n")
54 (add-text-properties 6 25 '(invisible t))
55 (add-text-properties 2 5 '(invisible t))
56 (goto-char (point-min))
57 (move-to-column 12 t)
58 (buffer-substring-no-properties 1 14))
59 "\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\) !
93. \0 0 1 93. \0 0 1
94 94
95; 95;
96; now move on to the repetion ops, 96; now move on to the repetition ops,
97; starting with operator * 97; starting with operator *
98- match_default normal REG_EXTENDED 98- match_default normal REG_EXTENDED
99a* b 0 0 99a* b 0 0
@@ -275,7 +275,7 @@ a(b*)c\1d abbcbbbd -1 -1
275^(.)\1 abc -1 -1 275^(.)\1 abc -1 -1
276a([bc])\1d abcdabbd 4 8 5 6 276a([bc])\1d abcdabbd 4 8 5 6
277; strictly speaking this is at best ambiguous, at worst wrong, this is what most 277; strictly speaking this is at best ambiguous, at worst wrong, this is what most
278; re implimentations will match though. 278; re implementations will match though.
279a(([bc])\2)*d abbccd 0 6 3 5 3 4 279a(([bc])\2)*d abbccd 0 6 3 5 3 4
280 280
281a(([bc])\2)*d abbcbd -1 -1 281a(([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)."
82 (should (equal (parse-partial-sexp pointC pointX nil nil ppsC) 82 (should (equal (parse-partial-sexp pointC pointX nil nil ppsC)
83 ppsX))))) 83 ppsX)))))
84 84
85
86;;; Commentary:
87;; The next bit tests the handling of comments in syntax.c, in
88;; particular the functions `forward-comment' and `scan-lists' and
89;; `parse-partial-sexp' (in so far as they relate to comments).
90
91;; It is intended to enhance this bit to test nested comments
92;; (2020-10-01).
93
94;; This bit uses the data file test/data/syntax-comments.txt.
95
96(defun syntax-comments-point (n forw)
97 "Return the buffer offset corresponding to the \"label\" N.
98N is a decimal number which appears in the data file, usually
99twice, as \"labels\". It can also be a negative number or zero.
100FORW is t when we're using the label at BOL, nil for the one at EOL.
101
102If the label N doesn't exist in the current buffer, an exception
103is thrown.
104
105When FORW is t and N positive, we return the position after the
106first occurrence of label N at BOL in the data file. With FORW
107nil, we return the position before the last occurrence of the
108label at EOL in the data file.
109
110When N is negative, we return instead the position of the end of
111line that the -N label is on. When it is zero, we return POINT."
112 (if (zerop n)
113 (point)
114 (let ((str (format "%d" (abs n))))
115 (save-excursion
116 (if forw
117 (progn
118 (goto-char (point-min))
119 (re-search-forward
120 (concat "^\\(" str "\\)\\([^0-9\n]\\|$\\)"))
121 (if (< n 0)
122 (progn (end-of-line) (point))
123 (match-end 1)))
124 (goto-char (point-max))
125 (re-search-backward
126 (concat "\\(^\\|[^0-9]\\)\\(" str "\\)$"))
127 (if (< n 0)
128 (progn (end-of-line) (point))
129 (match-beginning 2)))))))
130
131(defun syntax-comments-midpoint (n)
132 "Return the buffer offset corresponding to the \"label\" N.
133N is a positive decimal number which should appear in the buffer
134exactly once. The label need not be at the beginning or end of a
135line.
136
137The return value is the position just before the label.
138
139If the label N doesn't exist in the current buffer, an exception
140is thrown."
141 (let ((str (format "%d" n)))
142 (save-excursion
143 (goto-char (point-min))
144 (re-search-forward
145 (concat "\\(^\\|[^0-9]\\)\\(" str "\\)\\([^0-9\n]\\|$\\)"))
146 (match-beginning 2))))
147
148(eval-and-compile
149 (defvar syntax-comments-section))
150
151(defmacro syntax-comments (-type- -dir- res start &optional stop)
152 "Create an ERT test to test (forward-comment 1/-1).
153The test uses a fixed name data file, which it visits. It calls
154entry and exit functions to set up and tear down syntax entries
155for comment characters. The test is given a name based on the
156global variable `syntax-comments-section', the direction of
157movement and the value of START.
158
159-TYPE- (unquoted) is a symbol from whose name the entry and exit
160function names are derived by appending \"-in\" and \"-out\".
161
162-DIR- (unquoted) is `forward' or `backward', the direction
163`forward-comment' is attempted.
164
165RES, t or nil, is the expected result from `forward-comment'.
166
167START and STOP are decimal numbers corresponding to labels in the
168data file marking the start and expected stop positions. See
169`syntax-comments-point' for a precise specification. If STOP is
170missing or nil, the value of START is assumed for it."
171 (declare (debug t))
172 (let ((forw
173 (cond
174 ((eq -dir- 'forward) t)
175 ((eq -dir- 'backward) nil)
176 (t (error "Invalid -dir- argument \"%s\" to `syntax-comments'" -dir-))))
177 (start-str (format "%d" (abs start)))
178 (type -type-))
179 `(ert-deftest ,(intern (concat "syntax-comments-"
180 syntax-comments-section
181 (if forw "-f" "-b") start-str))
182 ()
183 (with-current-buffer
184 (find-file
185 ,(expand-file-name "data/syntax-comments.txt"
186 (getenv "EMACS_TEST_DIRECTORY")))
187 (,(intern (concat (symbol-name type) "-in")))
188 (goto-char (syntax-comments-point ,start ,forw))
189 (let ((stop (syntax-comments-point ,(or stop start) ,(not forw))))
190 (should (eq (forward-comment ,(if forw 1 -1)) ,res))
191 (should (eq (point) stop)))
192 (,(intern (concat (symbol-name type) "-out")))))))
193
194(defmacro syntax-br-comments (-type- -dir- res -start- &optional stop)
195 "Create an ERT test to test (scan-lists <position> 1/-1 0).
196This is to test the interface between scan-lists and the internal
197comment routines in syntax.c.
198
199The test uses a fixed name data file, which it visits. It calls
200entry and exit functions to set up and tear down syntax entries
201for comment and paren characters. The test is given a name based
202on the global variable `syntax-comments-section', the direction
203of movement and the value of -START-.
204
205-TYPE- (unquoted) is a symbol from whose name the entry and exit
206function names are derived by appending \"-in\" and \"-out\".
207
208-DIR- (unquoted) is `forward' or `backward', the direction
209`scan-lists' is attempted.
210
211RES is t if `scan-lists' is expected to return, nil if it is
212expected to raise a `scan-error' exception.
213
214-START- and STOP are decimal numbers corresponding to labels in the
215data file marking the start and expected stop positions. See
216`syntax-comments-point' for a precise specification. If STOP is
217missing or nil, the value of -START- is assumed for it."
218 (declare (debug t))
219 (let* ((forw
220 (cond
221 ((eq -dir- 'forward) t)
222 ((eq -dir- 'backward) nil)
223 (t (error "Invalid -dir- argument \"%s\" to `syntax-comments'" -dir-))))
224 (start -start-)
225 (start-str (format "%d" (abs start)))
226 (type -type-))
227 `(ert-deftest ,(intern (concat "syntax-br-comments-"
228 syntax-comments-section
229 (if forw "-f" "-b") start-str))
230 ()
231 (with-current-buffer
232 (find-file
233 ,(expand-file-name "data/syntax-comments.txt"
234 (getenv "EMACS_TEST_DIRECTORY")))
235 (,(intern (concat (symbol-name type) "-in")))
236 (let ((start-pos (syntax-comments-point ,start ,forw))
237 ,@(if res
238 `((stop-pos (syntax-comments-point
239 ,(or stop start) ,(not forw))))))
240 ,(if res
241 `(should
242 (eq (scan-lists start-pos ,(if forw 1 -1) 0)
243 stop-pos))
244 `(should-error (scan-lists start-pos ,(if forw 1 -1) 0)
245 :type 'scan-error)))
246 (,(intern (concat (symbol-name type) "-out")))))))
247
248(defmacro syntax-pps-comments (-type- -start- open close &optional -stop-)
249 "Create an ERT test to test `parse-partial-sexp' with comments.
250This is to test the interface between `parse-partial-sexp' and
251the internal comment routines in syntax.c.
252
253The test uses a fixed name data file, which it visits. It calls
254entry and exit functions to set up and tear down syntax entries
255for comment and paren characters. The test is given a name based
256on the global variable `syntax-comments-section', and the value
257of -START-.
258
259The generated test calls `parse-partial-sexp' three times, the
260first two with COMMENTSTOP set to `syntax-table' so as to stop
261after the start and end of the comment. The third call is
262expected to stop at the brace/paren matching the one where the
263test started.
264
265-TYPE- (unquoted) is a symbol from whose name the entry and exit
266function names are derived by appending \"-in\" and \"-out\".
267
268-START- and -STOP- are decimal numbers corresponding to labels in
269the data file marking the start and expected stop positions. See
270`syntax-comments-point' for a precise specification. If -STOP-
271is missing or nil, the value of -START- is assumed for it.
272
273OPEN and CLOSE are decimal numbers corresponding to labels in the
274data file marking just after the comment opener and closer where
275the `parse-partial-sexp's are expected to stop. See
276`syntax-comments-midpoint' for a precise specification."
277 (declare (debug t))
278 (let* ((type -type-)
279 (start -start-)
280 (start-str (format "%d" start))
281 (stop (or -stop- start)))
282 `(ert-deftest ,(intern (concat "syntax-pps-comments-"
283 syntax-comments-section
284 "-" start-str))
285 ()
286 (with-current-buffer
287 (find-file
288 ,(expand-file-name "data/syntax-comments.txt"
289 (getenv "EMACS_TEST_DIRECTORY")))
290 (,(intern (concat (symbol-name type) "-in")))
291 (let ((start-pos (syntax-comments-point ,start t))
292 (open-pos (syntax-comments-midpoint ,open))
293 (close-pos (syntax-comments-midpoint ,close))
294 (stop-pos (syntax-comments-point ,stop nil))
295 s)
296 (setq s (parse-partial-sexp
297 start-pos (point-max) 0 nil nil 'syntax-table))
298 (should (eq (point) open-pos))
299 (setq s (parse-partial-sexp
300 (point) (point-max) 0 nil s 'syntax-table))
301 (should (eq (point) close-pos))
302 (setq s (parse-partial-sexp (point) (point-max) 0 nil s))
303 (should (eq (point) stop-pos)))
304 (,(intern (concat (symbol-name type) "-out")))))))
305
306;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
307;; "Pascal" style comments - single character delimiters, the closing
308;; delimiter not being newline.
309;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
310(defun {-in ()
311 (setq parse-sexp-ignore-comments t)
312 (setq comment-end-can-be-escaped nil)
313 (modify-syntax-entry ?{ "<")
314 (modify-syntax-entry ?} ">"))
315(defun {-out ()
316 (modify-syntax-entry ?{ "(}")
317 (modify-syntax-entry ?} "){"))
318(eval-and-compile
319 (setq syntax-comments-section "pascal"))
320
321(syntax-comments { forward nil 20 0)
322(syntax-comments { backward nil 20 0)
323(syntax-comments { forward t 21)
324(syntax-comments { backward t 21)
325(syntax-comments { forward t 22)
326(syntax-comments { backward t 22)
327
328(syntax-comments { forward t 23)
329(syntax-comments { backward t 23)
330(syntax-comments { forward t 24)
331(syntax-comments { backward t 24)
332(syntax-comments { forward t 26)
333(syntax-comments { backward t 26)
334
335;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
336;; "Lisp" style comments - single character opening delimiters on line
337;; comments.
338;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
339(defun \;-in ()
340 (setq parse-sexp-ignore-comments t)
341 (setq comment-end-can-be-escaped nil)
342 (modify-syntax-entry ?\n ">")
343 (modify-syntax-entry ?\; "<"))
344(defun \;-out ()
345 (modify-syntax-entry ?\n " ")
346 (modify-syntax-entry ?\; "."))
347(eval-and-compile
348 (setq syntax-comments-section "lisp"))
349
350(syntax-comments \; backward nil 30 30)
351(syntax-comments \; forward t 31)
352(syntax-comments \; backward t 31)
353(syntax-comments \; forward t 32)
354(syntax-comments \; backward t 32)
355(syntax-comments \; forward t 33)
356(syntax-comments \; backward t 33)
357
358;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
359;; Emacs 27 "C" style comments - `comment-end-can-be-escaped' is non-nil.
360;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
361(defun /*-in ()
362 (setq parse-sexp-ignore-comments t)
363 (setq comment-end-can-be-escaped t)
364 (modify-syntax-entry ?/ ". 124b")
365 (modify-syntax-entry ?* ". 23")
366 (modify-syntax-entry ?\n "> b"))
367(defun /*-out ()
368 (setq comment-end-can-be-escaped nil)
369 (modify-syntax-entry ?/ ".")
370 (modify-syntax-entry ?* ".")
371 (modify-syntax-entry ?\n " "))
372(eval-and-compile
373 (setq syntax-comments-section "c"))
374
375(syntax-comments /* forward t 1)
376(syntax-comments /* backward t 1)
377(syntax-comments /* forward t 2)
378(syntax-comments /* backward t 2)
379(syntax-comments /* forward t 3)
380(syntax-comments /* backward t 3)
381
382(syntax-comments /* forward t 4)
383(syntax-comments /* backward t 4)
384(syntax-comments /* forward t 5 6)
385(syntax-comments /* backward nil 5 0)
386(syntax-comments /* forward nil 6 0)
387(syntax-comments /* backward t 6 5)
388
389(syntax-comments /* forward t 7 8)
390(syntax-comments /* backward nil 7 0)
391(syntax-comments /* forward nil 8 0)
392(syntax-comments /* backward t 8 7)
393(syntax-comments /* forward t 9)
394(syntax-comments /* backward t 9)
395
396(syntax-comments /* forward nil 10 0)
397(syntax-comments /* backward nil 10 0)
398(syntax-comments /* forward t 11)
399(syntax-comments /* backward t 11)
400
401(syntax-comments /* forward t 13 14)
402(syntax-comments /* backward nil 13 -14)
403(syntax-comments /* forward t 15)
404(syntax-comments /* backward t 15)
405
406;; Emacs 27 "C" style comments inside brace lists.
407(syntax-br-comments /* forward t 50)
408(syntax-br-comments /* backward t 50)
409(syntax-br-comments /* forward t 51)
410(syntax-br-comments /* backward t 51)
411(syntax-br-comments /* forward t 52)
412(syntax-br-comments /* backward t 52)
413
414(syntax-br-comments /* forward t 53)
415(syntax-br-comments /* backward t 53)
416(syntax-br-comments /* forward t 54 20)
417(syntax-br-comments /* backward t 54)
418(syntax-br-comments /* forward t 55)
419(syntax-br-comments /* backward t 55)
420
421(syntax-br-comments /* forward t 56 58)
422(syntax-br-comments /* backward t 58 56)
423(syntax-br-comments /* backward nil 59)
424(syntax-br-comments /* forward t 60)
425(syntax-br-comments /* backward t 60)
426
427;; Emacs 27 "C" style comments parsed by `parse-partial-sexp'.
428(syntax-pps-comments /* 50 70 71)
429(syntax-pps-comments /* 52 72 73)
430(syntax-pps-comments /* 54 74 55 20)
431(syntax-pps-comments /* 56 76 77 58)
432(syntax-pps-comments /* 60 78 79)
433
85;;; syntax-tests.el ends here 434;;; syntax-tests.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-03-06 08:19:34 +0000