diff options
Diffstat (limited to 'test/src')
39 files changed, 3024 insertions, 303 deletions
diff --git a/test/src/alloc-tests.el b/test/src/alloc-tests.el index e3e2ea184e6..1324c2d3b4d 100644 --- a/test/src/alloc-tests.el +++ b/test/src/alloc-tests.el @@ -51,3 +51,10 @@ (should-not (eq x y)) (dotimes (i 4) (should (eql (aref x i) (aref y i)))))) + +;; Bug#39207 +(ert-deftest aset-nbytes-change () + (let ((s (make-string 1 ?a))) + (dolist (c (list 10003 ?b 128 ?c ?d (max-char) ?e)) + (aset s 0 c) + (should (equal s (make-string 1 c)))))) diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 445a3414cdf..123f2e8eabb 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -19,9 +19,7 @@ ;;; Code: -(require 'ert) -(require 'seq) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (ert-deftest overlay-modification-hooks-message-other-buf () "Test for bug#21824. @@ -1314,4 +1312,53 @@ with parameters from the *Messages* buffer modification." (ovshould nonempty-eob-end 4 5) (ovshould empty-eob 5 5))))) +(ert-deftest buffer-multibyte-overlong-sequences () + (dolist (uni '("\xE0\x80\x80" + "\xF0\x80\x80\x80" + "\xF8\x8F\xBF\xBF\x80")) + (let ((multi (string-to-multibyte uni))) + (should + (string-equal + multi + (with-temp-buffer + (set-buffer-multibyte nil) + (insert uni) + (set-buffer-multibyte t) + (buffer-string))))))) + +;; https://debbugs.gnu.org/33492 +(ert-deftest buffer-tests-buffer-local-variables-undo () + "Test that `buffer-undo-list' appears in `buffer-local-variables'." + (with-temp-buffer + (should (assq 'buffer-undo-list (buffer-local-variables))))) + +(ert-deftest buffer-tests-inhibit-buffer-hooks () + "Test `get-buffer-create' argument INHIBIT-BUFFER-HOOKS." + (let* (run-bluh (bluh (lambda () (setq run-bluh t)))) + (unwind-protect + (let* ( run-kbh (kbh (lambda () (setq run-kbh t))) + run-kbqf (kbqf (lambda () (setq run-kbqf t))) ) + + ;; Inhibited. + (add-hook 'buffer-list-update-hook bluh) + (with-current-buffer (generate-new-buffer " foo" t) + (add-hook 'kill-buffer-hook kbh nil t) + (add-hook 'kill-buffer-query-functions kbqf nil t) + (kill-buffer)) + (with-temp-buffer) + (with-output-to-string) + (should-not run-bluh) + (should-not run-kbh) + (should-not run-kbqf) + + ;; Not inhibited. + (with-current-buffer (generate-new-buffer " foo") + (should run-bluh) + (add-hook 'kill-buffer-hook kbh nil t) + (add-hook 'kill-buffer-query-functions kbqf nil t) + (kill-buffer)) + (should run-kbh) + (should run-kbqf)) + (remove-hook 'buffer-list-update-hook bluh)))) + ;;; buffer-tests.el ends here diff --git a/test/src/callint-tests.el b/test/src/callint-tests.el index a2abac458d1..0df58877102 100644 --- a/test/src/callint-tests.el +++ b/test/src/callint-tests.el @@ -29,7 +29,8 @@ (ert-deftest call-interactively/incomplete-multibyte-sequence () "Check that Bug#30004 is fixed." - (let ((data (should-error (call-interactively (lambda () (interactive "\xFF")))))) + (let* ((text-quoting-style 'grave) + (data (should-error (call-interactively (lambda () (interactive "\xFF")))))) (should (equal (cdr data) diff --git a/test/src/callproc-tests.el b/test/src/callproc-tests.el index 71a4127dadb..7262abbe0d0 100644 --- a/test/src/callproc-tests.el +++ b/test/src/callproc-tests.el @@ -17,6 +17,11 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Unit tests for src/callproc.c. + ;;; Code: (require 'ert) @@ -60,3 +65,15 @@ (call-process "c:/nul.exe") (error :got-error)))) (should have-called-debugger))) + +(ert-deftest call-process-region-entire-buffer-with-delete () + "Check that Bug#40576 is fixed." + (let ((emacs (expand-file-name invocation-name invocation-directory))) + (skip-unless (file-executable-p emacs)) + (with-temp-buffer + (insert "Buffer contents\n") + (should + (eq (call-process-region nil nil emacs :delete nil nil "--version") 0)) + (should (eq (buffer-size) 0))))) + +;;; callproc-tests.el ends here diff --git a/test/src/casefiddle-tests.el b/test/src/casefiddle-tests.el index 714dd8f35d8..9fa54dcaf43 100644 --- a/test/src/casefiddle-tests.el +++ b/test/src/casefiddle-tests.el @@ -247,7 +247,8 @@ ;; input upcase downcase [titlecase] (dolist (test '((?a ?A ?a) (?A ?A ?a) (?ł ?Ł ?ł) (?Ł ?Ł ?ł) - (?ß ?ß ?ß) (?ẞ ?ẞ ?ß) + ;; We char-upcase ß to ẞ; see bug #11309. + (?ß ?ẞ ?ß) (?ẞ ?ẞ ?ß) (?ⅷ ?Ⅷ ?ⅷ) (?Ⅷ ?Ⅷ ?ⅷ) (?DŽ ?DŽ ?dž ?Dž) (?Dž ?DŽ ?dž ?Dž) (?dž ?DŽ ?dž ?Dž))) (let ((ch (car test)) diff --git a/test/src/charset-tests.el b/test/src/charset-tests.el index a97c8b6f1c8..5c46627c163 100644 --- a/test/src/charset-tests.el +++ b/test/src/charset-tests.el @@ -1,19 +1,21 @@ -;;; charset-tests.el --- Tests for charset.c +;;; charset-tests.el --- Tests for charset.c -*- lexical-binding: t -*- ;; Copyright 2017-2021 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/src/chartab-tests.el b/test/src/chartab-tests.el index d96ba0a0615..bf37fb51cf5 100644 --- a/test/src/chartab-tests.el +++ b/test/src/chartab-tests.el @@ -1,21 +1,23 @@ -;;; chartab-tests.el --- Tests for char-tab.c +;;; chartab-tests.el --- Tests for char-tab.c -*- lexical-binding: t -*- ;; Copyright (C) 2016-2021 Free Software Foundation, Inc. ;; Author: Eli Zaretskii <eliz@gnu.org> -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: @@ -47,5 +49,25 @@ (#xe0e00 . #xe0ef6) ))) +(ert-deftest chartab-test-char-table-p () + (should (char-table-p (make-char-table 'foo))) + (should (not (char-table-p (make-hash-table))))) + +(ert-deftest chartab-test-char-table-subtype () + (should (eq (char-table-subtype (make-char-table 'foo)) 'foo))) + +(ert-deftest chartab-test-char-table-parent () + (should (eq (char-table-parent (make-char-table 'foo)) nil)) + (let ((parent (make-char-table 'foo)) + (child (make-char-table 'bar))) + (set-char-table-parent child parent) + (should (eq (char-table-parent child) parent)))) + +(ert-deftest chartab-test-char-table-extra-slot () + ;; Use any type with extra slots, e.g. 'case-table. + (let ((tbl (make-char-table 'case-table))) + (set-char-table-extra-slot tbl 1 'bar) + (should (eq (char-table-extra-slot tbl 1) 'bar)))) + (provide 'chartab-tests) ;;; chartab-tests.el ends here diff --git a/test/src/cmds-tests.el b/test/src/cmds-tests.el index e07289d2264..681bfb30164 100644 --- a/test/src/cmds-tests.el +++ b/test/src/cmds-tests.el @@ -1,22 +1,24 @@ -;;; cmds-tests.el --- Testing some Emacs commands +;;; cmds-tests.el --- Testing some Emacs commands -*- lexical-binding: t -*- ;; Copyright (C) 2013-2021 Free Software Foundation, Inc. ;; Author: Nicolas Richard <youngfrog@members.fsf.org> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/test/src/coding-tests.el b/test/src/coding-tests.el index 4008b510223..0bdcff22ce5 100644 --- a/test/src/coding-tests.el +++ b/test/src/coding-tests.el @@ -1,4 +1,4 @@ -;;; coding-tests.el --- tests for text encoding and decoding +;;; coding-tests.el --- tests for text encoding and decoding -*- lexical-binding: t -*- ;; Copyright (C) 2013-2021 Free Software Foundation, Inc. @@ -296,7 +296,7 @@ ;;; decoder, not for regression testing. (defun generate-ascii-file () - (dotimes (i 100000) + (dotimes (_i 100000) (insert-char ?a 80) (insert "\n"))) @@ -309,13 +309,13 @@ (insert "\n"))) (defun generate-mostly-nonascii-file () - (dotimes (i 30000) + (dotimes (_i 30000) (insert-char ?a 80) (insert "\n")) - (dotimes (i 20000) + (dotimes (_i 20000) (insert-char ?À 80) (insert "\n")) - (dotimes (i 10000) + (dotimes (_i 10000) (insert-char ?あ 80) (insert "\n"))) @@ -375,6 +375,60 @@ (with-temp-buffer (insert-file-contents (car file)))))) (insert (format "%s: %s\n" (car file) result))))))) +(ert-deftest coding-nocopy-trivial () + "Check that the NOCOPY parameter works for the trivial coding system." + (let ((s "abc")) + (should-not (eq (decode-coding-string s nil nil) s)) + (should (eq (decode-coding-string s nil t) s)) + (should-not (eq (encode-coding-string s nil nil) s)) + (should (eq (encode-coding-string s nil t) s)))) + +(ert-deftest coding-nocopy-ascii () + "Check that the NOCOPY parameter works for ASCII-only strings." + (let* ((uni (apply #'string (number-sequence 0 127))) + (multi (string-to-multibyte uni))) + (dolist (s (list uni multi)) + ;; Encodings without EOL conversion. + (dolist (coding '(us-ascii-unix iso-latin-1-unix utf-8-unix)) + (should-not (eq (decode-coding-string s coding nil) s)) + (should-not (eq (encode-coding-string s coding nil) s)) + (should (eq (decode-coding-string s coding t) s)) + (should (eq (encode-coding-string s coding t) s)) + (should (eq last-coding-system-used coding))) + + ;; With EOL conversion inhibited. + (let ((inhibit-eol-conversion t)) + (dolist (coding '(us-ascii iso-latin-1 utf-8)) + (should-not (eq (decode-coding-string s coding nil) s)) + (should-not (eq (encode-coding-string s coding nil) s)) + (should (eq (decode-coding-string s coding t) s)) + (should (eq (encode-coding-string s coding t) s)))))) + + ;; Check identity decoding with EOL conversion for ASCII except CR. + (let* ((uni (apply #'string (delq ?\r (number-sequence 0 127)))) + (multi (string-to-multibyte uni))) + (dolist (s (list uni multi)) + (dolist (coding '(us-ascii-dos iso-latin-1-dos utf-8-dos mac-roman-mac)) + (should-not (eq (decode-coding-string s coding nil) s)) + (should (eq (decode-coding-string s coding t) s))))) + + ;; Check identity encoding with EOL conversion for ASCII except LF. + (let* ((uni (apply #'string (delq ?\n (number-sequence 0 127)))) + (multi (string-to-multibyte uni))) + (dolist (s (list uni multi)) + (dolist (coding '(us-ascii-dos iso-latin-1-dos utf-8-dos mac-roman-mac)) + (should-not (eq (encode-coding-string s coding nil) s)) + (should (eq (encode-coding-string s coding t) s)))))) + + +(ert-deftest coding-check-coding-systems-region () + (should (equal (check-coding-systems-region "aå" nil '(utf-8)) + nil)) + (should (equal (check-coding-systems-region "aåbγc" nil + '(utf-8 iso-latin-1 us-ascii)) + '((iso-latin-1 3) (us-ascii 1 3)))) + (should-error (check-coding-systems-region "å" nil '(bad-coding-system)))) + ;; Local Variables: ;; byte-compile-warnings: (not obsolete) ;; End: diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 33b206d8cf3..03d867f18a8 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -324,7 +324,7 @@ comparing the subr with a much slower lisp implementation." (defvar binding-test-some-local 'some) (with-current-buffer binding-test-buffer-A - (set (make-local-variable 'binding-test-some-local) 'local)) + (setq-local binding-test-some-local 'local)) (ert-deftest binding-test-manual () "A test case from the elisp manual." @@ -345,6 +345,25 @@ comparing the subr with a much slower lisp implementation." (setq-default binding-test-some-local 'new-default)) (should (eq binding-test-some-local 'some)))) +(ert-deftest data-tests--let-buffer-local () + (let ((blvar (make-symbol "blvar"))) + (set-default blvar nil) + (make-variable-buffer-local blvar) + + (dolist (var (list blvar 'left-margin)) + (let ((def (default-value var))) + (with-temp-buffer + (should (equal def (symbol-value var))) + (cl-progv (list var) (list 42) + (should (equal (symbol-value var) 42)) + (should (equal (default-value var) (symbol-value var))) + (set var 123) + (should (equal (symbol-value var) 123)) + (should (equal (default-value var) (symbol-value var)))) ;bug#44733 + (should (equal (symbol-value var) def)) + (should (equal (default-value var) (symbol-value var)))) + (should (equal (default-value var) def)))))) + (ert-deftest binding-test-makunbound () "Tests of makunbound, from the manual." (with-current-buffer binding-test-buffer-B @@ -381,6 +400,37 @@ comparing the subr with a much slower lisp implementation." "Test setting a keyword to itself" (with-no-warnings (should (setq :keyword :keyword)))) +(ert-deftest data-tests--set-default-per-buffer () + :expected-result t ;; Not fixed yet! + ;; FIXME: Performance tests are inherently unreliable. + ;; Using wall-clock time makes it even worse, so don't bother unless + ;; we have the primitive to measure cpu-time. + (skip-unless (fboundp 'current-cpu-time)) + ;; Test performance of set-default on DEFVAR_PER_BUFFER variables. + ;; More specifically, test the problem seen in bug#41029 where setting + ;; the default value of a variable takes time proportional to the + ;; number of buffers. + (let* ((fun #'error) + (test (lambda () + (with-temp-buffer + (let ((st (car (current-cpu-time)))) + (dotimes (_ 1000) + (let ((case-fold-search 'data-test)) + ;; Use an indirection through a mutable var + ;; to try and make sure the byte-compiler + ;; doesn't optimize away the let bindings. + (funcall fun))) + ;; FIXME: Handle the wraparound, if any. + (- (car (current-cpu-time)) st))))) + (_ (setq fun #'ignore)) + (time1 (funcall test)) + (bufs (mapcar (lambda (_) (generate-new-buffer " data-test")) + (make-list 1000 nil))) + (time2 (funcall test))) + (mapc #'kill-buffer bufs) + ;; Don't divide one time by the other since they may be 0. + (should (< time2 (* time1 5))))) + ;; More tests to write - ;; kill-local-variable ;; defconst; can modify diff --git a/test/src/decompress-tests.el b/test/src/decompress-tests.el index 3ada74be5c4..67a7fefb05e 100644 --- a/test/src/decompress-tests.el +++ b/test/src/decompress-tests.el @@ -1,4 +1,4 @@ -;;; decompress-tests.el --- Test suite for decompress. +;;; decompress-tests.el --- Test suite for decompress. -*- lexical-binding: t -*- ;; Copyright (C) 2013-2021 Free Software Foundation, Inc. diff --git a/test/src/doc-tests.el b/test/src/doc-tests.el deleted file mode 100644 index 107785945de..00000000000 --- a/test/src/doc-tests.el +++ /dev/null @@ -1,96 +0,0 @@ -;;; doc-tests.el --- Tests for doc.c - -;; Copyright (C) 2016-2021 Free Software Foundation, Inc. - -;; Author: Eli Zaretskii <eliz@gnu.org> - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. - -;;; Code: - -(require 'ert) - -(ert-deftest doc-test-substitute-command-keys () - ;; Bindings. - (should (string= (substitute-command-keys "foo \\[goto-char]") "foo M-g c")) - ;; Cannot use string= here, as that compares unibyte and multibyte - ;; strings not equal. - (should (compare-strings - (substitute-command-keys "\200 \\[goto-char]") nil nil - "\200 M-g c" nil nil)) - ;; Literals. - (should (string= (substitute-command-keys "foo \\=\\[goto-char]") - "foo \\[goto-char]")) - (should (string= (substitute-command-keys "foo \\=\\=") - "foo \\=")) - ;; Keymaps. - ;; I don't see that this is testing anything useful. - ;; AFAICS all it does it fail whenever someone modifies the - ;; minibuffer map. -;;; (should (string= (substitute-command-keys -;;; "\\{minibuffer-local-must-match-map}") -;;; "\ -;;; key binding -;;; --- ------- -;;; -;;; C-g abort-recursive-edit -;;; TAB minibuffer-complete -;;; C-j minibuffer-complete-and-exit -;;; RET minibuffer-complete-and-exit -;;; ESC Prefix Command -;;; SPC minibuffer-complete-word -;;; ? minibuffer-completion-help -;;; <C-tab> file-cache-minibuffer-complete -;;; <XF86Back> previous-history-element -;;; <XF86Forward> next-history-element -;;; <down> next-line-or-history-element -;;; <next> next-history-element -;;; <prior> switch-to-completions -;;; <up> previous-line-or-history-element -;;; -;;; M-v switch-to-completions -;;; -;;; M-< minibuffer-beginning-of-buffer -;;; M-n next-history-element -;;; M-p previous-history-element -;;; M-r previous-matching-history-element -;;; M-s next-matching-history-element -;;; -;;; ")) - (should (string= - (substitute-command-keys - "\\<minibuffer-local-must-match-map>\\[abort-recursive-edit]") - "C-g")) - ;; Allow any style of quotes, since the terminal might not support - ;; UTF-8. - (should (string-match - "\nUses keymap [`‘']foobar-map['’], which is not currently defined.\n" - (substitute-command-keys "\\{foobar-map}"))) - ;; Quotes. - (should (let ((text-quoting-style 'grave)) - (string= (substitute-command-keys "quotes `like this'") - "quotes `like this'"))) - (should (let ((text-quoting-style 'grave)) - (string= (substitute-command-keys "quotes ‘like this’") - "quotes ‘like this’"))) - (should (let ((text-quoting-style 'straight)) - (string= (substitute-command-keys "quotes `like this'") - "quotes 'like this'"))) - ;; Bugs. - (should (string= (substitute-command-keys "\\[foobar") "\\[foobar")) - (should (string= (substitute-command-keys "\\=") "\\=")) - ) - -(provide 'doc-tests) -;;; doc-tests.el ends here diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index fa5d04ee962..64f9137865b 100644 --- a/test/src/editfns-tests.el +++ b/test/src/editfns-tests.el @@ -1,21 +1,21 @@ -;;; editfns-tests.el -- tests for editfns.c +;;; editfns-tests.el -- tests for editfns.c -*- lexical-binding:t -*- ;; Copyright (C) 2016-2021 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. -;; This program is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: @@ -124,8 +124,8 @@ "Validate character position to byte position translation." (let ((bytes '())) (dotimes (pos len) - (setq bytes (add-to-list 'bytes (position-bytes (1+ pos)) t))) - bytes)) + (push (position-bytes (1+ pos)) bytes)) + (nreverse bytes))) (ert-deftest transpose-ascii-regions-test () (with-temp-buffer diff --git a/test/src/emacs-module-resources/mod-test.c b/test/src/emacs-module-resources/mod-test.c new file mode 100644 index 00000000000..ad59cfc18cd --- /dev/null +++ b/test/src/emacs-module-resources/mod-test.c @@ -0,0 +1,847 @@ +/* Test GNU Emacs modules. + +Copyright 2015-2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ + +#include "config.h" + +#undef NDEBUG +#include <assert.h> + +#include <errno.h> +#include <limits.h> +#include <stdbool.h> +#include <stdint.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <time.h> + +#ifdef WINDOWSNT +/* Cannot include <process.h> because of the local header by the same + name, sigh. */ +uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *); +# if !defined __x86_64__ +# define ALIGN_STACK __attribute__((force_align_arg_pointer)) +# endif +# include <windows.h> /* for Sleep */ +#else /* !WINDOWSNT */ +# include <pthread.h> +# include <unistd.h> +#endif + +#include <gmp.h> +#include <emacs-module.h> + +#include "timespec.h" + +int plugin_is_GPL_compatible; + +#if INTPTR_MAX <= 0 +# error "INTPTR_MAX misconfigured" +#elif INTPTR_MAX <= INT_MAX || INTPTR_MAX <= LONG_MAX +# define pT "ld" +# define pZ "lu" +# define T_TYPE long +# define Z_TYPE unsigned long +#elif INTPTR_MAX <= INT64_MAX +# ifdef __MINGW32__ +# define pT "lld" +# define pZ "llu" +# define T_TYPE long long +# define Z_TYPE unsigned long long +# else +# define pT "ld" +# define pZ "lu" +# define T_TYPE long +# define Z_TYPE unsigned long +# endif +#else +# error "INTPTR_MAX too large" +#endif + +/* Smoke test to verify that EMACS_LIMB_MAX is defined. */ +_Static_assert (0 < EMACS_LIMB_MAX, "EMACS_LIMB_MAX missing or incorrect"); + +/* Always return symbol 't'. */ +static emacs_value +Fmod_test_return_t (emacs_env *env, ptrdiff_t nargs, emacs_value args[], + void *data) +{ + return env->intern (env, "t"); +} + +/* Expose simple sum function. */ +static intmax_t +sum (intmax_t a, intmax_t b) +{ + return a + b; +} + +static emacs_value +Fmod_test_sum (emacs_env *env, ptrdiff_t nargs, emacs_value args[], void *data) +{ + assert (nargs == 2); + assert ((uintptr_t) data == 0x1234); + + intmax_t a = env->extract_integer (env, args[0]); + intmax_t b = env->extract_integer (env, args[1]); + + intmax_t r = sum (a, b); + + return env->make_integer (env, r); +} + + +/* Signal '(error 56). */ +static emacs_value +Fmod_test_signal (emacs_env *env, ptrdiff_t nargs, emacs_value args[], + void *data) +{ + assert (env->non_local_exit_check (env) == emacs_funcall_exit_return); + env->non_local_exit_signal (env, env->intern (env, "error"), + env->make_integer (env, 56)); + return NULL; +} + + +/* Throw '(tag 65). */ +static emacs_value +Fmod_test_throw (emacs_env *env, ptrdiff_t nargs, emacs_value args[], + void *data) +{ + assert (env->non_local_exit_check (env) == emacs_funcall_exit_return); + env->non_local_exit_throw (env, env->intern (env, "tag"), + env->make_integer (env, 65)); + return NULL; +} + + +/* Call argument function, catch all non-local exists and return + either normal result or a list describing the non-local exit. */ +static emacs_value +Fmod_test_non_local_exit_funcall (emacs_env *env, ptrdiff_t nargs, + emacs_value args[], void *data) +{ + assert (nargs == 1); + emacs_value result = env->funcall (env, args[0], 0, NULL); + emacs_value non_local_exit_symbol, non_local_exit_data; + enum emacs_funcall_exit code + = env->non_local_exit_get (env, &non_local_exit_symbol, + &non_local_exit_data); + switch (code) + { + case emacs_funcall_exit_return: + return result; + case emacs_funcall_exit_signal: + { + env->non_local_exit_clear (env); + emacs_value Flist = env->intern (env, "list"); + emacs_value list_args[] = {env->intern (env, "signal"), + non_local_exit_symbol, non_local_exit_data}; + return env->funcall (env, Flist, 3, list_args); + } + case emacs_funcall_exit_throw: + { + env->non_local_exit_clear (env); + emacs_value Flist = env->intern (env, "list"); + emacs_value list_args[] = {env->intern (env, "throw"), + non_local_exit_symbol, non_local_exit_data}; + return env->funcall (env, Flist, 3, list_args); + } + } + + /* Never reached. */ + return env->intern (env, "nil");; +} + + +/* Return a global reference. */ +static emacs_value +Fmod_test_globref_make (emacs_env *env, ptrdiff_t nargs, emacs_value args[], + void *data) +{ + /* Make a big string and make it global. */ + char str[26 * 100]; + for (int i = 0; i < sizeof str; i++) + str[i] = 'a' + (i % 26); + + /* We don't need to null-terminate str. */ + emacs_value lisp_str = env->make_string (env, str, sizeof str); + return env->make_global_ref (env, lisp_str); +} + +/* Create a few global references from arguments and free them. */ +static emacs_value +Fmod_test_globref_free (emacs_env *env, ptrdiff_t nargs, emacs_value args[], + void *data) +{ + emacs_value refs[10]; + for (int i = 0; i < 10; i++) + { + refs[i] = env->make_global_ref (env, args[i % nargs]); + } + for (int i = 0; i < 10; i++) + { + env->free_global_ref (env, refs[i]); + } + return env->intern (env, "ok"); +} + +/* Treat a local reference as global and free it. Module assertions + should detect this case even if a global reference representing the + same object also exists. */ + +static emacs_value +Fmod_test_globref_invalid_free (emacs_env *env, ptrdiff_t nargs, + emacs_value *args, void *data) +{ + emacs_value local = env->make_integer (env, 9876); + env->make_global_ref (env, local); + env->free_global_ref (env, local); /* Not allowed. */ + return env->intern (env, "nil"); +} + +/* Allocate and free global references in a different order. */ + +static emacs_value +Fmod_test_globref_reordered (emacs_env *env, ptrdiff_t nargs, + emacs_value *args, void *data) +{ + emacs_value booleans[2] = { + env->intern (env, "nil"), + env->intern (env, "t"), + }; + emacs_value local = env->intern (env, "foo"); + emacs_value globals[4] = { + env->make_global_ref (env, local), + env->make_global_ref (env, local), + env->make_global_ref (env, env->intern (env, "foo")), + env->make_global_ref (env, env->intern (env, "bar")), + }; + emacs_value elements[4]; + for (int i = 0; i < 4; ++i) + elements[i] = booleans[env->eq (env, globals[i], local)]; + emacs_value ret = env->funcall (env, env->intern (env, "list"), 4, elements); + env->free_global_ref (env, globals[2]); + env->free_global_ref (env, globals[1]); + env->free_global_ref (env, globals[3]); + env->free_global_ref (env, globals[0]); + return ret; +} + + +/* Return a copy of the argument string where every 'a' is replaced + with 'b'. */ +static emacs_value +Fmod_test_string_a_to_b (emacs_env *env, ptrdiff_t nargs, emacs_value args[], + void *data) +{ + emacs_value lisp_str = args[0]; + ptrdiff_t size = 0; + char * buf = NULL; + + env->copy_string_contents (env, lisp_str, buf, &size); + buf = malloc (size); + env->copy_string_contents (env, lisp_str, buf, &size); + + for (ptrdiff_t i = 0; i + 1 < size; i++) + if (buf[i] == 'a') + buf[i] = 'b'; + + emacs_value ret = env->make_string (env, buf, size - 1); + free (buf); + return ret; +} + + +/* Return a unibyte string. */ +static emacs_value +Fmod_test_return_unibyte (emacs_env *env, ptrdiff_t nargs, emacs_value args[], + void *data) +{ + const char *string = "foo\x00zot"; + return env->make_unibyte_string (env, string, 7); +} + + +/* Embedded pointers in lisp objects. */ + +/* C struct (pointer to) that will be embedded. */ +struct super_struct +{ + int amazing_int; + char large_unused_buffer[512]; +}; + +/* Return a new user-pointer to a super_struct, with amazing_int set + to the passed parameter. */ +static emacs_value +Fmod_test_userptr_make (emacs_env *env, ptrdiff_t nargs, emacs_value args[], + void *data) +{ + struct super_struct *p = calloc (1, sizeof *p); + p->amazing_int = env->extract_integer (env, args[0]); + return env->make_user_ptr (env, free, p); +} + +/* Return the amazing_int of a passed 'user-pointer to a super_struct'. */ +static emacs_value +Fmod_test_userptr_get (emacs_env *env, ptrdiff_t nargs, emacs_value args[], + void *data) +{ + struct super_struct *p = env->get_user_ptr (env, args[0]); + return env->make_integer (env, p->amazing_int); +} + + +/* Fill vector in args[0] with value in args[1]. */ +static emacs_value +Fmod_test_vector_fill (emacs_env *env, ptrdiff_t nargs, emacs_value args[], + void *data) +{ + emacs_value vec = args[0]; + emacs_value val = args[1]; + ptrdiff_t size = env->vec_size (env, vec); + for (ptrdiff_t i = 0; i < size; i++) + env->vec_set (env, vec, i, val); + return env->intern (env, "t"); +} + + +/* Return whether all elements of vector in args[0] are 'eq' to value + in args[1]. */ +static emacs_value +Fmod_test_vector_eq (emacs_env *env, ptrdiff_t nargs, emacs_value args[], + void *data) +{ + emacs_value vec = args[0]; + emacs_value val = args[1]; + ptrdiff_t size = env->vec_size (env, vec); + for (ptrdiff_t i = 0; i < size; i++) + if (!env->eq (env, env->vec_get (env, vec, i), val)) + return env->intern (env, "nil"); + return env->intern (env, "t"); +} + +static emacs_value invalid_stored_value; + +/* The next two functions perform a possibly-invalid operation: they + store a value in a static variable and load it. This causes + undefined behavior if the environment that the value was created + from is no longer live. The module assertions check for this + error. */ + +static emacs_value +Fmod_test_invalid_store (emacs_env *env, ptrdiff_t nargs, emacs_value *args, + void *data) +{ + return invalid_stored_value = env->make_integer (env, 123); +} + +static emacs_value +Fmod_test_invalid_load (emacs_env *env, ptrdiff_t nargs, emacs_value *args, + void *data) +{ + return invalid_stored_value; +} + +/* The next function works in conjunction with the two previous ones. + It stows away a copy of the object created by + `Fmod_test_invalid_store' in a global reference. Module assertions + should still detect the invalid load of the local reference. */ + +static emacs_value global_copy_of_invalid_stored_value; + +static emacs_value +Fmod_test_invalid_store_copy (emacs_env *env, ptrdiff_t nargs, + emacs_value *args, void *data) +{ + emacs_value local = Fmod_test_invalid_store (env, 0, NULL, NULL); + return global_copy_of_invalid_stored_value + = env->make_global_ref (env, local); +} + +/* An invalid finalizer: Finalizers are run during garbage collection, + where Lisp code can't be executed. -module-assertions tests for + this case. */ + +static emacs_env *current_env; + +static void +invalid_finalizer (void *ptr) +{ + current_env->intern (current_env, "nil"); +} + +static emacs_value +Fmod_test_invalid_finalizer (emacs_env *env, ptrdiff_t nargs, emacs_value *args, + void *data) +{ + current_env = env; + env->make_user_ptr (env, invalid_finalizer, NULL); + return env->intern (env, "nil"); +} + +static void +signal_system_error (emacs_env *env, int error, const char *function) +{ + const char *message = strerror (error); + emacs_value message_value = env->make_string (env, message, strlen (message)); + emacs_value symbol = env->intern (env, "file-error"); + emacs_value elements[2] + = {env->make_string (env, function, strlen (function)), message_value}; + emacs_value data = env->funcall (env, env->intern (env, "list"), 2, elements); + env->non_local_exit_signal (env, symbol, data); +} + +static void +signal_errno (emacs_env *env, const char *function) +{ + signal_system_error (env, errno, function); +} + +/* A long-running operation that occasionally calls `should_quit' or + `process_input'. */ + +static emacs_value +Fmod_test_sleep_until (emacs_env *env, ptrdiff_t nargs, emacs_value *args, + void *data) +{ + assert (nargs == 2); + const struct timespec until = env->extract_time (env, args[0]); + if (env->non_local_exit_check (env)) + return NULL; + const bool process_input = env->is_not_nil (env, args[1]); + const struct timespec amount = make_timespec(0, 10000000); + while (true) + { + const struct timespec now = current_timespec (); + if (timespec_cmp (now, until) >= 0) + break; + if (nanosleep (&amount, NULL) && errno != EINTR) + { + signal_errno (env, "nanosleep"); + return NULL; + } + if ((process_input + && env->process_input (env) == emacs_process_input_quit) + || env->should_quit (env)) + return NULL; + } + return env->intern (env, "finished"); +} + +static emacs_value +Fmod_test_add_nanosecond (emacs_env *env, ptrdiff_t nargs, emacs_value *args, + void *data) +{ + assert (nargs == 1); + struct timespec time = env->extract_time (env, args[0]); + assert (time.tv_nsec >= 0); + assert (time.tv_nsec < 2000000000); /* possible leap second */ + time.tv_nsec++; + return env->make_time (env, time); +} + +static void +signal_error (emacs_env *env, const char *message) +{ + emacs_value data = env->make_string (env, message, strlen (message)); + env->non_local_exit_signal (env, env->intern (env, "error"), + env->funcall (env, env->intern (env, "list"), 1, + &data)); +} + +static void +memory_full (emacs_env *env) +{ + signal_error (env, "Memory exhausted"); +} + +enum +{ + max_count = ((SIZE_MAX < PTRDIFF_MAX ? SIZE_MAX : PTRDIFF_MAX) + / sizeof (emacs_limb_t)) +}; + +static bool +extract_big_integer (emacs_env *env, emacs_value arg, mpz_t result) +{ + int sign; + ptrdiff_t count; + bool success = env->extract_big_integer (env, arg, &sign, &count, NULL); + if (!success) + return false; + if (sign == 0) + { + mpz_set_ui (result, 0); + return true; + } + enum { order = -1, size = sizeof (emacs_limb_t), endian = 0, nails = 0 }; + assert (0 < count && count <= max_count); + emacs_limb_t *magnitude = malloc (count * size); + if (magnitude == NULL) + { + memory_full (env); + return false; + } + success = env->extract_big_integer (env, arg, NULL, &count, magnitude); + assert (success); + mpz_import (result, count, order, size, endian, nails, magnitude); + free (magnitude); + if (sign < 0) + mpz_neg (result, result); + return true; +} + +static emacs_value +make_big_integer (emacs_env *env, const mpz_t value) +{ + if (mpz_sgn (value) == 0) + return env->make_integer (env, 0); + /* See + https://gmplib.org/manual/Integer-Import-and-Export.html#index-Export. */ + enum + { + order = -1, + size = sizeof (emacs_limb_t), + endian = 0, + nails = 0, + numb = 8 * size - nails + }; + size_t count = (mpz_sizeinbase (value, 2) + numb - 1) / numb; + if (max_count < count) + { + memory_full (env); + return NULL; + } + emacs_limb_t *magnitude = malloc (count * size); + if (magnitude == NULL) + { + memory_full (env); + return NULL; + } + size_t written; + mpz_export (magnitude, &written, order, size, endian, nails, value); + assert (written == count); + assert (count <= PTRDIFF_MAX); + emacs_value result = env->make_big_integer (env, mpz_sgn (value), + (ptrdiff_t) count, magnitude); + free (magnitude); + return result; +} + +static emacs_value +Fmod_test_nanoseconds (emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { + assert (nargs == 1); + struct timespec time = env->extract_time (env, args[0]); + mpz_t nanoseconds; + assert (LONG_MIN <= time.tv_sec && time.tv_sec <= LONG_MAX); + mpz_init_set_si (nanoseconds, time.tv_sec); +#ifdef __MINGW32__ + _Static_assert (1000000000 <= ULONG_MAX, "unsupported architecture"); +#else + static_assert (1000000000 <= ULONG_MAX, "unsupported architecture"); +#endif + mpz_mul_ui (nanoseconds, nanoseconds, 1000000000); + assert (0 <= time.tv_nsec && time.tv_nsec <= ULONG_MAX); + mpz_add_ui (nanoseconds, nanoseconds, time.tv_nsec); + emacs_value result = make_big_integer (env, nanoseconds); + mpz_clear (nanoseconds); + return result; +} + +static emacs_value +Fmod_test_double (emacs_env *env, ptrdiff_t nargs, emacs_value *args, + void *data) +{ + assert (nargs == 1); + emacs_value arg = args[0]; + mpz_t value; + mpz_init (value); + extract_big_integer (env, arg, value); + mpz_mul_ui (value, value, 2); + emacs_value result = make_big_integer (env, value); + mpz_clear (value); + return result; +} + +static int function_data; +static int finalizer_calls_with_correct_data; +static int finalizer_calls_with_incorrect_data; + +static void +finalizer (void *data) +{ + if (data == &function_data) + ++finalizer_calls_with_correct_data; + else + ++finalizer_calls_with_incorrect_data; +} + +static emacs_value +Fmod_test_make_function_with_finalizer (emacs_env *env, ptrdiff_t nargs, + emacs_value *args, void *data) +{ + emacs_value fun + = env->make_function (env, 2, 2, Fmod_test_sum, NULL, &function_data); + env->set_function_finalizer (env, fun, finalizer); + if (env->get_function_finalizer (env, fun) != finalizer) + signal_error (env, "Invalid finalizer"); + return fun; +} + +static emacs_value +Fmod_test_function_finalizer_calls (emacs_env *env, ptrdiff_t nargs, + emacs_value *args, void *data) +{ + emacs_value Flist = env->intern (env, "list"); + emacs_value list_args[] + = {env->make_integer (env, finalizer_calls_with_correct_data), + env->make_integer (env, finalizer_calls_with_incorrect_data)}; + return env->funcall (env, Flist, 2, list_args); +} + +static void +sleep_for_half_second (void) +{ + /* mingw.org's MinGW has nanosleep, but MinGW64 doesn't. */ +#ifdef WINDOWSNT + Sleep (500); +#else + const struct timespec sleep = {0, 500000000}; + if (nanosleep (&sleep, NULL) != 0) + perror ("nanosleep"); +#endif +} + +#ifdef WINDOWSNT +static void ALIGN_STACK +#else +static void * +#endif +write_to_pipe (void *arg) +{ + /* We sleep a bit to test that writing to a pipe is indeed possible + if no environment is active. */ + sleep_for_half_second (); + FILE *stream = arg; + /* The string below should be identical to the one we compare with + in emacs-module-tests.el:module/async-pipe. */ + if (fputs ("data from thread", stream) < 0) + perror ("fputs"); + if (fclose (stream) != 0) + perror ("close"); +#ifndef WINDOWSNT + return NULL; +#endif +} + +static emacs_value +Fmod_test_async_pipe (emacs_env *env, ptrdiff_t nargs, emacs_value *args, + void *data) +{ + assert (nargs == 1); + int fd = env->open_channel (env, args[0]); + if (env->non_local_exit_check (env) != emacs_funcall_exit_return) + return NULL; + FILE *stream = fdopen (fd, "w"); + if (stream == NULL) + { + signal_errno (env, "fdopen"); + return NULL; + } +#ifdef WINDOWSNT + uintptr_t thd = _beginthread (write_to_pipe, 0, stream); + int error = (thd == (uintptr_t)-1L) ? errno : 0; +#else /* !WINDOWSNT */ + pthread_t thread; + int error + = pthread_create (&thread, NULL, write_to_pipe, stream); +#endif + if (error != 0) + { + signal_system_error (env, error, "thread create"); + if (fclose (stream) != 0) + perror ("fclose"); + return NULL; + } + return env->intern (env, "nil"); +} + +static emacs_value +Fmod_test_identity (emacs_env *env, ptrdiff_t nargs, emacs_value *args, + void *data) +{ + assert (nargs == 1); + return args[0]; +} + +static emacs_value +Fmod_test_funcall (emacs_env *env, ptrdiff_t nargs, emacs_value *args, + void *data) +{ + assert (0 < nargs); + return env->funcall (env, args[0], nargs - 1, args + 1); +} + +static emacs_value +Fmod_test_make_string (emacs_env *env, ptrdiff_t nargs, + emacs_value *args, void *data) +{ + assert (nargs == 2); + intmax_t length_arg = env->extract_integer (env, args[0]); + if (env->non_local_exit_check (env) != emacs_funcall_exit_return) + return args[0]; + if (length_arg < 0 || SIZE_MAX < length_arg) + { + signal_error (env, "Invalid string length"); + return args[0]; + } + size_t length = (size_t) length_arg; + bool multibyte = env->is_not_nil (env, args[1]); + char *buffer = length == 0 ? NULL : malloc (length); + if (buffer == NULL && length != 0) + { + memory_full (env); + return args[0]; + } + memset (buffer, 'a', length); + emacs_value ret = multibyte ? env->make_string (env, buffer, length) + : env->make_unibyte_string (env, buffer, length); + free (buffer); + return ret; +} + +/* Lisp utilities for easier readability (simple wrappers). */ + +/* Provide FEATURE to Emacs. */ +static void +provide (emacs_env *env, const char *feature) +{ + emacs_value Qfeat = env->intern (env, feature); + emacs_value Qprovide = env->intern (env, "provide"); + emacs_value args[] = { Qfeat }; + + env->funcall (env, Qprovide, 1, args); +} + +/* Bind NAME to FUN. */ +static void +bind_function (emacs_env *env, const char *name, emacs_value Sfun) +{ + emacs_value Qdefalias = env->intern (env, "defalias"); + emacs_value Qsym = env->intern (env, name); + emacs_value args[] = { Qsym, Sfun }; + + env->funcall (env, Qdefalias, 2, args); +} + +/* Module init function. */ +int +emacs_module_init (struct emacs_runtime *ert) +{ + /* Check that EMACS_MAJOR_VERSION is defined and an integral + constant. */ + char dummy[EMACS_MAJOR_VERSION]; + assert (27 <= sizeof dummy); + + if (ert->size < sizeof *ert) + { + fprintf (stderr, "Runtime size of runtime structure (%"pT" bytes) " + "smaller than compile-time size (%"pZ" bytes)", + (T_TYPE) ert->size, (Z_TYPE) sizeof (*ert)); + return 1; + } + + emacs_env *env = ert->get_environment (ert); + + if (env->size < sizeof *env) + { + fprintf (stderr, "Runtime size of environment structure (%"pT" bytes) " + "smaller than compile-time size (%"pZ" bytes)", + (T_TYPE) env->size, (Z_TYPE) sizeof (*env)); + return 2; + } + +#define DEFUN(lsym, csym, amin, amax, doc, data) \ + bind_function (env, lsym, \ + env->make_function (env, amin, amax, csym, doc, data)) + + DEFUN ("mod-test-return-t", Fmod_test_return_t, 1, 1, NULL, NULL); + DEFUN ("mod-test-sum", Fmod_test_sum, 2, 2, "Return A + B\n\n(fn a b)", + (void *) (uintptr_t) 0x1234); + DEFUN ("mod-test-signal", Fmod_test_signal, 0, 0, NULL, NULL); + DEFUN ("mod-test-throw", Fmod_test_throw, 0, 0, NULL, NULL); + DEFUN ("mod-test-non-local-exit-funcall", Fmod_test_non_local_exit_funcall, + 1, 1, NULL, NULL); + DEFUN ("mod-test-globref-make", Fmod_test_globref_make, 0, 0, NULL, NULL); + DEFUN ("mod-test-globref-free", Fmod_test_globref_free, 4, 4, NULL, NULL); + DEFUN ("mod-test-globref-invalid-free", Fmod_test_globref_invalid_free, 0, 0, + NULL, NULL); + DEFUN ("mod-test-globref-reordered", Fmod_test_globref_reordered, 0, 0, NULL, + NULL); + DEFUN ("mod-test-string-a-to-b", Fmod_test_string_a_to_b, 1, 1, NULL, NULL); + DEFUN ("mod-test-return-unibyte", Fmod_test_return_unibyte, 0, 0, NULL, NULL); + DEFUN ("mod-test-userptr-make", Fmod_test_userptr_make, 1, 1, NULL, NULL); + DEFUN ("mod-test-userptr-get", Fmod_test_userptr_get, 1, 1, NULL, NULL); + DEFUN ("mod-test-vector-fill", Fmod_test_vector_fill, 2, 2, NULL, NULL); + DEFUN ("mod-test-vector-eq", Fmod_test_vector_eq, 2, 2, NULL, NULL); + DEFUN ("mod-test-invalid-store", Fmod_test_invalid_store, 0, 0, NULL, NULL); + DEFUN ("mod-test-invalid-store-copy", Fmod_test_invalid_store_copy, 0, 0, + NULL, NULL); + DEFUN ("mod-test-invalid-load", Fmod_test_invalid_load, 0, 0, NULL, NULL); + DEFUN ("mod-test-invalid-finalizer", Fmod_test_invalid_finalizer, 0, 0, + NULL, NULL); + DEFUN ("mod-test-sleep-until", Fmod_test_sleep_until, 2, 2, NULL, NULL); + DEFUN ("mod-test-add-nanosecond", Fmod_test_add_nanosecond, 1, 1, NULL, NULL); + DEFUN ("mod-test-nanoseconds", Fmod_test_nanoseconds, 1, 1, NULL, NULL); + DEFUN ("mod-test-double", Fmod_test_double, 1, 1, NULL, NULL); + DEFUN ("mod-test-make-function-with-finalizer", + Fmod_test_make_function_with_finalizer, 0, 0, NULL, NULL); + DEFUN ("mod-test-function-finalizer-calls", + Fmod_test_function_finalizer_calls, 0, 0, NULL, NULL); + DEFUN ("mod-test-async-pipe", Fmod_test_async_pipe, 1, 1, NULL, NULL); + DEFUN ("mod-test-funcall", Fmod_test_funcall, 1, emacs_variadic_function, + NULL, NULL); + DEFUN ("mod-test-make-string", Fmod_test_make_string, 2, 2, NULL, NULL); + +#undef DEFUN + + emacs_value constant_fn + = env->make_function (env, 0, 0, Fmod_test_return_t, NULL, NULL); + env->make_interactive (env, constant_fn, env->intern (env, "nil")); + bind_function (env, "mod-test-return-t-int", constant_fn); + + emacs_value identity_fn + = env->make_function (env, 1, 1, Fmod_test_identity, NULL, NULL); + const char *interactive_spec = "i"; + env->make_interactive (env, identity_fn, + env->make_string (env, interactive_spec, + strlen (interactive_spec))); + bind_function (env, "mod-test-identity", identity_fn); + + /* We allocate lots of values to trigger bugs in the frame allocator during + initialization. */ + int count = 10000; /* larger than value_frame_size in emacs-module.c */ + for (int i = 0; i < count; ++i) + env->make_integer (env, i); + + provide (env, "mod-test"); + return 0; +} diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 23fa46958a1..af5bc2a0baf 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -21,21 +21,23 @@ ;; Unit tests for the dynamic module facility. See Info node `(elisp) ;; Writing Dynamic Modules'. These tests make use of a small test -;; module in test/data/emacs-module. +;; module in the "emacs-module-resources" directory. ;;; Code: +;;; Prelude (require 'cl-lib) (require 'ert) +(require 'ert-x) (require 'help-fns) +(require 'subr-x) (defconst mod-test-emacs (expand-file-name invocation-name invocation-directory) "File name of the Emacs binary currently running.") (eval-and-compile - (defconst mod-test-file - (expand-file-name "../test/data/emacs-module/mod-test" invocation-directory) + (defconst mod-test-file (ert-resource-file "mod-test") "File name of the module test file.")) (require 'mod-test mod-test-file) @@ -48,9 +50,7 @@ (cl-defmethod emacs-module-tests--generic ((_ user-ptr)) 'user-ptr) -;; -;; Basic tests. -;; +;;; Basic tests (ert-deftest mod-test-sum-test () (should (= (mod-test-sum 1 2) 3)) @@ -60,8 +60,9 @@ (should (eq 0 (string-match (concat "#<module function " - "\\(at \\(0x\\)?[[:xdigit:]]+\\( from .*\\)?" - "\\|Fmod_test_sum from .*\\)>") + "\\(at \\(0x\\)?[[:xdigit:]]+ " + "with data 0x1234\\( from .*\\)?" + "\\|Fmod_test_sum with data 0x1234 from .*\\)>") (prin1-to-string (nth 1 descr))))) (should (= (nth 2 descr) 3))) (should-error (mod-test-sum "1" 2) :type 'wrong-type-argument) @@ -97,13 +98,12 @@ changes." (rx bos "#<module function " (or "Fmod_test_sum" (and "at 0x" (+ hex-digit))) + " with data 0x1234" (? " from " (* nonl) "mod-test" (* nonl) ) ">" eos) (prin1-to-string func))))) -;; -;; Non-local exists (throw, signal). -;; +;;; Non-local exists (throw, signal) (ert-deftest mod-test-non-local-exit-signal-test () (should-error (mod-test-signal)) @@ -140,9 +140,7 @@ changes." (should (equal (mod-test-non-local-exit-funcall (lambda () (throw 'tag 32))) '(throw tag 32)))) -;; -;; String tests. -;; +;;; String tests (defun multiply-string (s n) "Return N copies of S concatenated together." @@ -166,9 +164,7 @@ changes." (ert-deftest mod-test-string-a-to-b-test () (should (string= (mod-test-string-a-to-b "aaa") "bbb"))) -;; -;; User-pointer tests. -;; +;;; User-pointer tests (ert-deftest mod-test-userptr-fun-test () (let* ((n 42) @@ -182,9 +178,7 @@ changes." ;; TODO: try to test finalizer -;; -;; Vector tests. -;; +;;; Vector tests (ert-deftest mod-test-vector-test () (dolist (s '(2 10 100 1000)) @@ -316,14 +310,15 @@ local reference." (ert-deftest module/describe-function-1 () "Check that Bug#30163 is fixed." (with-temp-buffer - (let ((standard-output (current-buffer))) + (let ((standard-output (current-buffer)) + (text-quoting-style 'grave)) (describe-function-1 #'mod-test-sum) (goto-char (point-min)) - (while (re-search-forward "`[^']*/data/emacs-module/" nil t) - (replace-match "`data/emacs-module/")) + (while (re-search-forward "`[^']*/src/emacs-module-resources/" nil t) + (replace-match "`src/emacs-module-resources/")) (should (equal (buffer-substring-no-properties 1 (point-max)) - (format "a module function in `data/emacs-module/mod-test%s'. + (format "a module function in `src/emacs-module-resources/mod-test%s'. (mod-test-sum a b) @@ -419,4 +414,166 @@ Interactively, you can try hitting \\[keyboard-quit] to quit." (ert-info ((format "input: %d" input)) (should (= (mod-test-double input) (* 2 input)))))) +(ert-deftest module-darwin-secondary-suffix () + "Check that on Darwin, both .so and .dylib suffixes work. +See Bug#36226." + (skip-unless (eq system-type 'darwin)) + (should (member ".dylib" load-suffixes)) + (should (member ".so" load-suffixes)) + ;; Preserve the old `load-history'. This is needed for some of the + ;; other unit tests that indirectly rely on `load-history'. + (let ((load-history load-history) + (dylib (concat mod-test-file ".dylib")) + (so (concat mod-test-file ".so"))) + (should (file-regular-p dylib)) + (should-not (file-exists-p so)) + (add-name-to-file dylib so) + (unwind-protect + (load so nil nil :nosuffix :must-suffix) + (delete-file so)))) + +(ert-deftest module/function-finalizer () + "Test that module function finalizers are properly called." + ;; We create and leak a couple of module functions with attached + ;; finalizer. Creating only one function risks spilling it to the + ;; stack, where it wouldn't be garbage-collected. However, with one + ;; hundred functions, there should be at least one that's + ;; unreachable. + (dotimes (_ 100) + (mod-test-make-function-with-finalizer)) + (cl-destructuring-bind (valid-before invalid-before) + (mod-test-function-finalizer-calls) + (should (zerop invalid-before)) + (garbage-collect) + (cl-destructuring-bind (valid-after invalid-after) + (mod-test-function-finalizer-calls) + (should (zerop invalid-after)) + ;; We don't require exactly 100 invocations of the finalizer, + ;; but at least one. + (should (> valid-after valid-before))))) + +(ert-deftest module/async-pipe () + "Check that writing data from another thread works." + (skip-unless (not (eq system-type 'windows-nt))) ; FIXME! + (with-temp-buffer + (let ((process (make-pipe-process :name "module/async-pipe" + :buffer (current-buffer) + :coding 'utf-8-unix + :noquery t))) + (unwind-protect + (progn + (mod-test-async-pipe process) + (should (accept-process-output process 1)) + ;; The string below must be identical to what + ;; mod-test.c:write_to_pipe produces. + (should (equal (buffer-string) "data from thread"))) + (delete-process process))))) + +(ert-deftest module/interactive/return-t () + (should (functionp (symbol-function #'mod-test-return-t))) + (should (module-function-p (symbol-function #'mod-test-return-t))) + (should-not (commandp #'mod-test-return-t)) + (should-not (commandp (symbol-function #'mod-test-return-t))) + (should-not (interactive-form #'mod-test-return-t)) + (should-not (interactive-form (symbol-function #'mod-test-return-t))) + (should-error (call-interactively #'mod-test-return-t) + :type 'wrong-type-argument)) + +(ert-deftest module/interactive/return-t-int () + (should (functionp (symbol-function #'mod-test-return-t-int))) + (should (module-function-p (symbol-function #'mod-test-return-t-int))) + (should (commandp #'mod-test-return-t-int)) + (should (commandp (symbol-function #'mod-test-return-t-int))) + (should (equal (interactive-form #'mod-test-return-t-int) '(interactive))) + (should (equal (interactive-form (symbol-function #'mod-test-return-t-int)) + '(interactive))) + (should (eq (mod-test-return-t-int) t)) + (should (eq (call-interactively #'mod-test-return-t-int) t))) + +(ert-deftest module/interactive/identity () + (should (functionp (symbol-function #'mod-test-identity))) + (should (module-function-p (symbol-function #'mod-test-identity))) + (should (commandp #'mod-test-identity)) + (should (commandp (symbol-function #'mod-test-identity))) + (should (equal (interactive-form #'mod-test-identity) '(interactive "i"))) + (should (equal (interactive-form (symbol-function #'mod-test-identity)) + '(interactive "i"))) + (should (eq (mod-test-identity 123) 123)) + (should-not (call-interactively #'mod-test-identity))) + +(ert-deftest module/unibyte () + (let ((result (mod-test-return-unibyte))) + (should (stringp result)) + (should (not (multibyte-string-p (mod-test-return-unibyte)))) + (should (equal result "foo\x00zot")))) + +(cl-defstruct (emacs-module-tests--variable + (:constructor nil) + (:constructor emacs-module-tests--make-variable + (name + &aux + (mutex (make-mutex name)) + (condvar (make-condition-variable mutex name)))) + (:copier nil)) + "A variable that's protected by a mutex." + value + (mutex nil :read-only t :type mutex) + (condvar nil :read-only t :type condition-variable)) + +(defun emacs-module-tests--wait-for-variable (variable desired) + (with-mutex (emacs-module-tests--variable-mutex variable) + (while (not (eq (emacs-module-tests--variable-value variable) desired)) + (condition-wait (emacs-module-tests--variable-condvar variable))))) + +(defun emacs-module-tests--change-variable (variable new) + (with-mutex (emacs-module-tests--variable-mutex variable) + (setf (emacs-module-tests--variable-value variable) new) + (condition-notify (emacs-module-tests--variable-condvar variable) :all))) + +(ert-deftest emacs-module-tests/interleaved-threads () + (let* ((state-1 (emacs-module-tests--make-variable "1")) + (state-2 (emacs-module-tests--make-variable "2")) + (thread-1 + (make-thread + (lambda () + (emacs-module-tests--change-variable state-1 'before-module) + (mod-test-funcall + (lambda () + (emacs-module-tests--change-variable state-1 'in-module) + (emacs-module-tests--wait-for-variable state-2 'in-module))) + (emacs-module-tests--change-variable state-1 'after-module)) + "thread 1")) + (thread-2 + (make-thread + (lambda () + (emacs-module-tests--change-variable state-2 'before-module) + (emacs-module-tests--wait-for-variable state-1 'in-module) + (mod-test-funcall + (lambda () + (emacs-module-tests--change-variable state-2 'in-module) + (emacs-module-tests--wait-for-variable state-1 'after-module))) + (emacs-module-tests--change-variable state-2 'after-module)) + "thread 2"))) + (thread-join thread-1) + (thread-join thread-2))) + +(ert-deftest mod-test-make-string/empty () + (dolist (multibyte '(nil t)) + (ert-info ((format "Multibyte: %s" multibyte)) + (let ((got (mod-test-make-string 0 multibyte))) + (should (stringp got)) + (should (string-empty-p got)) + (should (eq (multibyte-string-p got) multibyte)))))) + +(ert-deftest mod-test-make-string/nonempty () + (dolist (multibyte '(nil t)) + (ert-info ((format "Multibyte: %s" multibyte)) + (let ((first (mod-test-make-string 1 multibyte)) + (second (mod-test-make-string 1 multibyte))) + (should (stringp first)) + (should (eql (length first) 1)) + (should (eq (multibyte-string-p first) multibyte)) + (should (string-equal first second)) + (should-not (eq first second)))))) + ;;; emacs-module-tests.el ends here diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el index 46029d520d6..b2b7dfefda5 100644 --- a/test/src/eval-tests.el +++ b/test/src/eval-tests.el @@ -27,6 +27,7 @@ (require 'ert) (eval-when-compile (require 'cl-lib)) +(require 'subr-x) (ert-deftest eval-tests--bug24673 () "Check that Bug#24673 has been fixed." @@ -176,4 +177,53 @@ in Common Lisp). Instead, make sure substitution in backquote expressions works for identifiers starting with period." (should (equal (let ((.x 'identity)) (eval `(,.x 'ok))) 'ok))) +(ert-deftest eval-tests/backtrace-in-batch-mode () + (let ((emacs (expand-file-name invocation-name invocation-directory))) + (skip-unless (file-executable-p emacs)) + (with-temp-buffer + (let ((status (call-process emacs nil t nil + "--quick" "--batch" + (concat "--eval=" + (prin1-to-string + '(progn + (defun foo () (error "Boo")) + (foo))))))) + (should (natnump status)) + (should-not (eql status 0))) + (goto-char (point-min)) + (ert-info ((concat "Process output:\n" (buffer-string))) + (search-forward " foo()") + (search-forward " normal-top-level()"))))) + +(ert-deftest eval-tests/backtrace-in-batch-mode/inhibit () + (let ((emacs (expand-file-name invocation-name invocation-directory))) + (skip-unless (file-executable-p emacs)) + (with-temp-buffer + (let ((status (call-process + emacs nil t nil + "--quick" "--batch" + (concat "--eval=" + (prin1-to-string + '(progn + (defun foo () (error "Boo")) + (let ((backtrace-on-error-noninteractive nil)) + (foo)))))))) + (should (natnump status)) + (should-not (eql status 0))) + (should (equal (string-trim (buffer-string)) "Boo"))))) + +(ert-deftest eval-tests/backtrace-in-batch-mode/demoted-errors () + (let ((emacs (expand-file-name invocation-name invocation-directory))) + (skip-unless (file-executable-p emacs)) + (with-temp-buffer + (should (eql 0 (call-process emacs nil t nil + "--quick" "--batch" + (concat "--eval=" + (prin1-to-string + '(with-demoted-errors "Error: %S" + (error "Boo"))))))) + (goto-char (point-min)) + (should (equal (string-trim (buffer-string)) + "Error: (error \"Boo\")"))))) + ;;; eval-tests.el ends here diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el index c7f6e6f8eb1..7f193d4eeab 100644 --- a/test/src/fileio-tests.el +++ b/test/src/fileio-tests.el @@ -98,15 +98,14 @@ Also check that an encoding error can appear in a symlink." (ert-deftest fileio-tests--relative-HOME () "Test that expand-file-name works even when HOME is relative." - (let ((old-home (getenv "HOME"))) + (let ((process-environment (copy-sequence process-environment))) (setenv "HOME" "a/b/c") (should (equal (expand-file-name "~/foo") (expand-file-name "a/b/c/foo"))) (when (memq system-type '(ms-dos windows-nt)) ;; Test expansion of drive-relative file names. (setenv "HOME" "x:foo") - (should (equal (expand-file-name "~/bar") "x:/foo/bar"))) - (setenv "HOME" old-home))) + (should (equal (expand-file-name "~/bar") "x:/foo/bar"))))) (ert-deftest fileio-tests--insert-file-interrupt () (let ((text "-*- coding: binary -*-\n\xc3\xc3help") @@ -156,3 +155,9 @@ Also check that an encoding error can appear in a symlink." (write-region "hello\n" nil f nil 'silent) (should-error (insert-file-contents f) :type 'circular-list) (delete-file f))) + +(ert-deftest fileio-tests/null-character () + (should-error (file-exists-p "/foo\0bar") + :type 'wrong-type-argument)) + +;;; fileio-tests.el ends here diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el index d1943f1ee95..4a3c03d833e 100644 --- a/test/src/floatfns-tests.el +++ b/test/src/floatfns-tests.el @@ -1,4 +1,4 @@ -;;; floatfns-tests.el --- tests for floating point operations +;;; floatfns-tests.el --- tests for floating point operations -*- lexical-binding: t -*- ;; Copyright 2017-2021 Free Software Foundation, Inc. diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 16033a2ba90..a9daf878b81 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -1,4 +1,4 @@ -;;; fns-tests.el --- tests for src/fns.c +;;; fns-tests.el --- tests for src/fns.c -*- lexical-binding:t -*- ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. @@ -49,21 +49,21 @@ (should-error (nreverse)) (should-error (nreverse 1)) (should-error (nreverse (make-char-table 'foo))) - (should (equal (nreverse "xyzzy") "yzzyx")) - (let ((A [])) + (should (equal (nreverse (copy-sequence "xyzzy")) "yzzyx")) + (let ((A (vector))) (nreverse A) (should (equal A []))) - (let ((A [0])) + (let ((A (vector 0))) (nreverse A) (should (equal A [0]))) - (let ((A [1 2 3 4])) + (let ((A (vector 1 2 3 4))) (nreverse A) (should (equal A [4 3 2 1]))) - (let ((A [1 2 3 4])) + (let ((A (vector 1 2 3 4))) (nreverse A) (nreverse A) (should (equal A [1 2 3 4]))) - (let* ((A [1 2 3 4]) + (let* ((A (vector 1 2 3 4)) (B (nreverse (nreverse A)))) (should (equal A B)))) @@ -146,13 +146,13 @@ ;; Invalid UTF-8 sequences shall be indicated. How to create such strings? (ert-deftest fns-tests-sort () - (should (equal (sort '(9 5 2 -1 5 3 8 7 4) (lambda (x y) (< x y))) + (should (equal (sort (list 9 5 2 -1 5 3 8 7 4) (lambda (x y) (< x y))) '(-1 2 3 4 5 5 7 8 9))) - (should (equal (sort '(9 5 2 -1 5 3 8 7 4) (lambda (x y) (> x y))) + (should (equal (sort (list 9 5 2 -1 5 3 8 7 4) (lambda (x y) (> x y))) '(9 8 7 5 5 4 3 2 -1))) - (should (equal (sort '[9 5 2 -1 5 3 8 7 4] (lambda (x y) (< x y))) + (should (equal (sort (vector 9 5 2 -1 5 3 8 7 4) (lambda (x y) (< x y))) [-1 2 3 4 5 5 7 8 9])) - (should (equal (sort '[9 5 2 -1 5 3 8 7 4] (lambda (x y) (> x y))) + (should (equal (sort (vector 9 5 2 -1 5 3 8 7 4) (lambda (x y) (> x y))) [9 8 7 5 5 4 3 2 -1])) (should (equal (sort @@ -166,13 +166,15 @@ (should (equal (should-error (sort "cba" #'<) :type 'wrong-type-argument) '(wrong-type-argument list-or-vector-p "cba")))) +(defvar w32-collate-ignore-punctuation) + (ert-deftest fns-tests-collate-sort () (skip-unless (fns-tests--collate-enabled-p)) ;; Punctuation and whitespace characters are relevant for POSIX. (should (equal - (sort '("11" "12" "1 1" "1 2" "1.1" "1.2") + (sort (list "11" "12" "1 1" "1 2" "1.1" "1.2") (lambda (a b) (string-collate-lessp a b "POSIX"))) '("1 1" "1 2" "1.1" "1.2" "11" "12"))) ;; Punctuation and whitespace characters are not taken into account @@ -180,7 +182,7 @@ (when (eq system-type 'windows-nt) (should (equal - (sort '("11" "12" "1 1" "1 2" "1.1" "1.2") + (sort (list "11" "12" "1 1" "1 2" "1.1" "1.2") (lambda (a b) (let ((w32-collate-ignore-punctuation t)) (string-collate-lessp @@ -190,7 +192,7 @@ ;; Diacritics are different letters for POSIX, they sort lexicographical. (should (equal - (sort '("Ævar" "Agustín" "Adrian" "Eli") + (sort (list "Ævar" "Agustín" "Adrian" "Eli") (lambda (a b) (string-collate-lessp a b "POSIX"))) '("Adrian" "Agustín" "Eli" "Ævar"))) ;; Diacritics are sorted between similar letters for other locales, @@ -198,7 +200,7 @@ (when (eq system-type 'windows-nt) (should (equal - (sort '("Ævar" "Agustín" "Adrian" "Eli") + (sort (list "Ævar" "Agustín" "Adrian" "Eli") (lambda (a b) (let ((w32-collate-ignore-punctuation t)) (string-collate-lessp @@ -212,7 +214,7 @@ (should (not (string-version-lessp "foo20000.png" "foo12.png"))) (should (string-version-lessp "foo.png" "foo2.png")) (should (not (string-version-lessp "foo2.png" "foo.png"))) - (should (equal (sort '("foo12.png" "foo2.png" "foo1.png") + (should (equal (sort (list "foo12.png" "foo2.png" "foo1.png") 'string-version-lessp) '("foo1.png" "foo2.png" "foo12.png"))) (should (string-version-lessp "foo2" "foo1234")) @@ -228,9 +230,9 @@ (should (equal (func-arity 'format) '(1 . many))) (require 'info) (should (equal (func-arity 'Info-goto-node) '(1 . 3))) - (should (equal (func-arity (lambda (&rest x))) '(0 . many))) - (should (equal (func-arity (eval (lambda (x &optional y)) nil)) '(1 . 2))) - (should (equal (func-arity (eval (lambda (x &optional y)) t)) '(1 . 2))) + (should (equal (func-arity (lambda (&rest _x))) '(0 . many))) + (should (equal (func-arity (eval '(lambda (_x &optional y)) nil)) '(1 . 2))) + (should (equal (func-arity (eval '(lambda (_x &optional y)) t)) '(1 . 2))) (should (equal (func-arity 'let) '(1 . unevalled)))) (defun fns-tests--string-repeat (s o) @@ -432,9 +434,9 @@ (should-error (mapcan)) (should-error (mapcan #'identity)) (should-error (mapcan #'identity (make-char-table 'foo))) - (should (equal (mapcan #'list '(1 2 3)) '(1 2 3))) + (should (equal (mapcan #'list (list 1 2 3)) '(1 2 3))) ;; `mapcan' is destructive - (let ((data '((foo) (bar)))) + (let ((data (list (list 'foo) (list 'bar)))) (should (equal (mapcan #'identity data) '(foo bar))) (should (equal data '((foo bar) (bar)))))) @@ -858,6 +860,22 @@ (puthash k k h))) (should (= 100 (hash-table-count h))))) +(ert-deftest test-sxhash-equal () + (should (= (sxhash-equal (* most-positive-fixnum most-negative-fixnum)) + (sxhash-equal (* most-positive-fixnum most-negative-fixnum)))) + (should (= (sxhash-equal (make-string 1000 ?a)) + (sxhash-equal (make-string 1000 ?a)))) + (should (= (sxhash-equal (point-marker)) + (sxhash-equal (point-marker)))) + (should (= (sxhash-equal (make-vector 1000 (make-string 10 ?a))) + (sxhash-equal (make-vector 1000 (make-string 10 ?a))))) + (should (= (sxhash-equal (make-bool-vector 1000 t)) + (sxhash-equal (make-bool-vector 1000 t)))) + (should (= (sxhash-equal (make-char-table nil (make-string 10 ?a))) + (sxhash-equal (make-char-table nil (make-string 10 ?a))))) + (should (= (sxhash-equal (record 'a (make-string 10 ?a))) + (sxhash-equal (record 'a (make-string 10 ?a)))))) + (ert-deftest test-secure-hash () (should (equal (secure-hash 'md5 "foobar") "3858f62230ac3c915f300c664312c63f")) @@ -874,6 +892,151 @@ (should (equal (secure-hash 'sha512 "foobar") (concat "0a50261ebd1a390fed2bf326f2673c145582a6342d5" "23204973d0219337f81616a8069b012587cf5635f69" - "25f1b56c360230c19b273500ee013e030601bf2425")))) + "25f1b56c360230c19b273500ee013e030601bf2425"))) + ;; Test that a call to getrandom returns the right format. + ;; This does not test randomness; it's merely a format check. + (should (string-match "\\`[0-9a-f]\\{128\\}\\'" + (secure-hash 'sha512 'iv-auto 100)))) + +(ert-deftest test-vector-delete () + (let ((v1 (make-vector 1000 1))) + (should (equal (delete t [nil t]) [nil])) + (should (equal (delete 1 v1) (vector))) + (should (equal (delete 2 v1) v1)))) + +(ert-deftest string-search () + (should (equal (string-search "zot" "foobarzot") 6)) + (should (equal (string-search "foo" "foobarzot") 0)) + (should (not (string-search "fooz" "foobarzot"))) + (should (not (string-search "zot" "foobarzo"))) + (should (equal (string-search "ab" "ab") 0)) + (should (equal (string-search "ab\0" "ab") nil)) + (should (equal (string-search "ab" "abababab" 3) 4)) + (should (equal (string-search "ab" "ababac" 3) nil)) + (should (equal (string-search "aaa" "aa") nil)) + (let ((case-fold-search t)) + (should (equal (string-search "ab" "AB") nil))) -(provide 'fns-tests) + (should (equal + (string-search (make-string 2 130) + (concat "helló" (make-string 5 130 t) "bár")) + 5)) + (should (equal + (string-search (make-string 2 127) + (concat "helló" (make-string 5 127 t) "bár")) + 5)) + + (should (equal (string-search "\377" "a\377ø") 1)) + (should (equal (string-search "\377" "a\377a") 1)) + + (should (not (string-search (make-string 1 255) "a\377ø"))) + (should (not (string-search (make-string 1 255) "a\377a"))) + + (should (equal (string-search "fóo" "zotfóo") 3)) + + (should (equal (string-search (string-to-multibyte "\377") "ab\377c") 2)) + (should (equal (string-search "\303" "aøb") nil)) + (should (equal (string-search "\270" "aøb") nil)) + (should (equal (string-search "ø" "\303\270") nil)) + (should (equal (string-search "ø" (make-string 32 ?a)) nil)) + (should (equal (string-search "ø" (string-to-multibyte (make-string 32 ?a))) + nil)) + (should (equal (string-search "o" (string-to-multibyte + (apply #'string + (number-sequence ?a ?z)))) + 14)) + + (should (equal (string-search "a\U00010f98z" "a\U00010f98a\U00010f98z") 2)) + + (should-error (string-search "a" "abc" -1)) + (should-error (string-search "a" "abc" 4)) + (should-error (string-search "a" "abc" 100000000000)) + + (should (equal (string-search "a" "aaa" 3) nil)) + (should (equal (string-search "aa" "aa" 1) nil)) + (should (equal (string-search "\0" "") nil)) + + (should (equal (string-search "" "") 0)) + (should-error (string-search "" "" 1)) + (should (equal (string-search "" "abc") 0)) + (should (equal (string-search "" "abc" 2) 2)) + (should (equal (string-search "" "abc" 3) 3)) + (should-error (string-search "" "abc" 4)) + (should-error (string-search "" "abc" -1)) + + (should-not (string-search "ø" "foo\303\270")) + (should-not (string-search "\303\270" "ø")) + (should-not (string-search "\370" "ø")) + (should-not (string-search (string-to-multibyte "\370") "ø")) + (should-not (string-search "ø" "\370")) + (should-not (string-search "ø" (string-to-multibyte "\370"))) + (should-not (string-search "\303\270" "\370")) + (should-not (string-search (string-to-multibyte "\303\270") "\370")) + (should-not (string-search "\303\270" (string-to-multibyte "\370"))) + (should-not (string-search (string-to-multibyte "\303\270") + (string-to-multibyte "\370"))) + (should-not (string-search "\370" "\303\270")) + (should-not (string-search (string-to-multibyte "\370") "\303\270")) + (should-not (string-search "\370" (string-to-multibyte "\303\270"))) + (should-not (string-search (string-to-multibyte "\370") + (string-to-multibyte "\303\270"))) + (should (equal (string-search (string-to-multibyte "o\303\270") "foo\303\270") + 2)) + (should (equal (string-search "\303\270" "foo\303\270") 3))) + +(ert-deftest object-intervals () + (should (equal (object-intervals (propertize "foo" 'bar 'zot)) + '((0 3 (bar zot))))) + (should (equal (object-intervals (concat (propertize "foo" 'bar 'zot) + (propertize "foo" 'gazonk "gazonk"))) + '((0 3 (bar zot)) (3 6 (gazonk "gazonk"))))) + (should (equal + (with-temp-buffer + (insert "foobar") + (put-text-property 1 3 'foo 1) + (put-text-property 3 6 'bar 2) + (put-text-property 2 5 'zot 3) + (object-intervals (current-buffer))) + '((0 1 (foo 1)) (1 2 (zot 3 foo 1)) (2 4 (zot 3 bar 2)) + (4 5 (bar 2)) (5 6 nil))))) + +(ert-deftest length-equals-tests () + (should-not (length< (list 1 2 3) 2)) + (should-not (length< (list 1 2 3) 3)) + (should (length< (list 1 2 3) 4)) + + (should-not (length< "abc" 2)) + (should-not (length< "abc" 3)) + (should (length< "abc" 4)) + + (should (length> (list 1 2 3) 2)) + (should-not (length> (list 1 2 3) 3)) + (should-not (length> (list 1 2 3) 4)) + + (should (length> "abc" 2)) + (should-not (length> "abc" 3)) + (should-not (length> "abc" 4)) + + (should-not (length= (list 1 2 3) 2)) + (should (length= (list 1 2 3) 3)) + (should-not (length= (list 1 2 3) 4)) + + (should-not (length= "abc" 2)) + (should (length= "abc" 3)) + (should-not (length= "abc" 4)) + + (should-not (length< (list 1 2 3) -1)) + (should-not (length< (list 1 2 3) 0)) + (should-not (length< (list 1 2 3) -10)) + + (should (length> (list 1 2 3) -1)) + (should (length> (list 1 2 3) 0)) + + (should-not (length= (list 1 2 3) -1)) + (should-not (length= (list 1 2 3) 0)) + (should-not (length= (list 1 2 3) 1)) + + (should-error + (let ((list (list 1))) + (setcdr list list) + (length< list #x1fffe)))) diff --git a/test/src/font-tests.el b/test/src/font-tests.el index 1892ebf69ee..de153b8de9b 100644 --- a/test/src/font-tests.el +++ b/test/src/font-tests.el @@ -1,4 +1,4 @@ -;;; font-tests.el --- Test suite for font-related functions. +;;; font-tests.el --- Test suite for font-related functions. -*- lexical-binding: t -*- ;; Copyright (C) 2011-2021 Free Software Foundation, Inc. diff --git a/test/src/indent-tests.el b/test/src/indent-tests.el new file mode 100644 index 00000000000..10f1202949b --- /dev/null +++ b/test/src/indent-tests.el @@ -0,0 +1,59 @@ +;;; indent-tests.el --- tests for src/indent.c -*- lexical-binding:t -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `https://www.gnu.org/licenses/'. + +;;; Commentary: + +;;; Code: + +(ert-deftest indent-tests-move-to-column-invis-1tab () + "Test `move-to-column' when a TAB is followed by invisible text." + (should + (string= + (with-temp-buffer + (insert "\tLine starting with INVISIBLE text after TAB\n") + (add-text-properties 2 21 '(invisible t)) + (goto-char (point-min)) + (move-to-column 7 t) + (buffer-substring-no-properties 1 8)) + " "))) + +(ert-deftest indent-tests-move-to-column-invis-2tabs () + "Test `move-to-column' when 2 TABs are followed by invisible text." + (should + (string= + (with-temp-buffer + (insert "\t\tLine starting with INVISIBLE text after TAB\n") + (add-text-properties 3 22 '(invisible t)) + (goto-char (point-min)) + (move-to-column 12 t) + (buffer-substring-no-properties 1 11)) + "\t \tLine"))) + +(ert-deftest indent-tests-move-to-column-invis-between-tabs () + "Test `move-to-column' when 2 TABs are mixed with invisible text." + (should + (string= + (with-temp-buffer + (insert "\txxx\tLine starting with INVISIBLE text after TAB\n") + (add-text-properties 6 25 '(invisible t)) + (add-text-properties 2 5 '(invisible t)) + (goto-char (point-min)) + (move-to-column 12 t) + (buffer-substring-no-properties 1 14)) + "\txxx \tLine"))) diff --git a/test/src/keyboard-tests.el b/test/src/keyboard-tests.el index 203c0b54154..607d2eafd45 100644 --- a/test/src/keyboard-tests.el +++ b/test/src/keyboard-tests.el @@ -32,5 +32,20 @@ (read-event nil nil 2)) ?\C-b))) +(ert-deftest keyboard-lossage-size () + "Test `lossage-size'." + (let ((min-value 100) + (lossage-orig (lossage-size))) + (dolist (factor (list 1 3 4 5 10 7 3)) + (let ((new-lossage (* factor min-value))) + (should (= new-lossage (lossage-size new-lossage))))) + ;; Wrong type + (should-error (lossage-size -5)) + (should-error (lossage-size "200")) + ;; Less that minimum value + (should-error (lossage-size (1- min-value))) + (should (= lossage-orig (lossage-size lossage-orig))))) + + (provide 'keyboard-tests) ;;; keyboard-tests.el ends here diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el index 5402916d7c0..74fb3c892db 100644 --- a/test/src/keymap-tests.el +++ b/test/src/keymap-tests.el @@ -1,8 +1,9 @@ -;;; keymap-tests.el --- Test suite for src/keymap.c +;;; keymap-tests.el --- Test suite for src/keymap.c -*- lexical-binding: t -*- ;; Copyright (C) 2015-2021 Free Software Foundation, Inc. ;; Author: Juanma Barranquero <lekktu@gmail.com> +;; Stefan Kangas <stefankangas@gmail.com> ;; This file is part of GNU Emacs. @@ -23,6 +24,83 @@ (require 'ert) +(defun keymap-tests--make-keymap-test (fun) + (should (eq (car (funcall fun)) 'keymap)) + (should (proper-list-p (funcall fun))) + (should (equal (car (last (funcall fun "foo"))) "foo"))) + +(ert-deftest keymap-make-keymap () + (keymap-tests--make-keymap-test #'make-keymap) + (should (char-table-p (cadr (make-keymap))))) + +(ert-deftest keymap-make-sparse-keymap () + (keymap-tests--make-keymap-test #'make-sparse-keymap)) + +(ert-deftest keymap-keymapp () + (should (keymapp (make-keymap))) + (should (keymapp (make-sparse-keymap))) + (should-not (keymapp '(foo bar)))) + +(ert-deftest keymap-keymap-parent () + (should-not (keymap-parent (make-keymap))) + (should-not (keymap-parent (make-sparse-keymap))) + (let ((map (make-keymap))) + (set-keymap-parent map help-mode-map) + (should (equal (keymap-parent map) help-mode-map)))) + +(ert-deftest keymap-copy-keymap/is-equal () + (should (equal (copy-keymap help-mode-map) help-mode-map))) + +(ert-deftest keymap-copy-keymap/is-not-eq () + (should-not (eq (copy-keymap help-mode-map) help-mode-map))) + +(ert-deftest keymap---get-keyelt/runs-menu-item-filter () + (let* (menu-item-filter-ran + (object `(menu-item "2" identity + :filter ,(lambda (cmd) + (setq menu-item-filter-ran t) + cmd)))) + (keymap--get-keyelt object t) + (should menu-item-filter-ran))) + +(ert-deftest keymap-lookup-key () + (let ((map (make-keymap))) + (define-key map [?a] 'foo) + (should (eq (lookup-key map [?a]) 'foo)))) + +(ert-deftest describe-buffer-bindings/header-in-current-buffer () + "Header should be inserted into the current buffer. +https://debbugs.gnu.org/39149#31" + (with-temp-buffer + (describe-buffer-bindings (current-buffer)) + (should (string-match (rx bol "key" (+ space) "binding" eol) + (buffer-string))))) + +(ert-deftest describe-buffer-bindings/returns-nil () + "Should return nil." + (with-temp-buffer + (should (eq (describe-buffer-bindings (current-buffer)) nil)))) + +(defun keymap-tests--test-menu-item-filter (show filter-fun) + (unwind-protect + (progn + (define-key global-map (kbd "C-c C-l r") + `(menu-item "2" identity :filter ,filter-fun)) + (with-temp-buffer + (describe-buffer-bindings (current-buffer)) + (goto-char (point-min)) + (if (eq show 'show) + (should (search-forward "C-c C-l r" nil t)) + (should-not (search-forward "C-c C-l r" nil t))))) + (define-key global-map (kbd "C-c C-l r") nil) + (define-key global-map (kbd "C-c C-l") nil))) + +(ert-deftest describe-buffer-bindings/menu-item-filter-show-binding () + (keymap-tests--test-menu-item-filter 'show (lambda (cmd) cmd))) + +(ert-deftest describe-buffer-bindings/menu-item-filter-hide-binding () + (keymap-tests--test-menu-item-filter 'hide (lambda (_) nil))) + (ert-deftest keymap-store_in_keymap-XFASTINT-on-non-characters () "Check for bug fixed in \"Fix assertion violation in define-key\", commit 86c19714b097aa477d339ed99ffb5136c755a046." @@ -38,13 +116,138 @@ commit 86c19714b097aa477d339ed99ffb5136c755a046." (should (eq (lookup-key Buffer-menu-mode-map [32]) 'undefined))) (define-key Buffer-menu-mode-map [32] def)))) -(ert-deftest keymap-where-is-internal-test () + +;;;; where-is-internal + +(defun keymap-tests--command-1 () (interactive) nil) +(defun keymap-tests--command-2 () (interactive) nil) +(put 'keymap-tests--command-1 :advertised-binding [?y]) + +(ert-deftest keymap-where-is-internal () + (let ((map (make-sparse-keymap))) + (define-key map "x" 'keymap-tests--command-1) + (define-key map "y" 'keymap-tests--command-1) + (should (equal (where-is-internal 'keymap-tests--command-1 map) + '([?y] [?x]))))) + +(ert-deftest keymap-where-is-internal/firstonly-t () + (let ((map (make-sparse-keymap))) + (define-key map "x" 'keymap-tests--command-1) + (define-key map "y" 'keymap-tests--command-1) + (should (equal (where-is-internal 'keymap-tests--command-1 map t) + [?y])))) + +(ert-deftest keymap-where-is-internal/menu-item () + (let ((map (make-sparse-keymap))) + (define-key map [menu-bar foobar cmd1] + '(menu-item "Run Command 1" keymap-tests--command-1 + :help "Command 1 Help")) + (define-key map "x" 'keymap-tests--command-1) + (should (equal (where-is-internal 'keymap-tests--command-1 map) + '([?x] [menu-bar foobar cmd1]))) + (should (equal (where-is-internal 'keymap-tests--command-1 map t) [?x])))) + + +(ert-deftest keymap-where-is-internal/advertised-binding () + ;; Make sure order does not matter. + (dolist (keys '(("x" . "y") ("y" . "x"))) + (let ((map (make-sparse-keymap))) + (define-key map (car keys) 'keymap-tests--command-1) + (define-key map (cdr keys) 'keymap-tests--command-1) + (should (equal (where-is-internal 'keymap-tests--command-1 map t) [121]))))) + +(ert-deftest keymap-where-is-internal/advertised-binding-respect-remap () + (let ((map (make-sparse-keymap))) + (define-key map "x" 'next-line) + (define-key map [remap keymap-tests--command-1] 'next-line) + (define-key map "y" 'keymap-tests--command-1) + (should (equal (where-is-internal 'keymap-tests--command-1 map t) [?x])))) + +(ert-deftest keymap-where-is-internal/remap () + (let ((map (make-keymap))) + (define-key map (kbd "x") 'foo) + (define-key map (kbd "y") 'bar) + (define-key map [remap foo] 'bar) + (should (equal (where-is-internal 'foo map t) [?y])) + (should (equal (where-is-internal 'bar map t) [?y])))) + +(defvar keymap-tests-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "x" 'keymap-tests--command-2) + map)) + +(defvar keymap-tests-major-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "x" 'keymap-tests--command-1) + map)) + +(define-minor-mode keymap-tests-minor-mode "Test.") + +(define-derived-mode keymap-tests-major-mode nil "Test.") + +(ert-deftest keymap-where-is-internal/shadowed () + (with-temp-buffer + (keymap-tests-major-mode) + (keymap-tests-minor-mode) + (should-not (where-is-internal 'keymap-tests--command-1 nil t)) + (should (equal (where-is-internal 'keymap-tests--command-2 nil t) [120])))) + +(ert-deftest keymap-where-is-internal/preferred-modifier-is-a-string () "Make sure we don't crash when `where-is-preferred-modifier' is not a symbol." (should (equal (let ((where-is-preferred-modifier "alt")) (where-is-internal 'execute-extended-command global-map t)) [#x8000078]))) + +;;;; describe_vector + +(ert-deftest help--describe-vector/bug-9293-one-shadowed-in-range () + "Check that we only show a range if shadowed by the same command." + (let ((orig-map (let ((map (make-keymap))) + (define-key map "e" 'foo) + (define-key map "f" 'foo) + (define-key map "g" 'foo) + (define-key map "h" 'foo) + map)) + (shadow-map (let ((map (make-keymap))) + (define-key map "f" 'bar) + map)) + (text-quoting-style 'grave)) + (with-temp-buffer + (help--describe-vector (cadr orig-map) nil #'help--describe-command + t shadow-map orig-map t) + (should (equal (buffer-string) + " +e foo +f foo (currently shadowed by `bar') +g .. h foo +"))))) + +(ert-deftest help--describe-vector/bug-9293-same-command-does-not-shadow () + "Check that a command can't be shadowed by the same command." + (let ((range-map + (let ((map (make-keymap))) + (define-key map "0" 'foo) + (define-key map "1" 'foo) + (define-key map "2" 'foo) + (define-key map "3" 'foo) + map)) + (shadow-map + (let ((map (make-keymap))) + (define-key map "0" 'foo) + (define-key map "1" 'foo) + (define-key map "2" 'foo) + (define-key map "3" 'foo) + map))) + (with-temp-buffer + (help--describe-vector (cadr range-map) nil #'help--describe-command + t shadow-map range-map t) + (should (equal (buffer-string) + " +0 .. 3 foo +"))))) + (provide 'keymap-tests) ;;; keymap-tests.el ends here diff --git a/test/src/lread-resources/somelib.el b/test/src/lread-resources/somelib.el new file mode 100644 index 00000000000..7b8d4037396 --- /dev/null +++ b/test/src/lread-resources/somelib.el @@ -0,0 +1,7 @@ +;;; -*- lexical-binding: t; -*- + +;; blah + +(defun somefunc () t) + +(provide 'somelib) diff --git a/test/src/lread-resources/somelib2.el b/test/src/lread-resources/somelib2.el new file mode 100644 index 00000000000..05156145a22 --- /dev/null +++ b/test/src/lread-resources/somelib2.el @@ -0,0 +1,7 @@ +;;; -*- lexical-binding: t; -*- + +;; blah + +(defun somefunc2 () t) + +(provide 'somelib2) diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index 87c1c706657..edf88214f97 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -6,18 +6,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -25,6 +25,9 @@ ;;; Code: +(require 'ert) +(require 'ert-x) + (ert-deftest lread-char-number () (should (equal (read "?\\N{U+A817}") #xA817))) @@ -146,10 +149,7 @@ literals (Bug#20852)." (ert-deftest lread-test-bug26837 () "Test for https://debbugs.gnu.org/26837 ." - (let ((load-path (cons - (file-name-as-directory - (expand-file-name "data" (getenv "EMACS_TEST_DIRECTORY"))) - load-path))) + (let ((load-path (cons (ert-resource-directory) load-path))) (load "somelib" nil t) (should (string-suffix-p "/somelib.el" (caar load-history))) (load "somelib2" nil t) @@ -157,22 +157,6 @@ literals (Bug#20852)." (load "somelib" nil t) (should (string-suffix-p "/somelib.el" (caar load-history))))) -(ert-deftest lread-tests--old-style-backquotes () - "Check that loading doesn't accept old-style backquotes." - (lread-tests--with-temp-file file-name - (write-region "(` (a b))" nil file-name) - (let ((data (should-error (load file-name nil :nomessage :nosuffix)))) - (should (equal (cdr data) - (list (concat (format-message "Loading `%s': " file-name) - "old-style backquotes detected!"))))))) - -(ert-deftest lread-tests--force-new-style-backquotes () - (let ((data (should-error (read "(` (a b))")))) - (should (equal (cdr data) '("Old-style backquotes detected!")))) - (should (equal (let ((force-new-style-backquotes t)) - (read "(` (a b))")) - '(`(a b))))) - (ert-deftest lread-lread--substitute-object-in-subtree () (let ((x (cons 0 1))) (setcar x x) diff --git a/test/src/print-tests.el b/test/src/print-tests.el index f094201443d..0d2ea6e3834 100644 --- a/test/src/print-tests.el +++ b/test/src/print-tests.el @@ -4,18 +4,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: @@ -355,5 +355,56 @@ otherwise, use a different charset." (setcdr err err) (should-error (error-message-string err) :type 'circular-list))) +(print-tests--deftest print-hash-table-test () + (should + (string-match + "data (2 3)" + (let ((h (make-hash-table))) + (puthash 1 2 h) + (puthash 2 3 h) + (remhash 1 h) + (format "%S" h)))) + + (should + (string-match + "data ()" + (let ((h (make-hash-table))) + (let ((print-length 0)) + (format "%S" h))))) + + (should + (string-match + "data (99 99)" + (let ((h (make-hash-table))) + (dotimes (i 100) + (puthash i i h)) + (dotimes (i 99) + (remhash i h)) + (let ((print-length 1)) + (format "%S" h)))))) + +(print-tests--deftest print-integers-as-characters () + ;; Bug#44155. + (let* ((print-integers-as-characters t) + (chars '(?? ?\; ?\( ?\) ?\{ ?\} ?\[ ?\] ?\" ?\' ?\\ ?f ?~ ?Á 32 + ?\n ?\r ?\t ?\b ?\f ?\a ?\v ?\e ?\d)) + (nums '(-1 -65 0 1 31 #x80 #x9f #x110000 #x3fff80 #x3fffff)) + (nonprints '(#xd800 #xdfff #x030a #xffff #x2002 #x200c)) + (printed-chars (print-tests--prin1-to-string chars)) + (printed-nums (print-tests--prin1-to-string nums)) + (printed-nonprints (print-tests--prin1-to-string nonprints))) + (should (equal (read printed-chars) chars)) + (should (equal + printed-chars + (concat + "(?? ?\\; ?\\( ?\\) ?\\{ ?\\} ?\\[ ?\\] ?\\\" ?\\' ?\\\\" + " ?f ?~ ?Á ?\\s ?\\n ?\\r ?\\t ?\\b ?\\f 7 11 27 127)"))) + (should (equal (read printed-nums) nums)) + (should (equal printed-nums + "(-1 -65 0 1 31 128 159 1114112 4194176 4194303)")) + (should (equal (read printed-nonprints) nonprints)) + (should (equal printed-nonprints + "(55296 57343 778 65535 8194 8204)")))) + (provide 'print-tests) ;;; print-tests.el ends here diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 4088f11c27e..cddf955853e 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -1,19 +1,21 @@ -;;; process-tests.el --- Testing the process facilities +;;; process-tests.el --- Testing the process facilities -*- lexical-binding: t -*- ;; Copyright (C) 2013-2021 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -21,8 +23,11 @@ ;;; Code: +(require 'cl-lib) (require 'ert) (require 'puny) +(require 'rx) +(require 'subr-x) ;; Timeout in seconds; the test fails if the timeout is reached. (defvar process-test-sentinel-wait-timeout 2.0) @@ -33,7 +38,7 @@ (let ((proc (start-process "test" nil "bash" "-c" "exit 20")) (sentinel-called nil) (start-time (float-time))) - (set-process-sentinel proc (lambda (proc msg) + (set-process-sentinel proc (lambda (_proc _msg) (setq sentinel-called t))) (while (not (or sentinel-called (> (- (float-time) start-time) @@ -45,13 +50,15 @@ (ert-deftest process-test-sentinel-accept-process-output () (skip-unless (executable-find "bash")) + (with-timeout (60 (ert-fail "Test timed out")) (should (process-test-sentinel-wait-function-working-p - #'accept-process-output))) + #'accept-process-output)))) (ert-deftest process-test-sentinel-sit-for () (skip-unless (executable-find "bash")) + (with-timeout (60 (ert-fail "Test timed out")) (should - (process-test-sentinel-wait-function-working-p (lambda () (sit-for 0.01 t))))) + (process-test-sentinel-wait-function-working-p (lambda () (sit-for 0.01 t)))))) (when (eq system-type 'windows-nt) (ert-deftest process-test-quoted-batfile () @@ -77,6 +84,7 @@ (ert-deftest process-test-stderr-buffer () (skip-unless (executable-find "bash")) + (with-timeout (60 (ert-fail "Test timed out")) (let* ((stdout-buffer (generate-new-buffer "*stdout*")) (stderr-buffer (generate-new-buffer "*stderr*")) (proc (make-process :name "test" @@ -88,7 +96,7 @@ :stderr stderr-buffer)) (sentinel-called nil) (start-time (float-time))) - (set-process-sentinel proc (lambda (proc msg) + (set-process-sentinel proc (lambda (_proc _msg) (setq sentinel-called t))) (while (not (or sentinel-called (> (- (float-time) start-time) @@ -101,10 +109,11 @@ (looking-at "hello stdout!"))) (should (with-current-buffer stderr-buffer (goto-char (point-min)) - (looking-at "hello stderr!"))))) + (looking-at "hello stderr!")))))) (ert-deftest process-test-stderr-filter () (skip-unless (executable-find "bash")) + (with-timeout (60 (ert-fail "Test timed out")) (let* ((sentinel-called nil) (stderr-sentinel-called nil) (stdout-output nil) @@ -120,13 +129,13 @@ "exit 20")) :stderr stderr-proc)) (start-time (float-time))) - (set-process-filter proc (lambda (proc input) + (set-process-filter proc (lambda (_proc input) (push input stdout-output))) - (set-process-sentinel proc (lambda (proc msg) + (set-process-sentinel proc (lambda (_proc _msg) (setq sentinel-called t))) - (set-process-filter stderr-proc (lambda (proc input) + (set-process-filter stderr-proc (lambda (_proc input) (push input stderr-output))) - (set-process-sentinel stderr-proc (lambda (proc input) + (set-process-sentinel stderr-proc (lambda (_proc _input) (setq stderr-sentinel-called t))) (while (not (or sentinel-called (> (- (float-time) start-time) @@ -143,10 +152,11 @@ (should (equal 1 (with-current-buffer stderr-buffer (point-max)))) (should (equal "hello stderr!\n" - (mapconcat #'identity (nreverse stderr-output) ""))))) + (mapconcat #'identity (nreverse stderr-output) "")))))) (ert-deftest set-process-filter-t () "Test setting process filter to t and back." ;; Bug#36591 + (with-timeout (60 (ert-fail "Test timed out")) (with-temp-buffer (let* ((print-level nil) (print-length nil) @@ -178,11 +188,12 @@ (line-beginning-position) (point-max)) "2> ")) (accept-process-output proc)) ; Read "Two". - (should (equal (buffer-string) "0> one\n1> two\n2> "))))) + (should (equal (buffer-string) "0> one\n1> two\n2> ")))))) (ert-deftest start-process-should-not-modify-arguments () "`start-process' must not modify its arguments in-place." ;; See bug#21831. + (with-timeout (60 (ert-fail "Test timed out")) (let* ((path (pcase system-type ((or 'windows-nt 'ms-dos) ;; Make sure the file name uses forward slashes. @@ -196,11 +207,12 @@ (should (process-live-p (condition-case nil (start-process "" nil path) (error nil)))) - (should (equal path samepath)))) + (should (equal path samepath))))) (ert-deftest make-process/noquery-stderr () "Checks that Bug#30031 is fixed." (skip-unless (executable-find "sleep")) + (with-timeout (60 (ert-fail "Test timed out")) (with-temp-buffer (let* ((previous-processes (process-list)) (process (make-process :name "sleep" @@ -215,7 +227,7 @@ (should new-processes) (dolist (process new-processes) (should-not (process-query-on-exit-flag process)))) - (kill-process process))))) + (kill-process process)))))) ;; Return t if OUTPUT could have been generated by merging the INPUTS somehow. (defun process-tests--mixable (output &rest inputs) @@ -231,6 +243,7 @@ (ert-deftest make-process/mix-stderr () "Check that `make-process' mixes the output streams if STDERR is nil." (skip-unless (executable-find "bash")) + (with-timeout (60 (ert-fail "Test timed out")) ;; Frequent random (?) failures on hydra.nixos.org, with no process output. ;; Maybe this test should be tagged unstable? See bug#31214. (skip-unless (not (getenv "EMACS_HYDRA_CI"))) @@ -249,11 +262,12 @@ (should (eq (process-exit-status process) 0)) (should (process-tests--mixable (string-to-list (buffer-string)) (string-to-list "stdout\n") - (string-to-list "stderr\n")))))) + (string-to-list "stderr\n"))))))) (ert-deftest make-process-w32-debug-spawn-error () "Check that debugger runs on `make-process' failure (Bug#33016)." (skip-unless (eq system-type 'windows-nt)) + (with-timeout (60 (ert-fail "Test timed out")) (let* ((debug-on-error t) (have-called-debugger nil) (debugger (lambda (&rest _) @@ -269,11 +283,12 @@ ;; code. (make-process :name "test" :command '("c:/No-Such-Command")) (error :got-error)))) - (should have-called-debugger))) + (should have-called-debugger)))) (ert-deftest make-process/file-handler/found () - "Check that the ‘:file-handler’ argument of ‘make-process’ + "Check that the `:file-handler’ argument of `make-process’ works as expected if a file name handler is found." + (with-timeout (60 (ert-fail "Test timed out")) (let ((file-handler-calls 0)) (cl-flet ((file-handler (&rest args) @@ -290,27 +305,29 @@ works as expected if a file name handler is found." :command '("/some/binary") :file-handler t) 'fake-process)) - (should (= file-handler-calls 1)))))) + (should (= file-handler-calls 1))))))) (ert-deftest make-process/file-handler/not-found () - "Check that the ‘:file-handler’ argument of ‘make-process’ + "Check that the `:file-handler’ argument of `make-process’ works as expected if no file name handler is found." + (with-timeout (60 (ert-fail "Test timed out")) (let ((file-name-handler-alist ()) (default-directory invocation-directory) (program (expand-file-name invocation-name invocation-directory))) (should (processp (make-process :name "name" :command (list program "--version") - :file-handler t))))) + :file-handler t)))))) (ert-deftest make-process/file-handler/disable () - "Check ‘make-process’ works as expected if it shouldn’t use the + "Check `make-process’ works as expected if it shouldn’t use the file name handler." + (with-timeout (60 (ert-fail "Test timed out")) (let ((file-name-handler-alist (list (cons (rx bos "test-handler:") #'process-tests--file-handler))) (default-directory "test-handler:/dir/") (program (expand-file-name invocation-name invocation-directory))) (should (processp (make-process :name "name" - :command (list program "--version")))))) + :command (list program "--version"))))))) (defun process-tests--file-handler (operation &rest _args) (cl-ecase operation @@ -323,48 +340,419 @@ file name handler." (ert-deftest make-process/stop () "Check that `make-process' doesn't accept a `:stop' key. See Bug#30460." + (with-timeout (60 (ert-fail "Test timed out")) (should-error (make-process :name "test" :command (list (expand-file-name invocation-name invocation-directory)) - :stop t))) + :stop t)))) ;; All the following tests require working DNS, which appears not to ;; be the case for hydra.nixos.org, so disable them there for now. (ert-deftest lookup-family-specification () - "network-lookup-address-info should only accept valid family symbols." + "`network-lookup-address-info' should only accept valid family symbols." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (with-timeout (60 (ert-fail "Test timed out")) (should-error (network-lookup-address-info "google.com" 'both)) (should (network-lookup-address-info "google.com" 'ipv4)) (when (featurep 'make-network-process '(:family ipv6)) - (should (network-lookup-address-info "google.com" 'ipv6)))) + (should (network-lookup-address-info "google.com" 'ipv6))))) (ert-deftest lookup-unicode-domains () - "Unicode domains should fail" + "Unicode domains should fail." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (with-timeout (60 (ert-fail "Test timed out")) (should-error (network-lookup-address-info "faß.de")) - (should (network-lookup-address-info (puny-encode-domain "faß.de")))) + (should (network-lookup-address-info (puny-encode-domain "faß.de"))))) (ert-deftest unibyte-domain-name () - "Unibyte domain names should work" + "Unibyte domain names should work." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) - (should (network-lookup-address-info (string-to-unibyte "google.com")))) + (with-timeout (60 (ert-fail "Test timed out")) + (should (network-lookup-address-info (string-to-unibyte "google.com"))))) (ert-deftest lookup-google () - "Check that we can look up google IP addresses" + "Check that we can look up google IP addresses." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (with-timeout (60 (ert-fail "Test timed out")) (let ((addresses-both (network-lookup-address-info "google.com")) (addresses-v4 (network-lookup-address-info "google.com" 'ipv4))) (should addresses-both) (should addresses-v4)) (when (featurep 'make-network-process '(:family ipv6)) - (should (network-lookup-address-info "google.com" 'ipv6)))) + (should (network-lookup-address-info "google.com" 'ipv6))))) (ert-deftest non-existent-lookup-failure () + "Check that looking up non-existent domain returns nil." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) - "Check that looking up non-existent domain returns nil" - (should (eq nil (network-lookup-address-info "emacs.invalid")))) + (with-timeout (60 (ert-fail "Test timed out")) + (should (eq nil (network-lookup-address-info "emacs.invalid"))))) + +(defmacro process-tests--ignore-EMFILE (&rest body) + "Evaluate BODY, ignoring EMFILE errors." + (declare (indent 0) (debug t)) + (let ((err (make-symbol "err")) + (message (make-symbol "message"))) + `(let ((,message (process-tests--EMFILE-message))) + (condition-case ,err + ,(macroexp-progn body) + (file-error + ;; If we couldn't determine the EMFILE message, just ignore + ;; all `file-error' signals. + (and ,message + (not (string-equal (caddr ,err) ,message)) + (signal (car ,err) (cdr ,err)))))))) + +(defmacro process-tests--with-buffers (var &rest body) + "Bind VAR to nil and evaluate BODY. +Afterwards, kill all buffers in the list VAR. BODY should add +some buffer objects to VAR." + (declare (indent 1) (debug (symbolp body))) + (cl-check-type var symbol) + `(let ((,var nil)) + (unwind-protect + ,(macroexp-progn body) + (mapc #'kill-buffer ,var)))) + +(defmacro process-tests--with-processes (var &rest body) + "Bind VAR to nil and evaluate BODY. +Afterwards, delete all processes in the list VAR. BODY should +add some process objects to VAR." + (declare (indent 1) (debug (symbolp body))) + (cl-check-type var symbol) + `(let ((,var nil)) + (unwind-protect + ,(macroexp-progn body) + (mapc #'delete-process ,var)))) + +(defmacro process-tests--with-raised-rlimit (&rest body) + "Evaluate BODY using a higher limit for the number of open files. +Attempt to set the resource limit for the number of open files +temporarily to the highest possible value." + (declare (indent 0) (debug t)) + (let ((prlimit (make-symbol "prlimit")) + (soft (make-symbol "soft")) + (hard (make-symbol "hard")) + (pid-arg (make-symbol "pid-arg"))) + `(let ((,prlimit (executable-find "prlimit")) + (,pid-arg (format "--pid=%d" (emacs-pid))) + (,soft nil) (,hard nil)) + (cl-flet ((set-limit + (value) + (cl-check-type value natnum) + (when ,prlimit + (call-process ,prlimit nil nil nil + ,pid-arg + (format "--nofile=%d:" value))))) + (when ,prlimit + (with-temp-buffer + (when (eql (call-process ,prlimit nil t nil + ,pid-arg "--nofile" + "--raw" "--noheadings" + "--output=SOFT,HARD") + 0) + (goto-char (point-min)) + (when (looking-at (rx (group (+ digit)) (+ blank) + (group (+ digit)) ?\n)) + (setq ,soft (string-to-number + (match-string-no-properties 1)) + ,hard (string-to-number + (match-string-no-properties 2)))))) + (and ,soft ,hard (< ,soft ,hard) + (set-limit ,hard))) + (unwind-protect + ,(macroexp-progn body) + (when ,soft (set-limit ,soft))))))) + +(defmacro process-tests--fd-setsize-test (&rest body) + "Run BODY as a test for FD_SETSIZE overflow. +Try to generate pipe processes until we are close to the +FD_SETSIZE limit. Within BODY, only a small number of file +descriptors should still be available. Furthermore, raise the +maximum number of open files in the Emacs process above +FD_SETSIZE." + (declare (indent 0) (debug t)) + (let ((process (make-symbol "process")) + (processes (make-symbol "processes")) + (buffer (make-symbol "buffer")) + (buffers (make-symbol "buffers")) + ;; FD_SETSIZE is typically 1024 on Unix-like systems. On + ;; MS-Windows we artificially limit FD_SETSIZE to 64, see the + ;; commentary in w32proc.c. + (fd-setsize (if (eq system-type 'windows-nt) 64 1024))) + `(process-tests--with-raised-rlimit + (process-tests--with-buffers ,buffers + (process-tests--with-processes ,processes + ;; First, allocate enough pipes to definitely exceed the + ;; FD_SETSIZE limit. + (cl-loop for i from 1 to ,(1+ fd-setsize) + for ,buffer = (generate-new-buffer + (format " *pipe %d*" i)) + do (push ,buffer ,buffers) + for ,process = (process-tests--ignore-EMFILE + (make-pipe-process + :name (format "pipe %d" i) + ;; Prevent delete-process from + ;; trying to read from pipe + ;; processes that didn't exit + ;; yet, because no one is + ;; writing to those pipes, and + ;; the read will stall. + :stop (eq system-type 'windows-nt) + :buffer ,buffer + :coding 'no-conversion + :noquery t)) + while ,process + do (push ,process ,processes)) + (unless (cddr ,processes) + (ert-fail "Couldn't allocate enough pipes")) + ;; Delete two pipes to test more edge cases. + (delete-process (pop ,processes)) + (delete-process (pop ,processes)) + ,@body))))) + +(defmacro process-tests--with-temp-file (var &rest body) + "Bind VAR to the name of a new regular file and evaluate BODY. +Afterwards, delete the file." + (declare (indent 1) (debug (symbolp body))) + (cl-check-type var symbol) + (let ((file (make-symbol "file"))) + `(let ((,file (make-temp-file "emacs-test-"))) + (unwind-protect + (let ((,var ,file)) + ,@body) + (delete-file ,file))))) + +(defmacro process-tests--with-temp-directory (var &rest body) + "Bind VAR to the name of a new directory and evaluate BODY. +Afterwards, delete the directory." + (declare (indent 1) (debug (symbolp body))) + (cl-check-type var symbol) + (let ((dir (make-symbol "dir"))) + `(let ((,dir (make-temp-file "emacs-test-" :dir))) + (unwind-protect + (let ((,var ,dir)) + ,@body) + (delete-directory ,dir :recursive))))) + +;; Tests for FD_SETSIZE overflow (Bug#24325). The following tests +;; generate lots of process objects of the various kinds. Running the +;; tests with assertions enabled should not result in any crashes due +;; to file descriptor set overflow. These tests first generate lots +;; of unused pipe processes to fill up the file descriptor space. +;; Then, they create a few instances of the process type under test. + +(ert-deftest process-tests/fd-setsize-no-crash/make-process () + "Check that Emacs doesn't crash when trying to use more than +FD_SETSIZE file descriptors (Bug#24325)." + (with-timeout (60 (ert-fail "Test timed out")) + (let ((sleep (executable-find "sleep"))) + (skip-unless sleep) + (dolist (conn-type '(pipe pty)) + (ert-info ((format "Connection type `%s'" conn-type)) + (process-tests--fd-setsize-test + (process-tests--with-processes processes + ;; Start processes until we exhaust the file descriptor + ;; set size. We assume that each process requires at + ;; least one file descriptor. + (dotimes (i 10) + (let ((process + ;; Failure to allocate more file descriptors + ;; should signal `file-error', but not crash. + ;; Since we don't know the exact limit, we + ;; ignore `file-error'. + (process-tests--ignore-EMFILE + (make-process :name (format "test %d" i) + :command (list sleep "5") + :connection-type conn-type + :coding 'no-conversion + :noquery t)))) + (when process (push process processes)))) + ;; We should have managed to start at least one process. + (should processes) + (dolist (process processes) + (while (accept-process-output process)) + (should (eq (process-status process) 'exit)) + ;; If there's an error between fork and exec, Emacs + ;; will use exit statuses between 125 and 127, see + ;; process.h. This can happen if the child process + ;; tries to set up terminal device but fails due to + ;; file number limits. We don't treat this as an + ;; error. + (should (memql (process-exit-status process) + '(0 125 126 127))))))))))) + +(ert-deftest process-tests/fd-setsize-no-crash/make-pipe-process () + "Check that Emacs doesn't crash when trying to use more than +FD_SETSIZE file descriptors (Bug#24325)." + (with-timeout (60 (ert-fail "Test timed out")) + (process-tests--fd-setsize-test + (process-tests--with-buffers buffers + (process-tests--with-processes processes + ;; Start processes until we exhaust the file descriptor set + ;; size. We assume that each process requires at least one + ;; file descriptor. + (dotimes (i 10) + (let ((buffer (generate-new-buffer (format " *%d*" i)))) + (push buffer buffers) + (let ((process + ;; Failure to allocate more file descriptors + ;; should signal `file-error', but not crash. + ;; Since we don't know the exact limit, we ignore + ;; `file-error'. + (process-tests--ignore-EMFILE + (make-pipe-process :name (format "test %d" i) + :buffer buffer + :coding 'no-conversion + :noquery t)))) + (when process (push process processes))))) + ;; We should have managed to start at least one process. + (should processes)))))) + +(ert-deftest process-tests/fd-setsize-no-crash/make-network-process () + "Check that Emacs doesn't crash when trying to use more than +FD_SETSIZE file descriptors (Bug#24325)." + (skip-unless (featurep 'make-network-process '(:server t))) + (skip-unless (featurep 'make-network-process '(:family local))) + (with-timeout (60 (ert-fail "Test timed out")) + (process-tests--with-temp-directory directory + (process-tests--with-processes processes + (let* ((num-clients 10) + (socket-name (expand-file-name "socket" directory)) + ;; Run a UNIX server to connect to. + (server (make-network-process :name "server" + :server num-clients + :buffer nil + :service socket-name + :family 'local + :coding 'no-conversion + :noquery t))) + (push server processes) + (process-tests--fd-setsize-test + ;; Start processes until we exhaust the file descriptor + ;; set size. We assume that each process requires at + ;; least one file descriptor. + (dotimes (i num-clients) + (let ((client + ;; Failure to allocate more file descriptors + ;; should signal `file-error', but not crash. + ;; Since we don't know the exact limit, we ignore + ;; `file-error'. + (process-tests--ignore-EMFILE + (make-network-process + :name (format "client %d" i) + :service socket-name + :family 'local + :coding 'no-conversion + :noquery t)))) + (when client (push client processes)))) + ;; We should have managed to start at least one process. + (should processes))))))) + +(ert-deftest process-tests/fd-setsize-no-crash/make-serial-process () + "Check that Emacs doesn't crash when trying to use more than +FD_SETSIZE file descriptors (Bug#24325)." + (with-timeout (60 (ert-fail "Test timed out")) + (skip-unless (file-executable-p shell-file-name)) + (skip-unless (executable-find "tty")) + (skip-unless (executable-find "sleep")) + ;; `process-tests--new-pty' probably only works with GNU Bash. + (skip-unless (string-equal + (file-name-nondirectory shell-file-name) "bash")) + (process-tests--with-processes processes + ;; In order to use `make-serial-process', we need to create some + ;; pseudoterminals. The easiest way to do that is to start a + ;; normal process using the `pty' connection type. We need to + ;; ensure that the terminal stays around while we connect to it. + ;; Create the host processes before the dummy pipes so we have a + ;; high chance of succeeding here. + (let ((tty-names ())) + (dotimes (_ 10) + (cl-destructuring-bind + (host tty-name) (process-tests--new-pty) + (should (processp host)) + (push host processes) + (should tty-name) + (should (file-exists-p tty-name)) + (push tty-name tty-names))) + (process-tests--fd-setsize-test + (process-tests--with-processes processes + (process-tests--with-buffers buffers + (dolist (tty-name tty-names) + (let ((buffer (generate-new-buffer + (format " *%s*" tty-name)))) + (push buffer buffers) + ;; Failure to allocate more file descriptors should + ;; signal `file-error', but not crash. Since we + ;; don't know the exact limit, we ignore + ;; `file-error'. + (let ((process (process-tests--ignore-EMFILE + (make-serial-process + :name (format "test %s" tty-name) + :port tty-name + :speed 9600 + :buffer buffer + :coding 'no-conversion + :noquery t)))) + (when process (push process processes)))))) + ;; We should have managed to start at least one process. + (should processes))))))) + +(defvar process-tests--EMFILE-message :unknown + "Cached result of the function `process-tests--EMFILE-message'.") + +(defun process-tests--EMFILE-message () + "Return the error message for the EMFILE POSIX error. +Return nil if that can't be determined." + (when (eq process-tests--EMFILE-message :unknown) + (setq process-tests--EMFILE-message + (with-temp-buffer + (when (eql (ignore-error 'file-error + (call-process "errno" nil t nil "EMFILE")) + 0) + (goto-char (point-min)) + (when (looking-at (rx "EMFILE" (+ blank) (+ digit) + (+ blank) (group (+ nonl)))) + (match-string-no-properties 1)))))) + process-tests--EMFILE-message) + +(defun process-tests--new-pty () + "Allocate a new pseudoterminal. +Return a list (PROCESS TTY-NAME)." + ;; The command below will typically only work with GNU Bash. + (should (string-equal (file-name-nondirectory shell-file-name) + "bash")) + (process-tests--with-temp-file temp-file + (should-not (file-remote-p temp-file)) + (let* ((command (list shell-file-name shell-command-switch + (format "tty > %s && sleep 60" + (shell-quote-argument + (file-name-unquote temp-file))))) + (process (make-process :name "tty host" + :command command + :buffer nil + :coding 'utf-8-unix + :connection-type 'pty + :noquery t)) + (tty-name nil) + (coding-system-for-read 'utf-8-unix) + (coding-system-for-write 'utf-8-unix)) + ;; Wait until TTY name has arrived. + (with-timeout (2 (message "Timed out waiting for TTY name")) + (while (and (process-live-p process) (not tty-name)) + (sleep-for 0.1) + (when-let ((attributes (file-attributes temp-file))) + (when (cl-plusp (file-attribute-size attributes)) + (with-temp-buffer + (insert-file-contents temp-file) + (goto-char (point-max)) + ;; `tty' has printed a trailing newline. + (skip-chars-backward "\n") + (unless (bobp) + (setq tty-name (buffer-substring-no-properties + (point-min) (point))))))))) + (list process tty-name)))) (provide 'process-tests) -;; process-tests.el ends here. +;;; process-tests.el ends here diff --git a/test/src/regex-emacs-tests.el b/test/src/regex-emacs-tests.el index bb564a4fe25..0607eacf397 100644 --- a/test/src/regex-emacs-tests.el +++ b/test/src/regex-emacs-tests.el @@ -161,7 +161,7 @@ what failed, if anything; valid values are 'search-failed, 'compilation-failed and nil. I compare the beginning/end of each group with their expected values. This is done with either BOUNDS-REF or SUBSTRING-REF; one of those should be non-nil. -BOUNDS-REF is a sequence \[start-ref0 end-ref0 start-ref1 +BOUNDS-REF is a sequence [start-ref0 end-ref0 start-ref1 end-ref1 ....] while SUBSTRING-REF is the expected substring obtained by indexing the input string by start/end-ref. @@ -327,7 +327,7 @@ emacs requires an extra symbol character" (defun regex-tests-BOOST-frob-escapes (s ispattern) "Mangle \\ the way it is done in frob_escapes() in regex-tests-BOOST.c in glibc: \\t, \\n, \\r are interpreted; -\\\\, \\^, \{, \\|, \} are unescaped for the string (not +\\\\, \\^, \\{, \\|, \\} are unescaped for the string (not pattern)" ;; this is all similar to (regex-tests-unextend) @@ -505,7 +505,7 @@ differences in behavior.") (cond ;; pattern - ((save-excursion (re-search-forward "^/\\(.*\\)/\\(.*i?\\)$" nil t)) + ((save-excursion (re-search-forward "^/\\(.*\\)/\\(.*\\)$" nil t)) (setq icase (string= "i" (match-string 2)) pattern (regex-tests-unextend (match-string 1)))) @@ -803,4 +803,68 @@ This evaluates the TESTS test cases from glibc." (should-not (string-match "å" "\xe5")) (should-not (string-match "[å]" "\xe5"))) +(ert-deftest regexp-case-fold () + "Test case-sensitive and case-insensitive matching." + (let ((case-fold-search nil)) + (should (equal (string-match "aB" "ABaB") 2)) + (should (equal (string-match "åÄ" "ÅäåäÅÄåÄ") 6)) + (should (equal (string-match "λΛ" "lΛλλΛ") 3)) + (should (equal (string-match "шШ" "zШшшШ") 3)) + (should (equal (string-match "[[:alpha:]]+" ".3aBåÄßλΛшШ中﷽") 2)) + (should (equal (match-end 0) 12)) + (should (equal (string-match "[[:alnum:]]+" ".3aBåÄßλΛшШ中﷽") 1)) + (should (equal (match-end 0) 12)) + (should (equal (string-match "[[:upper:]]+" ".3aåλшBÄΛШ中﷽") 6)) + (should (equal (match-end 0) 10)) + (should (equal (string-match "[[:lower:]]+" ".3BÄΛШaåλш中﷽") 6)) + (should (equal (match-end 0) 10))) + (let ((case-fold-search t)) + (should (equal (string-match "aB" "ABaB") 0)) + (should (equal (string-match "åÄ" "ÅäåäÅÄåÄ") 0)) + (should (equal (string-match "λΛ" "lΛλλΛ") 1)) + (should (equal (string-match "шШ" "zШшшШ") 1)) + (should (equal (string-match "[[:alpha:]]+" ".3aBåÄßλΛшШ中﷽") 2)) + (should (equal (match-end 0) 12)) + (should (equal (string-match "[[:alnum:]]+" ".3aBåÄßλΛшШ中﷽") 1)) + (should (equal (match-end 0) 12)) + (should (equal (string-match "[[:upper:]]+" ".3aåλшBÄΛШ中﷽") 2)) + (should (equal (match-end 0) 10)) + (should (equal (string-match "[[:lower:]]+" ".3BÄΛШaåλш中﷽") 2)) + (should (equal (match-end 0) 10)))) + +(ert-deftest regexp-eszett () + "Test matching of ß and ẞ." + ;; Sanity checks. + (should (equal (upcase "ß") "SS")) + (should (equal (downcase "ß") "ß")) + (should (equal (capitalize "ß") "Ss")) ; undeutsch... + (should (equal (upcase "ẞ") "ẞ")) + (should (equal (downcase "ẞ") "ß")) + (should (equal (capitalize "ẞ") "ẞ")) + ;; ß is a lower-case letter (Ll); ẞ is an upper-case letter (Lu). + (let ((case-fold-search nil)) + (should (equal (string-match "ß" "ß") 0)) + (should (equal (string-match "ß" "ẞ") nil)) + (should (equal (string-match "ẞ" "ß") nil)) + (should (equal (string-match "ẞ" "ẞ") 0)) + (should (equal (string-match "[[:alpha:]]" "ß") 0)) + ;; bug#11309 + (should (equal (string-match "[[:lower:]]" "ß") 0)) + (should (equal (string-match "[[:upper:]]" "ß") nil)) + (should (equal (string-match "[[:alpha:]]" "ẞ") 0)) + (should (equal (string-match "[[:lower:]]" "ẞ") nil)) + (should (equal (string-match "[[:upper:]]" "ẞ") 0))) + (let ((case-fold-search t)) + (should (equal (string-match "ß" "ß") 0)) + (should (equal (string-match "ß" "ẞ") 0)) + (should (equal (string-match "ẞ" "ß") 0)) + (should (equal (string-match "ẞ" "ẞ") 0)) + (should (equal (string-match "[[:alpha:]]" "ß") 0)) + ;; bug#11309 + (should (equal (string-match "[[:lower:]]" "ß") 0)) + (should (equal (string-match "[[:upper:]]" "ß") 0)) + (should (equal (string-match "[[:alpha:]]" "ẞ") 0)) + (should (equal (string-match "[[:lower:]]" "ẞ") 0)) + (should (equal (string-match "[[:upper:]]" "ẞ") 0)))) + ;;; regex-emacs-tests.el ends here diff --git a/test/src/regex-resources/BOOST.tests b/test/src/regex-resources/BOOST.tests index 98fd3b6abf3..756fa00486b 100644 --- a/test/src/regex-resources/BOOST.tests +++ b/test/src/regex-resources/BOOST.tests @@ -93,7 +93,7 @@ aa\) ! . \0 0 1 ; -; now move on to the repetion ops, +; now move on to the repetition ops, ; starting with operator * - match_default normal REG_EXTENDED a* b 0 0 @@ -275,7 +275,7 @@ a(b*)c\1d abbcbbbd -1 -1 ^(.)\1 abc -1 -1 a([bc])\1d abcdabbd 4 8 5 6 ; strictly speaking this is at best ambiguous, at worst wrong, this is what most -; re implimentations will match though. +; re implementations will match though. a(([bc])\2)*d abbccd 0 6 3 5 3 4 a(([bc])\2)*d abbcbd -1 -1 diff --git a/test/src/syntax-resources/syntax-comments.txt b/test/src/syntax-resources/syntax-comments.txt new file mode 100644 index 00000000000..a292d816b9d --- /dev/null +++ b/test/src/syntax-resources/syntax-comments.txt @@ -0,0 +1,94 @@ +/* This file is a test file for tests of the comment handling in src/syntax.c. + This includes the testing of comments which figure in parse-partial-sexp + and scan-lists. */ + +/* Straight C comments */ +1/* comment */1 +2/**/2 +3// comment +3 +4// +4 +5/*/5 +6*/6 +7/* \*/7 +8*/8 +9/* \\*/9 +10*/10 +11// \ +12 +11 +13// \\ +14 +13 +15/* /*/15 + +/* C Comments within lists */ +59}59 +50{ /*70 comment */71 }50 +51{ /**/ }51 +52{ //72 comment +73}52 +53{ // +}53 +54{ //74 \ +}54 +55{/* */}55 +56{ /*76 \*/ }56 +57*/77 +58}58 +60{ /*78 \\*/79}60 + + +/* Straight Pascal comments (not nested) */ +20}20 +21{ Comment }21 +22{}22 +23{ +}23 +24{ +25{25 +}24 +26{ \}26 + + +/* Straight Lisp comments (not nested) */ +30 +30 +31; Comment +31 +32;;;;;;;;; +32 +33; \ +33 + +/* Lisp comments within lists */ +40)40 +41(;90 comment +91)41 +42(;92\ +93)42 +43( ;94 +95 + +/* Nested Lisp comments */ +100|#100 +101#|# +102#||#102 +103#| Comment |#103 +104#| Comment +|#104 +105#|#|#105 +106#| #| Comment |# |#106 +107#|#|#|#|#|#|#|#|#| Comment |#|#|#|#|#|#|#|#|#107 + +/* Mixed Lisp comments */ +110; #| +110 +111#| ; |#111 + +Local Variables: +mode: fundamental +eval: (set-syntax-table (make-syntax-table)) +End: +999
\ No newline at end of file diff --git a/test/src/syntax-tests.el b/test/src/syntax-tests.el index 52b70fc404d..479b818935f 100644 --- a/test/src/syntax-tests.el +++ b/test/src/syntax-tests.el @@ -20,6 +20,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (ert-deftest parse-partial-sexp-continue-over-comment-marker () "Continue a parse that stopped in the middle of a comment marker." @@ -82,4 +83,410 @@ also has open paren syntax (see Bug#24870)." (should (equal (parse-partial-sexp pointC pointX nil nil ppsC) ppsX))))) + +;;; Commentary: +;; The next bit tests the handling of comments in syntax.c, in +;; particular the functions `forward-comment' and `scan-lists' and +;; `parse-partial-sexp' (in so far as they relate to comments). + +;; It is intended to enhance this bit to test nested comments +;; (2020-10-01). + +;; This bit uses the data file syntax-resources/syntax-comments.txt. + +(defun syntax-comments-point (n forw) + "Return the buffer offset corresponding to the \"label\" N. +N is a decimal number which appears in the data file, usually +twice, as \"labels\". It can also be a negative number or zero. +FORW is t when we're using the label at BOL, nil for the one at EOL. + +If the label N doesn't exist in the current buffer, an exception +is thrown. + +When FORW is t and N positive, we return the position after the +first occurrence of label N at BOL in the data file. With FORW +nil, we return the position before the last occurrence of the +label at EOL in the data file. + +When N is negative, we return instead the position of the end of +line that the -N label is on. When it is zero, we return POINT." + (if (zerop n) + (point) + (let ((str (format "%d" (abs n)))) + (save-excursion + (if forw + (progn + (goto-char (point-min)) + (re-search-forward + (concat "^\\(" str "\\)\\([^0-9\n]\\|$\\)")) + (if (< n 0) + (progn (end-of-line) (point)) + (match-end 1))) + (goto-char (point-max)) + (re-search-backward + (concat "\\(^\\|[^0-9]\\)\\(" str "\\)$")) + (if (< n 0) + (progn (end-of-line) (point)) + (match-beginning 2))))))) + +(defun syntax-comments-midpoint (n) + "Return the buffer offset corresponding to the \"label\" N. +N is a positive decimal number which should appear in the buffer +exactly once. The label need not be at the beginning or end of a +line. + +The return value is the position just before the label. + +If the label N doesn't exist in the current buffer, an exception +is thrown." + (let ((str (format "%d" n))) + (save-excursion + (goto-char (point-min)) + (re-search-forward + (concat "\\(^\\|[^0-9]\\)\\(" str "\\)\\([^0-9\n]\\|$\\)")) + (match-beginning 2)))) + +(eval-and-compile + (defvar syntax-comments-section)) + +(defmacro syntax-comments (-type- -dir- res start &optional stop) + "Create an ERT test to test (forward-comment 1/-1). +The test uses a fixed name data file, which it visits. It calls +entry and exit functions to set up and tear down syntax entries +for comment characters. The test is given a name based on the +global variable `syntax-comments-section', the direction of +movement and the value of START. + +-TYPE- (unquoted) is a symbol from whose name the entry and exit +function names are derived by appending \"-in\" and \"-out\". + +-DIR- (unquoted) is `forward' or `backward', the direction +`forward-comment' is attempted. + +RES, t or nil, is the expected result from `forward-comment'. + +START and STOP are decimal numbers corresponding to labels in the +data file marking the start and expected stop positions. See +`syntax-comments-point' for a precise specification. If STOP is +missing or nil, the value of START is assumed for it." + (declare (debug t)) + (let ((forw + (cond + ((eq -dir- 'forward) t) + ((eq -dir- 'backward) nil) + (t (error "Invalid -dir- argument \"%s\" to `syntax-comments'" -dir-)))) + (start-str (format "%d" (abs start))) + (type -type-)) + `(ert-deftest ,(intern (concat "syntax-comments-" + syntax-comments-section + (if forw "-f" "-b") start-str)) + () + (with-current-buffer + (find-file + ,(ert-resource-file "syntax-comments.txt")) + (,(intern (concat (symbol-name type) "-in"))) + (goto-char (syntax-comments-point ,start ,forw)) + (let ((stop (syntax-comments-point ,(or stop start) ,(not forw)))) + (should (eq (forward-comment ,(if forw 1 -1)) ,res)) + (should (eq (point) stop))) + (,(intern (concat (symbol-name type) "-out"))))))) + +(defmacro syntax-br-comments (-type- -dir- res -start- &optional stop) + "Create an ERT test to test (scan-lists <position> 1/-1 0). +This is to test the interface between scan-lists and the internal +comment routines in syntax.c. + +The test uses a fixed name data file, which it visits. It calls +entry and exit functions to set up and tear down syntax entries +for comment and paren characters. The test is given a name based +on the global variable `syntax-comments-section', the direction +of movement and the value of -START-. + +-TYPE- (unquoted) is a symbol from whose name the entry and exit +function names are derived by appending \"-in\" and \"-out\". + +-DIR- (unquoted) is `forward' or `backward', the direction +`scan-lists' is attempted. + +RES is t if `scan-lists' is expected to return, nil if it is +expected to raise a `scan-error' exception. + +-START- and STOP are decimal numbers corresponding to labels in the +data file marking the start and expected stop positions. See +`syntax-comments-point' for a precise specification. If STOP is +missing or nil, the value of -START- is assumed for it." + (declare (debug t)) + (let* ((forw + (cond + ((eq -dir- 'forward) t) + ((eq -dir- 'backward) nil) + (t (error "Invalid -dir- argument \"%s\" to `syntax-br-comments'" -dir-)))) + (start -start-) + (start-str (format "%d" (abs start))) + (type -type-)) + `(ert-deftest ,(intern (concat "syntax-br-comments-" + syntax-comments-section + (if forw "-f" "-b") start-str)) + () + (with-current-buffer + (find-file + ,(ert-resource-file "syntax-comments.txt")) + (,(intern (concat (symbol-name type) "-in"))) + (let ((start-pos (syntax-comments-point ,start ,forw)) + ,@(if res + `((stop-pos (syntax-comments-point + ,(or stop start) ,(not forw)))))) + ,(if res + `(should + (eq (scan-lists start-pos ,(if forw 1 -1) 0) + stop-pos)) + `(should-error (scan-lists start-pos ,(if forw 1 -1) 0) + :type 'scan-error))) + (,(intern (concat (symbol-name type) "-out"))))))) + +(defmacro syntax-pps-comments (-type- -start- open close &optional -stop-) + "Create an ERT test to test `parse-partial-sexp' with comments. +This is to test the interface between `parse-partial-sexp' and +the internal comment routines in syntax.c. + +The test uses a fixed name data file, which it visits. It calls +entry and exit functions to set up and tear down syntax entries +for comment and paren characters. The test is given a name based +on the global variable `syntax-comments-section', and the value +of -START-. + +The generated test calls `parse-partial-sexp' three times, the +first two with COMMENTSTOP set to `syntax-table' so as to stop +after the start and end of the comment. The third call is +expected to stop at the brace/paren matching the one where the +test started. + +-TYPE- (unquoted) is a symbol from whose name the entry and exit +function names are derived by appending \"-in\" and \"-out\". + +-START- and -STOP- are decimal numbers corresponding to labels in +the data file marking the start and expected stop positions. See +`syntax-comments-point' for a precise specification. If -STOP- +is missing or nil, the value of -START- is assumed for it. + +OPEN and CLOSE are decimal numbers corresponding to labels in the +data file marking just after the comment opener and closer where +the `parse-partial-sexp's are expected to stop. See +`syntax-comments-midpoint' for a precise specification." + (declare (debug t)) + (let* ((type -type-) + (start -start-) + (start-str (format "%d" start)) + (stop (or -stop- start))) + `(ert-deftest ,(intern (concat "syntax-pps-comments-" + syntax-comments-section + "-" start-str)) + () + (with-current-buffer + (find-file + ,(ert-resource-file "syntax-comments.txt")) + (,(intern (concat (symbol-name type) "-in"))) + (let ((start-pos (syntax-comments-point ,start t)) + (open-pos (syntax-comments-midpoint ,open)) + (close-pos (syntax-comments-midpoint ,close)) + (stop-pos (syntax-comments-point ,stop nil)) + s) + (setq s (parse-partial-sexp + start-pos (point-max) 0 nil nil 'syntax-table)) + (should (eq (point) open-pos)) + (setq s (parse-partial-sexp + (point) (point-max) 0 nil s 'syntax-table)) + (should (eq (point) close-pos)) + (setq s (parse-partial-sexp (point) (point-max) 0 nil s)) + (should (eq (point) stop-pos))) + (,(intern (concat (symbol-name type) "-out"))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; "Pascal" style comments - single character delimiters, the closing +;; delimiter not being newline. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun {-in () + (setq parse-sexp-ignore-comments t) + (setq comment-end-can-be-escaped nil) + (modify-syntax-entry ?{ "<") + (modify-syntax-entry ?} ">")) +(defun {-out () + (modify-syntax-entry ?{ "(}") + (modify-syntax-entry ?} "){")) +(eval-and-compile + (setq syntax-comments-section "pascal")) + +(syntax-comments { forward nil 20 0) +(syntax-comments { backward nil 20 0) +(syntax-comments { forward t 21) +(syntax-comments { backward t 21) +(syntax-comments { forward t 22) +(syntax-comments { backward t 22) + +(syntax-comments { forward t 23) +(syntax-comments { backward t 23) +(syntax-comments { forward t 24) +(syntax-comments { backward t 24) +(syntax-comments { forward t 26) +(syntax-comments { backward t 26) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; "Lisp" style comments - single character opening delimiters on line +;; comments. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun \;-in () + (setq parse-sexp-ignore-comments t) + (setq comment-end-can-be-escaped nil) + (modify-syntax-entry ?\n ">") + (modify-syntax-entry ?\; "<") + (modify-syntax-entry ?{ ".") + (modify-syntax-entry ?} ".")) +(defun \;-out () + (modify-syntax-entry ?\n " ") + (modify-syntax-entry ?\; ".") + (modify-syntax-entry ?{ "(}") + (modify-syntax-entry ?} "){")) +(eval-and-compile + (setq syntax-comments-section "lisp")) + +(syntax-comments \; backward nil 30 30) +(syntax-comments \; forward t 31) +(syntax-comments \; backward t 31) +(syntax-comments \; forward t 32) +(syntax-comments \; backward t 32) +(syntax-comments \; forward t 33) +(syntax-comments \; backward t 33) + +;; "Lisp" style comments inside lists. +(syntax-br-comments \; backward nil 40) +(syntax-br-comments \; forward t 41) +(syntax-br-comments \; backward t 41) +(syntax-br-comments \; forward t 42) +(syntax-br-comments \; backward t 42) +(syntax-br-comments \; forward nil 43) + +;; "Lisp" style comments parsed by `parse-partial-sexp'. +(syntax-pps-comments \; 41 90 91) +(syntax-pps-comments \; 42 92 93) +(syntax-pps-comments \; 43 94 95 -999) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; "Lisp" style nested comments: between delimiters #| |#. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun \#|-in () + (setq parse-sexp-ignore-comments t) + (modify-syntax-entry ?# ". 14") + (modify-syntax-entry ?| ". 23n") + (modify-syntax-entry ?\; "< b") + (modify-syntax-entry ?\n "> b")) +(defun \#|-out () + (modify-syntax-entry ?# ".") + (modify-syntax-entry ?| ".") + (modify-syntax-entry ?\; ".") + (modify-syntax-entry ?\n " ")) +(eval-and-compile + (setq syntax-comments-section "lisp-n")) + +(syntax-comments \#| forward nil 100 0) +(syntax-comments \#| backward nil 100 0) +(syntax-comments \#| forward nil 101 -999) +(syntax-comments \#| forward t 102) +(syntax-comments \#| backward t 102) + +(syntax-comments \#| forward t 103) +(syntax-comments \#| backward t 103) +(syntax-comments \#| forward t 104) +(syntax-comments \#| backward t 104) + +(syntax-comments \#| forward nil 105 -999) +(syntax-comments \#| backward t 105) +(syntax-comments \#| forward t 106) +(syntax-comments \#| backward t 106) +(syntax-comments \#| forward t 107) +(syntax-comments \#| backward t 107) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Mixed "Lisp" style (nested and unnested) comments. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(syntax-comments \#| forward t 110) +(syntax-comments \#| backward t 110) +(syntax-comments \#| forward t 111) +(syntax-comments \#| backward t 111) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Emacs 27 "C" style comments - `comment-end-can-be-escaped' is non-nil. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun /*-in () + (setq parse-sexp-ignore-comments t) + (setq comment-end-can-be-escaped t) + (modify-syntax-entry ?/ ". 124b") + (modify-syntax-entry ?* ". 23") + (modify-syntax-entry ?\n "> b")) +(defun /*-out () + (setq comment-end-can-be-escaped nil) + (modify-syntax-entry ?/ ".") + (modify-syntax-entry ?* ".") + (modify-syntax-entry ?\n " ")) +(eval-and-compile + (setq syntax-comments-section "c")) + +(syntax-comments /* forward t 1) +(syntax-comments /* backward t 1) +(syntax-comments /* forward t 2) +(syntax-comments /* backward t 2) +(syntax-comments /* forward t 3) +(syntax-comments /* backward t 3) + +(syntax-comments /* forward t 4) +(syntax-comments /* backward t 4) +(syntax-comments /* forward t 5 6) +(syntax-comments /* backward nil 5 0) +(syntax-comments /* forward nil 6 0) +(syntax-comments /* backward t 6 5) + +(syntax-comments /* forward t 7 8) +(syntax-comments /* backward nil 7 0) +(syntax-comments /* forward nil 8 0) +(syntax-comments /* backward t 8 7) +(syntax-comments /* forward t 9) +(syntax-comments /* backward t 9) + +(syntax-comments /* forward nil 10 0) +(syntax-comments /* backward nil 10 0) +(syntax-comments /* forward t 11) +(syntax-comments /* backward t 11) + +(syntax-comments /* forward t 13 14) +(syntax-comments /* backward nil 13 -14) +(syntax-comments /* forward t 15) +(syntax-comments /* backward t 15) + +;; Emacs 27 "C" style comments inside brace lists. +(syntax-br-comments /* forward t 50) +(syntax-br-comments /* backward t 50) +(syntax-br-comments /* forward t 51) +(syntax-br-comments /* backward t 51) +(syntax-br-comments /* forward t 52) +(syntax-br-comments /* backward t 52) + +(syntax-br-comments /* forward t 53) +(syntax-br-comments /* backward t 53) +(syntax-br-comments /* forward t 54 20) +(syntax-br-comments /* backward t 54) +(syntax-br-comments /* forward t 55) +(syntax-br-comments /* backward t 55) + +(syntax-br-comments /* forward t 56 58) +(syntax-br-comments /* backward t 58 56) +(syntax-br-comments /* backward nil 59) +(syntax-br-comments /* forward t 60) +(syntax-br-comments /* backward t 60) + +;; Emacs 27 "C" style comments parsed by `parse-partial-sexp'. +(syntax-pps-comments /* 50 70 71) +(syntax-pps-comments /* 52 72 73) +(syntax-pps-comments /* 54 74 55 20) +(syntax-pps-comments /* 56 76 77 58) +(syntax-pps-comments /* 60 78 79) + ;;; syntax-tests.el ends here diff --git a/test/src/textprop-tests.el b/test/src/textprop-tests.el index aadd7a9474e..b083588e645 100644 --- a/test/src/textprop-tests.el +++ b/test/src/textprop-tests.el @@ -1,4 +1,4 @@ -;;; textprop-tests.el --- Test suite for text properties. +;;; textprop-tests.el --- Test suite for text properties. -*- lexical-binding: t -*- ;; Copyright (C) 2015-2021 Free Software Foundation, Inc. diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el index 4aba36c2011..f14d2426ef0 100644 --- a/test/src/thread-tests.el +++ b/test/src/thread-tests.el @@ -1,4 +1,4 @@ -;;; threads.el --- tests for threads. +;;; threads.el --- tests for threads. -*- lexical-binding: t -*- ;; Copyright (C) 2012-2021 Free Software Foundation, Inc. diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index ab3ed2ceddf..e55bd1eb4ee 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -1,21 +1,23 @@ -;;; timefns-tests.el -- tests for timefns.c +;;; timefns-tests.el -- tests for timefns.c -*- lexical-binding: t -*- ;; Copyright (C) 2016-2021 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. -;; This program is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: (require 'ert) @@ -124,44 +126,44 @@ ;;; Tests of format-time-string padding (ert-deftest format-time-string-padding-minimal-deletes-unneeded-zeros () - (let ((ref-time (append (encode-time 0 0 0 15 2 2000) '(123450)))) + (let ((ref-time (encode-time '((123450 . 1000000) 0 0 15 2 2000 - - t)))) (should (equal (format-time-string "%-:::z" ref-time "FJT-12") "+12")) - (should (equal (format-time-string "%-N" ref-time) "12345")) - (should (equal (format-time-string "%-6N" ref-time) "12345")) - (should (equal (format-time-string "%-m" ref-time) "2")))) ;not "02" + (should (equal (format-time-string "%-N" ref-time t) "12345")) + (should (equal (format-time-string "%-6N" ref-time t) "12345")) + (should (equal (format-time-string "%-m" ref-time t) "2")))) ;not "02" (ert-deftest format-time-string-padding-minimal-retains-needed-zeros () - (let ((ref-time (append (encode-time 0 0 0 20 10 2000) '(3450)))) + (let ((ref-time (encode-time '((3450 . 1000000) 0 0 20 10 2000 - - t)))) (should (equal (format-time-string "%-z" ref-time "IST-5:30") "+530")) (should (equal (format-time-string "%-4z" ref-time "IST-5:30") "+530")) (should (equal (format-time-string "%4z" ref-time "IST-5:30") "+530")) - (should (equal (format-time-string "%-N" ref-time) "00345")) - (should (equal (format-time-string "%-3N" ref-time) "003")) - (should (equal (format-time-string "%3N" ref-time) "003")) - (should (equal (format-time-string "%-m" ref-time) "10")) ;not "1" - (should (equal (format-time-string "%-1m" ref-time) "10")) ;not "1" - (should (equal (format-time-string "%1m" ref-time) "10")))) ;not "1" + (should (equal (format-time-string "%-N" ref-time t) "00345")) + (should (equal (format-time-string "%-3N" ref-time t) "003")) + (should (equal (format-time-string "%3N" ref-time t) "003")) + (should (equal (format-time-string "%-m" ref-time t) "10")) ;not "1" + (should (equal (format-time-string "%-1m" ref-time t) "10")) ;not "1" + (should (equal (format-time-string "%1m" ref-time t) "10")))) ;not "1" (ert-deftest format-time-string-padding-spaces () - (let ((ref-time (append (encode-time 0 0 0 10 12 2000) '(123000)))) + (let ((ref-time (encode-time '((123000 . 1000000) 0 0 10 12 2000 - - t)))) (should (equal (format-time-string "%_7z" ref-time "CHA-12:45") " +1245")) - (should (equal (format-time-string "%_6N" ref-time) "123 ")) - (should (equal (format-time-string "%_9N" ref-time) "123 ")) - (should (equal (format-time-string "%_12N" ref-time) "123 ")) - (should (equal (format-time-string "%_m" ref-time) "12")) - (should (equal (format-time-string "%_2m" ref-time) "12")) - (should (equal (format-time-string "%_3m" ref-time) " 12")))) + (should (equal (format-time-string "%_6N" ref-time t) "123 ")) + (should (equal (format-time-string "%_9N" ref-time t) "123 ")) + (should (equal (format-time-string "%_12N" ref-time t) "123 ")) + (should (equal (format-time-string "%_m" ref-time t) "12")) + (should (equal (format-time-string "%_2m" ref-time t) "12")) + (should (equal (format-time-string "%_3m" ref-time t) " 12")))) (ert-deftest format-time-string-padding-zeros-adds-on-insignificant-side () "Fractional seconds have a fixed place on the left, and any padding must happen on the right. All other numbers have a fixed place on the right and are padded on the left." - (let ((ref-time (append (encode-time 0 0 0 10 12 2000) '(123000)))) - (should (equal (format-time-string "%3m" ref-time) "012")) + (let ((ref-time (encode-time '((123000 . 1000000) 0 0 10 12 2000 - - t)))) + (should (equal (format-time-string "%3m" ref-time t) "012")) (should (equal (format-time-string "%7z" ref-time "CHA-12:45") "+001245")) - (should (equal (format-time-string "%12N" ref-time) "123000000000")) - (should (equal (format-time-string "%9N" ref-time) "123000000")) - (should (equal (format-time-string "%6N" ref-time) "123000")))) + (should (equal (format-time-string "%12N" ref-time t) "123000000000")) + (should (equal (format-time-string "%9N" ref-time t) "123000000")) + (should (equal (format-time-string "%6N" ref-time t) "123000")))) (ert-deftest time-equal-p-nil-nil () @@ -220,6 +222,9 @@ a fixed place on the right and are padded on the left." '(23752 27217)))) (ert-deftest float-time-precision () + (should (= (float-time '(0 1 0 4025)) 1.000000004025)) + (should (= (float-time '(1000000004025 . 1000000000000)) 1.000000004025)) + (should (< 0 (float-time '(1 . 10000000000)))) (should (< (float-time '(-1 . 10000000000)) 0)) diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el index 75b6d2761f0..055bf102dfc 100644 --- a/test/src/undo-tests.el +++ b/test/src/undo-tests.el @@ -1,21 +1,23 @@ -;;; undo-tests.el --- Tests of primitive-undo +;;; undo-tests.el --- Tests of primitive-undo -*- lexical-binding: t -*- ;; Copyright (C) 2012-2021 Free Software Foundation, Inc. ;; Author: Aaron S. Hawley <aaron.s.hawley@gmail.com> -;; This program is free software: you can redistribute it and/or +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as ;; published by the Free Software Foundation, either version 3 of the ;; License, or (at your option) any later version. ;; -;; This program is distributed in the hope that it will be useful, but +;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -452,7 +454,7 @@ Demonstrates bug 25599." (insert ";; aaaaaaaaa ;; bbbbbbbb") (let ((overlay-modified - (lambda (ov after-p _beg _end &optional length) + (lambda (ov after-p _beg _end &optional _length) (unless after-p (when (overlay-buffer ov) (delete-overlay ov)))))) diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el new file mode 100644 index 00000000000..d13ce77a997 --- /dev/null +++ b/test/src/xdisp-tests.el @@ -0,0 +1,75 @@ +;;; xdisp-tests.el --- tests for xdisp.c functions -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) + +(defmacro xdisp-tests--in-minibuffer (&rest body) + (declare (debug t) (indent 0)) + `(catch 'result + (minibuffer-with-setup-hook + (lambda () + (let ((redisplay-skip-initial-frame nil) + (executing-kbd-macro nil)) ;Don't skip redisplay + (throw 'result (progn . ,body)))) + (let ((executing-kbd-macro t)) ;Force real minibuffer in `read-string'. + (read-string "toto: "))))) + +(ert-deftest xdisp-tests--minibuffer-resizing () ;; bug#43519 + (should + (equal + t + (xdisp-tests--in-minibuffer + (insert "hello") + (let ((ol (make-overlay (point) (point))) + (max-mini-window-height 1) + (text "askdjfhaklsjdfhlkasjdfhklasdhflkasdhflkajsdhflkashdfkljahsdlfkjahsdlfkjhasldkfhalskdjfhalskdfhlaksdhfklasdhflkasdhflkasdhflkajsdhklajsdgh")) + ;; (save-excursion (insert text)) + ;; (sit-for 2) + ;; (delete-region (point) (point-max)) + (put-text-property 0 1 'cursor t text) + (overlay-put ol 'after-string text) + (redisplay 'force) + ;; Make sure we do the see "hello" text. + (prog1 (equal (window-start) (point-min)) + ;; (list (window-start) (window-end) (window-width)) + (delete-overlay ol))))))) + +(ert-deftest xdisp-tests--minibuffer-scroll () ;; bug#44070 + (let ((posns + (xdisp-tests--in-minibuffer + (let ((max-mini-window-height 4)) + (dotimes (_ 80) (insert "\nhello")) + (goto-char (point-min)) + (redisplay 'force) + (goto-char (point-max)) + ;; A simple edit like removing the last `o' shouldn't cause + ;; the rest of the minibuffer's text to move. + (list + (progn (redisplay 'force) (window-start)) + (progn (delete-char -1) + (redisplay 'force) (window-start)) + (progn (goto-char (point-min)) (redisplay 'force) + (goto-char (point-max)) (redisplay 'force) + (window-start))))))) + (should (equal (nth 0 posns) (nth 1 posns))) + (should (equal (nth 1 posns) (nth 2 posns))))) + +;;; xdisp-tests.el ends here diff --git a/test/src/xfaces-tests.el b/test/src/xfaces-tests.el new file mode 100644 index 00000000000..0a7ef55b2b6 --- /dev/null +++ b/test/src/xfaces-tests.el @@ -0,0 +1,50 @@ +;;; xfaces-tests.el --- tests for xfaces.c -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +(require 'ert) + +(ert-deftest xfaces-color-distance () + ;; Check symmetry (bug#41544). + (should (equal (color-distance "#222222" "#ffffff") + (color-distance "#ffffff" "#222222")))) + +(ert-deftest xfaces-internal-color-values-from-color-spec () + (should (equal (color-values-from-color-spec "#f05") + '(#xffff #x0000 #x5555))) + (should (equal (color-values-from-color-spec "#1fb0C5") + '(#x1f1f #xb0b0 #xc5c5))) + (should (equal (color-values-from-color-spec "#1f8b0AC5e") + '(#x1f81 #xb0aa #xc5eb))) + (should (equal (color-values-from-color-spec "#1f83b0ADC5e2") + '(#x1f83 #xb0ad #xc5e2))) + (should (equal (color-values-from-color-spec "#1f83b0ADC5e2g") nil)) + (should (equal (color-values-from-color-spec "#1f83b0ADC5e20") nil)) + (should (equal (color-values-from-color-spec "#12345") nil)) + (should (equal (color-values-from-color-spec "rgb:f/23/28a") + '(#xffff #x2323 #x28a2))) + (should (equal (color-values-from-color-spec "rgb:1234/5678/09ab") + '(#x1234 #x5678 #x09ab))) + (should (equal (color-values-from-color-spec "rgb:0//0") nil)) + (should (equal (color-values-from-color-spec "rgbi:0/0.5/0.1") + '(0 32768 6554))) + (should (equal (color-values-from-color-spec "rgbi:1e-3/1.0e-2/1e0") + '(66 655 65535))) + (should (equal (color-values-from-color-spec "rgbi:0/0.5/10") nil))) + +(provide 'xfaces-tests) diff --git a/test/src/xml-tests.el b/test/src/xml-tests.el index be5fd5134f3..632cf965fa2 100644 --- a/test/src/xml-tests.el +++ b/test/src/xml-tests.el @@ -1,4 +1,4 @@ -;;; libxml-parse-tests.el --- Test suite for libxml parsing. +;;; xml-tests.el --- Test suite for libxml parsing. -*- lexical-binding: t -*- ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. @@ -42,20 +42,6 @@ (comment nil "comment-b") (comment nil "comment-c")))) "Alist of XML strings and their expected parse trees for preserved comments.") -(defvar libxml-tests--data-comments-discarded - `(;; simple case - ("<?xml version=\"1.0\"?><foo baz=\"true\">bar</foo>" - . (foo ((baz . "true")) "bar")) - ;; toplevel comments -- first document child must not get lost - (,(concat "<?xml version=\"1.0\"?><foo>bar</foo><!--comment-1-->" - "<!--comment-2-->") - . (foo nil "bar")) - (,(concat "<?xml version=\"1.0\"?><!--comment-a--><foo a=\"b\">" - "<bar>blub</bar></foo><!--comment-b--><!--comment-c-->") - . (foo ((a . "b")) (bar nil "blub")))) - "Alist of XML strings and their expected parse trees for discarded comments.") - - (ert-deftest libxml-tests () "Test libxml." (when (fboundp 'libxml-parse-xml-region) @@ -64,11 +50,6 @@ (erase-buffer) (insert (car test)) (should (equal (cdr test) - (libxml-parse-xml-region (point-min) (point-max))))) - (dolist (test libxml-tests--data-comments-discarded) - (erase-buffer) - (insert (car test)) - (should (equal (cdr test) - (libxml-parse-xml-region (point-min) (point-max) nil t))))))) + (libxml-parse-xml-region (point-min) (point-max)))))))) ;;; libxml-tests.el ends here |