Merge 'master' into noverlay

1 files changed, 376 insertions, 49 deletions

diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el
index 4b41fc21c20..1099fd04678 100644
--- a/test/src/emacs-module-tests.el
+++ b/test/src/emacs-module-tests.el
@@ -1,6 +1,6 @@
-;;; Test GNU Emacs modules.
+;;; emacs-module-tests.el --- Test GNU Emacs modules.  -*- lexical-binding: t; -*-
 
-;; Copyright 2015-2017 Free Software Foundation, Inc.
+;; Copyright 2015-2022 Free Software Foundation, Inc.
 
 ;; This file is part of GNU Emacs.
 
@@ -17,7 +17,25 @@
 ;; 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 the dynamic module facility.  See Info node `(elisp)
+;; Writing Dynamic Modules'.  These tests make use of a small test
+;; module in the "emacs-module-resources" directory.
+
+;;; Code:
+;;; Prelude
+
+(require 'cl-lib)
 (require 'ert)
+(require 'ert-x)
+(require 'help-fns)
+(require 'subr-x)
+
+;; Catch information for bug#50902.
+(when (getenv "EMACS_EMBA_CI")
+  (start-process-shell-command
+   "*timeout*" nil (format "sleep 60; kill -ABRT %d" (emacs-pid))))
 
 (defconst mod-test-emacs
   (expand-file-name invocation-name invocation-directory)
@@ -25,15 +43,21 @@
 
 (eval-and-compile
   (defconst mod-test-file
-    (substitute-in-file-name
-     "$EMACS_TEST_DIRECTORY/data/emacs-module/mod-test")
+    (expand-file-name "../test/src/emacs-module-resources/mod-test"
+                      invocation-directory)
     "File name of the module test file."))
 
 (require 'mod-test mod-test-file)
 
-;;
-;; Basic tests.
-;;
+(cl-defgeneric emacs-module-tests--generic (_))
+
+(cl-defmethod emacs-module-tests--generic ((_ module-function))
+  'module-function)
+
+(cl-defmethod emacs-module-tests--generic ((_ user-ptr))
+  'user-ptr)
+
+;;; Basic tests
 
 (ert-deftest mod-test-sum-test ()
   (should (= (mod-test-sum 1 2) 3))
@@ -43,8 +67,9 @@
     (should (eq 0
                 (string-match
                  (concat "#<module function "
-                         "\\(at \\(0x\\)?[0-9a-fA-F]+\\( 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)
@@ -57,12 +82,12 @@
   (when (< #x1fffffff most-positive-fixnum)
     (should (= (mod-test-sum 1 #x1fffffff)
                (1+ #x1fffffff)))
-    (should (= (mod-test-sum -1 #x20000000)
+    (should (= (mod-test-sum -1 (1+ #x1fffffff))
                #x1fffffff)))
-  (should-error (mod-test-sum 1 most-positive-fixnum)
-                :type 'overflow-error)
-  (should-error (mod-test-sum -1 most-negative-fixnum)
-                :type 'overflow-error))
+  (should (= (mod-test-sum 1 most-positive-fixnum)
+             (1+ most-positive-fixnum)))
+  (should (= (mod-test-sum -1 most-negative-fixnum)
+             (1- most-negative-fixnum))))
 
 (ert-deftest mod-test-sum-docstring ()
   (should (string= (documentation 'mod-test-sum) "Return A + B\n\n(fn a b)")))
@@ -73,18 +98,19 @@ This test needs to be changed whenever the implementation
 changes."
   (let ((func (symbol-function #'mod-test-sum)))
     (should (module-function-p func))
+    (should (functionp func))
     (should (equal (type-of func) 'module-function))
+    (should (eq (emacs-module-tests--generic func) 'module-function))
     (should (string-match-p
              (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))
@@ -121,14 +147,14 @@ 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."
   (let ((res ""))
-    (dotimes (i n res)
-      (setq res (concat res s)))))
+    (dotimes (_ n)
+      (setq res (concat res s)))
+    res))
 
 (ert-deftest mod-test-globref-make-test ()
   (let ((mod-str (mod-test-globref-make))
@@ -136,12 +162,16 @@ changes."
     (garbage-collect) ;; XXX: not enough to really test but it's something..
     (should (string= ref-str mod-str))))
 
+(ert-deftest mod-test-globref-free-test ()
+  (should (eq (mod-test-globref-free 1 'a "test" 'b) 'ok)))
+
+(ert-deftest mod-test-globref-reordered ()
+  (should (equal (mod-test-globref-reordered) '(t t t nil))))
+
 (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)
@@ -149,14 +179,13 @@ changes."
          (r (mod-test-userptr-get v)))
 
     (should (eq (type-of v) 'user-ptr))
+    (should (eq (emacs-module-tests--generic v) 'user-ptr))
     (should (integerp r))
     (should (= r n))))
 
 ;; TODO: try to test finalizer
 
-;;
-;; Vector tests.
-;;
+;;; Vector tests
 
 (ert-deftest mod-test-vector-test ()
   (dolist (s '(2 10 100 1000))
@@ -182,20 +211,6 @@ changes."
   (should (equal (help-function-arglist #'mod-test-sum)
                  '(arg1 arg2))))
 
-(defmacro module--with-temp-directory (name &rest body)
-  "Bind NAME to the name of a temporary directory and evaluate BODY.
-NAME must be a symbol.  Delete the temporary directory after BODY
-exits normally or non-locally.  NAME will be bound to the
-directory name (not the directory file name) of the temporary
-directory."
-  (declare (indent 1))
-  (cl-check-type name symbol)
-  `(let ((,name (file-name-as-directory
-                 (make-temp-file "emacs-module-test" :directory))))
-     (unwind-protect
-         (progn ,@body)
-       (delete-directory ,name :recursive))))
-
 (defmacro module--test-assertion (pattern &rest body)
   "Test that PATTERN matches the assertion triggered by BODY.
 Run Emacs as a subprocess, load the test module `mod-test-file',
@@ -204,7 +219,7 @@ assertion message that matches PATTERN.  PATTERN is evaluated and
 must evaluate to a regular expression string."
   (declare (indent 1))
   ;; To contain any core dumps.
-  `(module--with-temp-directory tempdir
+  `(ert-with-temp-directory tempdir
      (with-temp-buffer
        (let* ((default-directory tempdir)
               (status (call-process mod-test-emacs nil t nil
@@ -231,10 +246,12 @@ must evaluate to a regular expression string."
                                   (point) (point-max))))))))
 
 (ert-deftest module--test-assertions--load-non-live-object ()
-  "Check that -module-assertions verify that non-live objects
-aren’t accessed."
-  (skip-unless (file-executable-p mod-test-emacs))
-  ;; This doesn’t yet cause undefined behavior.
+  "Check that -module-assertions verify that non-live objects aren't accessed."
+  :tags (if (getenv "EMACS_EMBA_CI") '(:unstable))
+  (skip-unless (or (file-executable-p mod-test-emacs)
+                   (and (eq system-type 'windows-nt)
+                        (file-executable-p (concat mod-test-emacs ".exe")))))
+  ;; This doesn't yet cause undefined behavior.
   (should (eq (mod-test-invalid-store) 123))
   (module--test-assertion (rx "Emacs value not found in "
                               (+ digit) " values of "
@@ -244,12 +261,322 @@ aren’t accessed."
     (mod-test-invalid-store)
     (mod-test-invalid-load)))
 
+(ert-deftest module--test-assertions--load-non-live-object-with-global-copy ()
+  "Check that -module-assertions verify that non-live objects aren't accessed.
+This differs from `module--test-assertions-load-non-live-object'
+in that it stows away a global reference.  The module assertions
+should nevertheless detect the invalid load."
+  :tags (if (getenv "EMACS_EMBA_CI") '(:unstable))
+  (skip-unless (or (file-executable-p mod-test-emacs)
+                   (and (eq system-type 'windows-nt)
+                        (file-executable-p (concat mod-test-emacs ".exe")))))
+  ;; This doesn't yet cause undefined behavior.
+  (should (eq (mod-test-invalid-store-copy) 123))
+  (module--test-assertion (rx "Emacs value not found in "
+                              (+ digit) " values of "
+                              (+ digit) " environments\n")
+    ;; Storing and reloading a local value causes undefined behavior,
+    ;; which should be detected by the module assertions.
+    (mod-test-invalid-store-copy)
+    (mod-test-invalid-load)))
+
 (ert-deftest module--test-assertions--call-emacs-from-gc ()
   "Check that -module-assertions prevents calling Emacs functions
 during garbage collection."
-  (skip-unless (file-executable-p mod-test-emacs))
+  :tags (if (getenv "EMACS_EMBA_CI") '(:unstable))
+  (skip-unless (or (file-executable-p mod-test-emacs)
+                   (and (eq system-type 'windows-nt)
+                        (file-executable-p (concat mod-test-emacs ".exe")))))
   (module--test-assertion
       (rx "Module function called during garbage collection\n")
-    (mod-test-invalid-finalizer)))
+    (mod-test-invalid-finalizer)
+    (garbage-collect)))
+
+(ert-deftest module--test-assertions--globref-invalid-free ()
+  "Check that -module-assertions detects invalid freeing of a
+local reference."
+  :tags (if (getenv "EMACS_EMBA_CI") '(:unstable))
+  (skip-unless (or (file-executable-p mod-test-emacs)
+                   (and (eq system-type 'windows-nt)
+                        (file-executable-p (concat mod-test-emacs ".exe")))))
+  (module--test-assertion
+      (rx "Global value was not found in list of " (+ digit) " globals")
+    (mod-test-globref-invalid-free)
+    (garbage-collect)))
+
+(ert-deftest module/describe-function-1 ()
+  "Check that Bug#30163 is fixed."
+  (with-temp-buffer
+    (let ((standard-output (current-buffer))
+          (text-quoting-style 'grave)
+          (fill-column 200))            ; prevent line breaks when filling
+      (describe-function-1 #'mod-test-sum)
+      (goto-char (point-min))
+      (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 `src/emacs-module-resources/mod-test%s'.
+
+(mod-test-sum a b)
+
+Return A + B
+
+"
+                       module-file-suffix))))))
+
+(ert-deftest module/load-history ()
+  "Check that Bug#30164 is fixed."
+  (load mod-test-file)
+  (cl-destructuring-bind (file &rest entries) (car load-history)
+    (should (equal (file-name-sans-extension file) mod-test-file))
+    (should (member '(provide . mod-test) entries))
+    (should (member '(defun . mod-test-sum) entries))))
+
+(ert-deftest mod-test-sleep-until ()
+  "Check that `mod-test-sleep-until' either returns normally or quits.
+Interactively, you can try hitting \\[keyboard-quit] to quit."
+  (skip-unless (fboundp 'mod-test-sleep-until))
+  (dolist (arg '(nil t))
+    ;; Guard against some caller setting `inhibit-quit'.
+    (with-local-quit
+      (condition-case nil
+          (should (eq (with-local-quit
+                        ;; Because `inhibit-quit' is nil here, the next
+                        ;; form either quits or returns `finished'.
+                        (mod-test-sleep-until
+                         ;; Interactively, run for 5 seconds to give the
+                         ;; user time to quit.  In batch mode, run only
+                         ;; briefly since the user can't quit.
+                         (time-add nil (if noninteractive 0.1 5))
+                         ;; should_quit or process_input
+                         arg))
+                      'finished))
+        (quit)))))
+
+(ert-deftest mod-test-add-nanosecond/valid ()
+  (dolist (input (list
+                  ;; Some realistic examples.
+                  (current-time) (time-to-seconds)
+                  (encode-time 12 34 5 6 7 2019 t)
+                  ;; Various legacy timestamp forms.
+                  '(123 456) '(123 456 789) '(123 456 789 6000)
+                  ;; Corner case: this will result in a nanosecond
+                  ;; value of 1000000000 after addition.  The module
+                  ;; code should handle this correctly.
+                  '(123 65535 999999 999000)
+                  ;; Seconds since the epoch.
+                  123 123.45
+                  ;; New (TICKS . HZ) format.
+                  '(123456789 . 1000000000)))
+    (ert-info ((format "input: %s" input))
+      (let ((result (mod-test-add-nanosecond input))
+	    (desired-result
+	     (let ((hz 1000000000))
+	       (time-add (time-convert input hz) (cons 1 hz)))))
+        (should (consp result))
+        (should (integerp (car result)))
+        (should (integerp (cdr result)))
+        (should (cl-plusp (cdr result)))
+        (should (time-equal-p result desired-result))))))
+
+(ert-deftest mod-test-add-nanosecond/nil ()
+  (should (<= (float-time (mod-test-add-nanosecond nil))
+              (+ (float-time) 1e-9))))
+
+(ert-deftest mod-test-add-nanosecond/invalid ()
+  (dolist (input '(1.0e+INF 1.0e-INF 0.0e+NaN (123) (123.45 6 7) "foo" [1 2]))
+    (ert-info ((format "input: %s" input))
+      (should-error (mod-test-add-nanosecond input)))))
+
+(ert-deftest mod-test-nanoseconds ()
+  "Test truncation when converting to `struct timespec'."
+  (skip-unless (fboundp 'mod-test-nanoseconds))
+  (dolist (test-case '((0 . 0)
+                       (-1 . -1000000000)
+                       ((1 . 1000000000) . 1)
+                       ((-1 . 1000000000) . -1)
+                       ((1 . 1000000000000) . 0)
+                       ((-1 . 1000000000000) . -1)
+                       ((999 . 1000000000000) . 0)
+                       ((-999 . 1000000000000) . -1)
+                       ((1000 . 1000000000000) . 1)
+                       ((-1000 . 1000000000000) . -1)
+                       ((0 0 0 1) . 0)
+                       ((0 0 0 -1) . -1)))
+    (let ((input (car test-case))
+          (expected (cdr test-case)))
+      (ert-info ((format "input: %S, expected result: %d" input expected))
+        (should (= (mod-test-nanoseconds input) expected))))))
+
+(ert-deftest mod-test-double ()
+  (skip-unless (fboundp 'mod-test-double))
+  (dolist (input (list 0 1 2 -1 42 12345678901234567890
+                       most-positive-fixnum (1+ most-positive-fixnum)
+                       most-negative-fixnum (1- most-negative-fixnum)))
+    (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