diff options
Diffstat (limited to 'test/src')
56 files changed, 11446 insertions, 888 deletions
diff --git a/test/src/alloc-tests.el b/test/src/alloc-tests.el index aff480c6b66..967833e1903 100644 --- a/test/src/alloc-tests.el +++ b/test/src/alloc-tests.el @@ -1,6 +1,6 @@ ;;; alloc-tests.el --- alloc tests -*- lexical-binding: t -*- -;; Copyright (C) 2015-2017 Free Software Foundation, Inc. +;; Copyright (C) 2015-2022 Free Software Foundation, Inc. ;; Author: Daniel Colascione <dancol@dancol.org> ;; Keywords: @@ -30,7 +30,7 @@ (require 'cl-lib) (ert-deftest finalizer-object-type () - (should (equal (type-of (make-finalizer nil)) 'finalizer))) + (should (equal (type-of (make-finalizer #'ignore)) 'finalizer))) (ert-deftest record-1 () (let ((x (record 'foo 1 2 3))) @@ -51,3 +51,12 @@ (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)))))) + +;;; alloc-tests.el ends here diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 153aea3a20b..a12d15bc798 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -1,6 +1,6 @@ ;;; buffer-tests.el --- tests for buffer.c functions -*- lexical-binding: t -*- -;; Copyright (C) 2015-2017 Free Software Foundation, Inc. +;; Copyright (C) 2015-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -21,6 +21,201 @@ (require 'ert) (require 'seq) +(require 'ert-x) +(require 'cl-lib) +(require 'let-alist) + +(defun overlay-tests-start-recording-modification-hooks (overlay) + "Start recording modification hooks on OVERLAY. + +Always overwrites the `insert-in-front-hooks', +`modification-hooks' and `insert-behind-hooks' properties. Any +recorded history from a previous call is erased. + +The history is stored in a property on the overlay itself. Call +`overlay-tests-get-recorded-modification-hooks' to retrieve the +recorded calls conveniently." + (dolist (hooks-property '(insert-in-front-hooks + modification-hooks + insert-behind-hooks)) + (overlay-put + overlay + hooks-property + (list (lambda (ov &rest args) + (message " %S called on %S with args %S" hooks-property ov args) + (should inhibit-modification-hooks) + (should (eq ov overlay)) + (push (list hooks-property args) + (overlay-get overlay + 'recorded-modification-hook-calls))))) + (overlay-put overlay 'recorded-modification-hook-calls nil))) + +(defun overlay-tests-get-recorded-modification-hooks (overlay) + "Extract the recorded calls made to modification hooks on OVERLAY. + +Must be preceded by a call to +`overlay-tests-start-recording-modification-hooks' on OVERLAY. + +Returns a list. Each element of the list represents a recorded +call to a particular modification hook. + +Each call is itself a sub-list where the first element is a +symbol matching the modification hook property (one of +`insert-in-front-hooks', `modification-hooks' or +`insert-behind-hooks') and the second element is the list of +arguments passed to the hook. The first hook argument, the +overlay itself, is omitted to make test result verification +easier." + (reverse (overlay-get overlay + 'recorded-modification-hook-calls))) + +(ert-deftest overlay-modification-hooks () + "Test the basic functionality of overlay modification hooks. + +This exercises hooks registered on the `insert-in-front-hooks', +`modification-hooks' and `insert-behind-hooks' overlay +properties." + ;; This is a data driven test loop. Each test case is described + ;; by an alist. The test loop initializes a new temporary buffer + ;; for each case, creates an overlay, registers modification hooks + ;; on the overlay, modifies the buffer, and then verifies which + ;; modification hooks (if any) were called for the overlay, as + ;; well as which arguments were passed to the hooks. + ;; + ;; The following keys are available in the alist: + ;; + ;; `buffer-text': the initial buffer text of the temporary buffer. + ;; Defaults to "1234". + ;; + ;; `overlay-beg' and `overlay-end': the begin and end positions of + ;; the overlay under test. Defaults to 2 and 4 respectively. + ;; + ;; `insert-at': move to the given position and insert the string + ;; "x" into the test case's buffer. + ;; + ;; `replace': replace the first occurrence of the given string in + ;; the test case's buffer with "x". The test will fail if the + ;; string is not found. + ;; + ;; `expected-calls': a description of the expected buffer + ;; modification hooks. See + ;; `overlay-tests-get-recorded-modification-hooks' for the format. + ;; May be omitted, in which case the test will insist that no + ;; modification hooks are called. + ;; + ;; The test will fail itself in the degenerate case where no + ;; buffer modifications are requested. + (dolist (test-case + '( + ;; Remember that the default buffer text is "1234" and + ;; the default overlay begins at position 2 and ends at + ;; position 4. Most of the test cases below assume + ;; this. + + ;; TODO: (info "(elisp) Special Properties") says this + ;; about `modification-hooks': "Furthermore, insertion + ;; will not modify any existing character, so this hook + ;; will only be run when removing some characters, + ;; replacing them with others, or changing their + ;; text-properties." So, why are modification-hooks + ;; being called when inserting at position 3 below? + ((insert-at . 1)) + ((insert-at . 2) + (expected-calls . ((insert-in-front-hooks (nil 2 2)) + (insert-in-front-hooks (t 2 3 0))))) + ((insert-at . 3) + (expected-calls . ((modification-hooks (nil 3 3)) + (modification-hooks (t 3 4 0))))) + ((insert-at . 4) + (expected-calls . ((insert-behind-hooks (nil 4 4)) + (insert-behind-hooks (t 4 5 0))))) + ((insert-at . 5)) + + ;; Replacing text never calls `insert-in-front-hooks' + ;; or `insert-behind-hooks'. It calls + ;; `modification-hooks' if the overlay covers any text + ;; that has changed. + ((replace . "1")) + ((replace . "2") + (expected-calls . ((modification-hooks (nil 2 3)) + (modification-hooks (t 2 3 1))))) + ((replace . "3") + (expected-calls . ((modification-hooks (nil 3 4)) + (modification-hooks (t 3 4 1))))) + ((replace . "4")) + ((replace . "12") + (expected-calls . ((modification-hooks (nil 1 3)) + (modification-hooks (t 1 2 2))))) + ((replace . "23") + (expected-calls . ((modification-hooks (nil 2 4)) + (modification-hooks (t 2 3 2))))) + ((replace . "34") + (expected-calls . ((modification-hooks (nil 3 5)) + (modification-hooks (t 3 4 2))))) + ((replace . "123") + (expected-calls . ((modification-hooks (nil 1 4)) + (modification-hooks (t 1 2 3))))) + ((replace . "234") + (expected-calls . ((modification-hooks (nil 2 5)) + (modification-hooks (t 2 3 3))))) + ((replace . "1234") + (expected-calls . ((modification-hooks (nil 1 5)) + (modification-hooks (t 1 2 4))))) + + ;; Inserting at the position of a zero-length overlay + ;; calls both `insert-in-front-hooks' and + ;; `insert-behind-hooks'. + ((buffer-text . "") (overlay-beg . 1) (overlay-end . 1) + (insert-at . 1) + (expected-calls . ((insert-in-front-hooks + (nil 1 1)) + (insert-behind-hooks + (nil 1 1)) + (insert-in-front-hooks + (t 1 2 0)) + (insert-behind-hooks + (t 1 2 0))))))) + (message "BEGIN overlay-modification-hooks test-case %S" test-case) + + ;; All three hooks ignore the overlay's `front-advance' and + ;; `rear-advance' option, so test both ways while expecting the same + ;; result. + (dolist (advance '(nil t)) + (message " advance is %S" advance) + (let-alist test-case + (with-temp-buffer + ;; Set up the temporary buffer and overlay as specified by + ;; the test case. + (insert (or .buffer-text "1234")) + (let ((overlay (make-overlay + (or .overlay-beg 2) + (or .overlay-end 4) + nil + advance advance))) + (message " (buffer-string) is %S" (buffer-string)) + (message " overlay is %S" overlay) + (overlay-tests-start-recording-modification-hooks overlay) + + ;; Modify the buffer, possibly inducing calls to the + ;; overlay's modification hooks. + (should (or .insert-at .replace)) + (when .insert-at + (goto-char .insert-at) + (insert "x") + (message " inserted \"x\" at %S, buffer-string now %S" + .insert-at (buffer-string))) + (when .replace + (goto-char (point-min)) + (search-forward .replace) + (replace-match "x") + (message " replaced %S with \"x\"" .replace)) + + ;; Verify that the expected and actual modification hook + ;; calls match. + (should (equal + .expected-calls + (overlay-tests-get-recorded-modification-hooks + overlay))))))))) (ert-deftest overlay-modification-hooks-message-other-buf () "Test for bug#21824. @@ -46,34 +241,80 @@ with parameters from the *Messages* buffer modification." (should (eq buf (current-buffer)))) (when msg-ov (delete-overlay msg-ov)))))) +(ert-deftest overlay-modification-hooks-deleted-overlay () + "Test for bug#30823." + (let ((check-point nil) + (ov-delete nil) + (ov-set nil)) + (with-temp-buffer + (insert "abc") + (setq ov-set (make-overlay 1 3)) + (overlay-put ov-set 'modification-hooks + (list (lambda (_o after &rest _args) + (and after (setq check-point t))))) + (setq ov-delete (make-overlay 1 3)) + (overlay-put ov-delete 'modification-hooks + (list (lambda (o after &rest _args) + (and (not after) (delete-overlay o))))) + (goto-char 2) + (insert "1") + (should (eq check-point t))))) + (ert-deftest test-generate-new-buffer-name-bug27966 () (should-not (string-equal "nil" (progn (get-buffer-create "nil") (generate-new-buffer-name "nil"))))) - -;; +===================================================================================+ +(ert-deftest test-buffer-base-buffer-indirect () + (with-temp-buffer + (let* ((ind-buf-name (generate-new-buffer-name "indbuf")) + (ind-buf (make-indirect-buffer (current-buffer) ind-buf-name))) + (should (eq (buffer-base-buffer ind-buf) (current-buffer)))))) + +(ert-deftest test-buffer-base-buffer-non-indirect () + (with-temp-buffer + (should (eq (buffer-base-buffer (current-buffer)) nil)))) + +(ert-deftest overlay-evaporation-after-killed-buffer () + (let* ((ols (with-temp-buffer + (insert "toto") + (list + (make-overlay (point-min) (point-max)) + (make-overlay (point-min) (point-max)) + (make-overlay (point-min) (point-max))))) + (ol (nth 1 ols))) + (overlay-put ol 'evaporate t) + ;; Evaporation within move-overlay of an overlay that was deleted because + ;; of a kill-buffer, triggered an assertion failure in unchain_both. + (with-temp-buffer + (insert "toto") + (move-overlay ol (point-min) (point-min))))) + + +;; +==========================================================================+ ;; | Overlay test setup -;; +===================================================================================+ +;; +==========================================================================+ -(eval-when-compile - (defun make-overlay-test-name (fn x y) - (intern (format "test-%s-%s-%s" fn x y)))) +(eval-and-compile + (defun buffer-tests--make-test-name (fn x y) + (intern (format "buffer-tests--%s-%s-%s" fn x y)))) -(defun unmake-ov-test-name (symbol) +(defun buffer-tests--unmake-test-name (symbol) (let ((name (if (stringp symbol) symbol (symbol-name symbol)))) - (when (string-match "\\`test-\\(.*\\)-\\(.*\\)-\\(.*\\)\\'" name) - (list (match-string 1 name) (match-string 2 name) (match-string 3 name))))) + (when (string-match "\\`buffer-tests--\\(.*\\)-\\(.*\\)-\\(.*\\)\\'" name) + (list (match-string 1 name) + (match-string 2 name) + (match-string 3 name))))) (defmacro deftest-make-overlay-1 (id args) (declare (indent 1)) - `(ert-deftest ,(make-overlay-test-name 'make-overlay 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'make-overlay 1 id) () (with-temp-buffer (should ,(cons 'make-overlay args))))) (defmacro deftest-make-overlay-2 (id args condition) (declare (indent 1)) - `(ert-deftest ,(make-overlay-test-name 'make-overlay 2 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'make-overlay 2 id) () (with-temp-buffer (should-error ,(cons 'make-overlay args) @@ -84,7 +325,7 @@ with parameters from the *Messages* buffer modification." (declare (indent 1)) (cl-destructuring-bind (start end sstart send) (append start-end-args start-end-should) - `(ert-deftest ,(make-overlay-test-name 'overlay-start/end 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'overlay-start/end 1 id) () (with-temp-buffer (insert (make-string 9 ?\n)) (let ((ov (make-overlay ,start ,end))) @@ -93,25 +334,26 @@ with parameters from the *Messages* buffer modification." (defmacro deftest-overlay-buffer-1 (id arg-expr should-expr) (declare (indent 1)) - `(ert-deftest ,(make-overlay-test-name 'overlay-buffer 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'overlay-buffer 1 id) () (with-temp-buffer (should (equal (overlay-buffer (make-overlay 1 1 ,arg-expr)) - ,should-expr))))) + ,should-expr))))) (defmacro deftest-overlayp-1 (id arg-expr should-expr) (declare (indent 1)) - `(ert-deftest ,(make-overlay-test-name 'overlay-buffer 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'overlayp 1 id) () (with-temp-buffer (should (equal ,should-expr (overlayp ,arg-expr)))))) (defmacro deftest-next-overlay-change-1 (id pos result &rest ov-tuple) - `(ert-deftest ,(make-overlay-test-name 'next-overlay-change 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'next-overlay-change 1 id) () (let ((tuple (copy-sequence ',ov-tuple))) (with-temp-buffer (insert (make-string (max 100 (if tuple (apply #'max (mapcar - (lambda (m) (apply #'max m)) tuple)) + (lambda (m) (apply #'max m)) + tuple)) 0)) ?\n)) (dolist (tup tuple) @@ -120,13 +362,14 @@ with parameters from the *Messages* buffer modification." ,result)))))) (defmacro deftest-previous-overlay-change-1 (id pos result &rest ov-tuple) - `(ert-deftest ,(make-overlay-test-name 'previous-overlay-change 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'previous-overlay-change 1 id) () (let ((tuple ',ov-tuple)) (with-temp-buffer (insert (make-string (max 100 (if tuple (apply #'max (mapcar - (lambda (m) (apply #'max m)) tuple)) + (lambda (m) (apply #'max m)) + tuple)) 0)) ?\n)) (dolist (tup tuple) @@ -135,7 +378,7 @@ with parameters from the *Messages* buffer modification." ,result)))))) (defmacro deftest-overlays-at-1 (id pos result &rest ov-triple) - `(ert-deftest ,(make-overlay-test-name 'overlays-at 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'overlays-at 1 id) () (let ((pos* ,pos)) (with-temp-buffer (insert (make-string 100 ?\s)) @@ -150,7 +393,7 @@ with parameters from the *Messages* buffer modification." (should (memq (overlay-get ov 'tag) ',result)))))))) (defmacro deftest-overlays-in-1 (id beg end result &rest ov-triple) - `(ert-deftest ,(make-overlay-test-name 'overlays-in 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'overlays-in 1 id) () (let ((beg* ,beg) (end* ,end)) (with-temp-buffer @@ -176,39 +419,42 @@ with parameters from the *Messages* buffer modification." ,@body)))) (defmacro deftest-overlays-equal-1 (id result ov1-args ov2-args) - `(ert-deftest ,(make-overlay-test-name 'overlays-equal 1 id) () - (cl-labels ((create-overlay (args) - (cl-destructuring-bind (start end &optional fa ra &rest properties) - args - (let ((ov (make-overlay start end nil fa ra))) - (while properties - (overlay-put ov (pop properties) (pop properties))) - ov)))) + `(ert-deftest ,(buffer-tests--make-test-name 'overlays-equal 1 id) () + (cl-flet ((create-overlay (args) + (cl-destructuring-bind (start end &optional fa ra + &rest properties) + args + (let ((ov (make-overlay start end nil fa ra))) + (while properties + (overlay-put ov (pop properties) (pop properties))) + ov)))) (with-temp-buffer (insert (make-string 1024 ?\s)) (should (,(if result 'identity 'not) (equal (create-overlay ',ov1-args) (create-overlay ',ov2-args)))))))) - -(defun find-ert-overlay-test (name) - (let ((test (unmake-ov-test-name name))) + +(defun buffer-tests--find-ert-test (name) + (let ((test (buffer-tests--unmake-test-name name))) (or (and test (cl-destructuring-bind (fn x y) test (let ((regexp (format "deftest-%s-%s +%s" fn x y))) (re-search-forward regexp nil t)))) (let ((find-function-regexp-alist - (cl-remove 'find-ert-overlay-test find-function-regexp-alist :key #'cdr))) - (find-function-do-it name 'ert-deftest 'switch-to-buffer-other-window))))) + (cl-remove #'buffer-tests--find-ert-test + find-function-regexp-alist :key #'cdr))) + (find-function-do-it name 'ert-deftest + #'switch-to-buffer-other-window))))) (add-to-list 'find-function-regexp-alist - '(ert-deftest . find-ert-overlay-test)) + `(ert-deftest . ,#'buffer-tests--find-ert-test)) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | make-overlay -;; +===================================================================================+ +;; +==========================================================================+ ;; Test if making an overlay succeeds. (deftest-make-overlay-1 A (1 1)) @@ -237,12 +483,12 @@ with parameters from the *Messages* buffer modification." (deftest-make-overlay-2 I (1 [1]) wrong-type-argument) (deftest-make-overlay-2 J (1 1 (with-temp-buffer (current-buffer))) - error) + error) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | overlay-start/end -;; +===================================================================================+ +;; +==========================================================================+ ;; Test if the overlays return proper positions. point-max of the ;; buffer will equal 10. ARG RESULT @@ -253,7 +499,8 @@ with parameters from the *Messages* buffer modification." (deftest-overlay-start/end-1 E (1 11) (1 10)) (deftest-overlay-start/end-1 F (1 most-positive-fixnum) (1 10)) (deftest-overlay-start/end-1 G (most-positive-fixnum 1) (1 10)) -(deftest-overlay-start/end-1 H (most-positive-fixnum most-positive-fixnum) (10 10)) +(deftest-overlay-start/end-1 H (most-positive-fixnum most-positive-fixnum) + (10 10)) (deftest-overlay-start/end-1 I (100 11) (10 10)) (deftest-overlay-start/end-1 J (11 100) (10 10)) (deftest-overlay-start/end-1 K (0 1) (1 1)) @@ -264,10 +511,10 @@ with parameters from the *Messages* buffer modification." (should-not (overlay-start (with-temp-buffer (make-overlay 1 1)))) (should-not (overlay-end (with-temp-buffer (make-overlay 1 1))))) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | overlay-buffer -;; +===================================================================================+ +;; +==========================================================================+ ;; Test if overlay-buffer returns appropriate values. (deftest-overlay-buffer-1 A (current-buffer) (current-buffer)) @@ -276,10 +523,10 @@ with parameters from the *Messages* buffer modification." (should-error (make-overlay 1 1 (with-temp-buffer (current-buffer))))) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | overlayp -;; +===================================================================================+ +;; +==========================================================================+ ;; Check the overlay predicate. (deftest-overlayp-1 A (make-overlay 1 1) t) @@ -298,10 +545,10 @@ with parameters from the *Messages* buffer modification." (deftest-overlayp-1 N (selected-window) nil) (deftest-overlayp-1 O (selected-frame) nil) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | overlay equality -;; +===================================================================================+ +;; +==========================================================================+ (deftest-overlays-equal-1 A t (1 1) (1 1)) (deftest-overlays-equal-1 B t (5 10) (5 10)) @@ -313,10 +560,10 @@ with parameters from the *Messages* buffer modification." (deftest-overlays-equal-1 H t (10 20 nil nil foo 42) (10 20 nil nil foo 42)) (deftest-overlays-equal-1 I nil (10 20 nil nil foo 42) (10 20 nil nil foo 43)) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | overlay-lists -;; +===================================================================================+ +;; +==========================================================================+ ;; Check whether overlay-lists returns something sensible. (ert-deftest test-overlay-lists-1 () @@ -330,10 +577,10 @@ with parameters from the *Messages* buffer modification." (should (= 10 (length list))) (should (seq-every-p #'overlayp list))))) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | overlay-put/get/properties -;; +===================================================================================+ +;; +==========================================================================+ ;; Test if overlay-put properties can be retrieved by overlay-get and ;; overlay-properties. @@ -361,10 +608,10 @@ with parameters from the *Messages* buffer modification." ;; Check if overlay-properties is a subset. (should (= (length (overlay-properties ov)) (* n 2)))))) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | next-overlay-change -;; +===================================================================================+ +;; +==========================================================================+ ;; Test if next-overlay-change returns RESULT if called with POS in a ;; buffer with overlays corresponding to OVS and point-max >= 100. @@ -383,14 +630,14 @@ with parameters from the *Messages* buffer modification." (deftest-next-overlay-change-1 I 10 (point-max) (10 10)) (deftest-next-overlay-change-1 J 20 (point-max) (10 10)) ;; 2 non-empty, non-intersecting -(deftest-next-overlay-change-1 D 10 20 (20 30) (40 50)) -(deftest-next-overlay-change-1 E 35 40 (20 30) (40 50)) -(deftest-next-overlay-change-1 F 60 (point-max) (20 30) (40 50)) -(deftest-next-overlay-change-1 G 30 40 (20 30) (40 50)) -(deftest-next-overlay-change-1 H 50 (point-max) (20 30) (40 50)) +(deftest-next-overlay-change-1 D2 10 20 (20 30) (40 50)) +(deftest-next-overlay-change-1 E2 35 40 (20 30) (40 50)) +(deftest-next-overlay-change-1 F2 60 (point-max) (20 30) (40 50)) +(deftest-next-overlay-change-1 G2 30 40 (20 30) (40 50)) +(deftest-next-overlay-change-1 H2 50 (point-max) (20 30) (40 50)) ;; 2 non-empty, intersecting -(deftest-next-overlay-change-1 I 10 20 (20 30) (25 35)) -(deftest-next-overlay-change-1 J 20 25 (20 30) (25 35)) +(deftest-next-overlay-change-1 I2 10 20 (20 30) (25 35)) +(deftest-next-overlay-change-1 J2 20 25 (20 30) (25 35)) (deftest-next-overlay-change-1 K 23 25 (20 30) (25 35)) (deftest-next-overlay-change-1 L 25 30 (20 30) (25 35)) (deftest-next-overlay-change-1 M 28 30 (20 30) (25 35)) @@ -420,11 +667,11 @@ with parameters from the *Messages* buffer modification." (deftest-next-overlay-change-1 k 30 (point-max) (20 20) (20 30)) (deftest-next-overlay-change-1 l 40 (point-max) (20 20) (20 30)) ;; 1 empty, 1 non-empty, intersecting at end -(deftest-next-overlay-change-1 h 10 20 (30 30) (20 30)) -(deftest-next-overlay-change-1 i 20 30 (30 30) (20 30)) -(deftest-next-overlay-change-1 j 25 30 (30 30) (20 30)) -(deftest-next-overlay-change-1 k 30 (point-max) (20 20) (20 30)) -(deftest-next-overlay-change-1 l 40 (point-max) (20 20) (20 30)) +(deftest-next-overlay-change-1 h2 10 20 (30 30) (20 30)) +(deftest-next-overlay-change-1 i2 20 30 (30 30) (20 30)) +(deftest-next-overlay-change-1 j2 25 30 (30 30) (20 30)) +(deftest-next-overlay-change-1 k2 30 (point-max) (20 20) (20 30)) +(deftest-next-overlay-change-1 l2 40 (point-max) (20 20) (20 30)) ;; 1 empty, 1 non-empty, intersecting in the middle (deftest-next-overlay-change-1 m 10 20 (25 25) (20 30)) (deftest-next-overlay-change-1 n 20 25 (25 25) (20 30)) @@ -452,10 +699,10 @@ with parameters from the *Messages* buffer modification." (58 66) (41 10) (9 67) (28 88) (27 43) (24 27) (48 36) (5 90) (61 9)) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | previous-overlay-change. -;; +===================================================================================+ +;; +==========================================================================+ ;; Same for previous-overlay-change. ;; 1 non-empty overlay @@ -471,14 +718,14 @@ with parameters from the *Messages* buffer modification." (deftest-previous-overlay-change-1 I 10 1 (10 10)) (deftest-previous-overlay-change-1 J 20 10 (10 10)) ;; 2 non-empty, non-intersecting -(deftest-previous-overlay-change-1 D 10 1 (20 30) (40 50)) -(deftest-previous-overlay-change-1 E 35 30 (20 30) (40 50)) -(deftest-previous-overlay-change-1 F 60 50 (20 30) (40 50)) -(deftest-previous-overlay-change-1 G 30 20 (20 30) (40 50)) -(deftest-previous-overlay-change-1 H 50 40 (20 30) (40 50)) +(deftest-previous-overlay-change-1 D2 10 1 (20 30) (40 50)) +(deftest-previous-overlay-change-1 E2 35 30 (20 30) (40 50)) +(deftest-previous-overlay-change-1 F2 60 50 (20 30) (40 50)) +(deftest-previous-overlay-change-1 G2 30 20 (20 30) (40 50)) +(deftest-previous-overlay-change-1 H2 50 40 (20 30) (40 50)) ;; 2 non-empty, intersecting -(deftest-previous-overlay-change-1 I 10 1 (20 30) (25 35)) -(deftest-previous-overlay-change-1 J 20 1 (20 30) (25 35)) +(deftest-previous-overlay-change-1 I2 10 1 (20 30) (25 35)) +(deftest-previous-overlay-change-1 J2 20 1 (20 30) (25 35)) (deftest-previous-overlay-change-1 K 23 20 (20 30) (25 35)) (deftest-previous-overlay-change-1 L 25 20 (20 30) (25 35)) (deftest-previous-overlay-change-1 M 28 25 (20 30) (25 35)) @@ -513,7 +760,7 @@ with parameters from the *Messages* buffer modification." (deftest-previous-overlay-change-1 o 25 20 (30 30) (20 30)) (deftest-previous-overlay-change-1 p 30 20 (20 20) (20 30)) (deftest-previous-overlay-change-1 q 40 30 (20 20) (20 30)) -;; 1 empty, 1 non-empty, intersectig in the middle +;; 1 empty, 1 non-empty, intersecting in the middle (deftest-previous-overlay-change-1 r 10 1 (25 25) (20 30)) (deftest-previous-overlay-change-1 s 20 1 (25 25) (20 30)) (deftest-previous-overlay-change-1 t 25 20 (25 25) (20 30)) @@ -540,10 +787,10 @@ with parameters from the *Messages* buffer modification." (58 66) (41 10) (9 67) (28 88) (27 43) (24 27) (48 36) (5 90) (61 9)) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | overlays-at -;; +===================================================================================+ +;; +==========================================================================+ ;; Test whether overlay-at returns RESULT at POS after overlays OVL were @@ -568,36 +815,36 @@ with parameters from the *Messages* buffer modification." (deftest-overlays-at-1 P 50 () (a 10 20) (b 30 40)) ;; 2 non-empty overlays intersecting -(deftest-overlays-at-1 G 1 () (a 10 30) (b 20 40)) -(deftest-overlays-at-1 H 10 (a) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 I 15 (a) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 K 20 (a b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 L 25 (a b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 M 30 (b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 N 35 (b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 O 40 () (a 10 30) (b 20 40)) -(deftest-overlays-at-1 P 50 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 G2 1 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 H2 10 (a) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 I2 15 (a) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 K2 20 (a b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 L2 25 (a b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 M2 30 (b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 N2 35 (b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 O2 40 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 P2 50 () (a 10 30) (b 20 40)) ;; 2 non-empty overlays continuous -(deftest-overlays-at-1 G 1 () (a 10 20) (b 20 30)) -(deftest-overlays-at-1 H 10 (a) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 I 15 (a) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 K 20 (b) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 L 25 (b) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 M 30 () (a 10 20) (b 20 30)) +(deftest-overlays-at-1 G3 1 () (a 10 20) (b 20 30)) +(deftest-overlays-at-1 H3 10 (a) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 I3 15 (a) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 K3 20 (b) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 L3 25 (b) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 M3 30 () (a 10 20) (b 20 30)) ;; overlays-at never returns empty overlays. -(deftest-overlays-at-1 N 1 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) -(deftest-overlays-at-1 O 20 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) -(deftest-overlays-at-1 P 30 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 N3 1 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 O3 20 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 P3 30 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 Q 40 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 R 50 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 S 60 () (a 1 60) (c 1 1) (b 30 30) (d 50 50)) -;; behaviour at point-min and point-max +;; behavior at point-min and point-max (ert-deftest test-overlays-at-2 () (cl-macrolet ((should-length (n list) - `(should (= ,n (length ,list))))) + `(should (= ,n (length ,list))))) (with-temp-buffer (insert (make-string 100 ?\s)) (make-overlay 1 (point-max)) @@ -613,10 +860,10 @@ with parameters from the *Messages* buffer modification." (should-length 1 (overlays-at 15)) (should-length 1 (overlays-at (point-max)))))) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | overlay-in -;; +===================================================================================+ +;; +==========================================================================+ ;; Test whether overlays-in returns RES in BEG,END after overlays OVL were @@ -691,10 +938,10 @@ with parameters from the *Messages* buffer modification." (deftest-overlays-in-1 af 10 11 (a) (a 10 10)) -;; behaviour at point-max +;; behavior at point-max (ert-deftest test-overlays-in-2 () (cl-macrolet ((should-length (n list) - `(should (= ,n (length ,list))))) + `(should (= ,n (length ,list))))) (with-temp-buffer (insert (make-string 100 ?\s)) (make-overlay (point-max) (point-max)) @@ -703,13 +950,13 @@ with parameters from the *Messages* buffer modification." (should-length 2 (overlays-in 1 (point-max))) (should-length 1 (overlays-in (point-max) (point-max))) (narrow-to-region 1 50) - (should-length 0 (overlays-in 1 (point-max))) + (should-length 1 (overlays-in 1 (point-max))) (should-length 1 (overlays-in (point-max) (point-max)))))) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | overlay-recenter -;; +===================================================================================+ +;; +==========================================================================+ ;; This function is a noop in the overlay tree branch. (ert-deftest test-overlay-recenter () @@ -720,10 +967,10 @@ with parameters from the *Messages* buffer modification." (make-overlay i (1+ i)) (should-not (overlay-recenter i))))) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | move-overlay -;; +===================================================================================+ +;; +==========================================================================+ ;; buffer nil with live overlay (ert-deftest test-move-overlay-1 () @@ -767,23 +1014,9 @@ with parameters from the *Messages* buffer modification." (should-not (overlay-end ov)) (should-not (overlay-buffer ov)))) -;; This used to fail. -(ert-deftest test-move-overlay-5 () - (skip-unless (fboundp 'overlay-tree)) - (with-temp-buffer - (insert (make-string 1 ?.)) - (let ((other (make-overlay 1 1))) - (make-overlay 1 1) - (insert "()") - (move-overlay other (point-max) (1+ (point-max)) (current-buffer)) - (delete-overlay other)) - (should (= (plist-get (car (with-no-warnings (overlay-tree))) :limit) - 1)))) - - -;; +===================================================================================+ +;; +==========================================================================+ ;; | delete-(all-)overlay -;; +===================================================================================+ +;; +==========================================================================+ ;; delete live overlay (ert-deftest test-delete-overlay-1 () @@ -814,22 +1047,22 @@ with parameters from the *Messages* buffer modification." (should-not (delete-all-overlays (current-buffer))) (should-not (delete-all-overlays)))) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | get-char-property(-and-overlay) -;; +===================================================================================+ +;; +==========================================================================+ ;; FIXME: TBD - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | Moving by insertions -;; +===================================================================================+ +;; +==========================================================================+ (defmacro deftest-moving-insert-1 (id beg-end insert sbeg-send fa ra) (cl-destructuring-bind (beg end ipos ilen sbeg send fa ra) (append beg-end insert sbeg-send (list fa ra) nil) - `(ert-deftest ,(make-overlay-test-name 'moving-insert 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'moving-insert 1 id) () (test-with-overlay-in-buffer (ov ,beg ,end ,fa ,ra) (should (= ,beg (overlay-start ov))) (should (= ,end (overlay-end ov))) @@ -931,21 +1164,21 @@ with parameters from the *Messages* buffer modification." (should (= 25 (overlay-start right))) (should (= 75 (overlay-end right))) ;; Try to detect the error, by removing left. The should fail - ;; an eassert, since it won't be found by a reular tree + ;; an eassert, since it won't be found by a regular tree ;; traversal - in theory. (delete-overlay left) (should (= 2 (length (overlays-in 1 (point-max)))))))) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | Moving by deletions -;; +===================================================================================+ +;; +==========================================================================+ (defmacro deftest-moving-delete-1 (id beg-end delete sbeg-send fa ra) (cl-destructuring-bind (beg end dpos dlen sbeg send fa ra) (append beg-end delete sbeg-send (list fa ra) nil) - `(ert-deftest ,(make-overlay-test-name 'moving-delete 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'moving-delete 1 id) () (test-with-overlay-in-buffer (ov ,beg ,end ,fa ,ra) (should (= ,beg (overlay-start ov))) (should (= ,end (overlay-end ov))) @@ -1002,12 +1235,12 @@ with parameters from the *Messages* buffer modification." (deftest-moving-delete-1 e (15 15) (5 5) (10 10) t t) (deftest-moving-delete-1 f (15 15) (15 3) (15 15) t t) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | make-indirect-buffer -;; +===================================================================================+ +;; +==========================================================================+ -;; Check if overlays are cloned/seperate from indirect buffer. +;; Check if overlays are cloned/separate from indirect buffer. (ert-deftest test-make-indirect-buffer-1 () (with-temp-buffer (dotimes (_ 10) (make-overlay 1 1)) @@ -1045,22 +1278,22 @@ with parameters from the *Messages* buffer modification." (kill-buffer indirect)))))) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | buffer-swap-text -;; +===================================================================================+ +;; +==========================================================================+ -(defmacro test-with-temp-buffers (vars &rest body) +(defmacro buffer-tests--with-temp-buffers (vars &rest body) (declare (indent 1) (debug (sexp &rest form))) (if (null vars) `(progn ,@body) `(with-temp-buffer (let ((,(car vars) (current-buffer))) - (test-with-temp-buffers ,(cdr vars) ,@body))))) + (buffer-tests--with-temp-buffers ,(cdr vars) ,@body))))) ;; basic (ert-deftest test-buffer-swap-text-1 () - (test-with-temp-buffers (buffer other) + (buffer-tests--with-temp-buffers (buffer other) (with-current-buffer buffer (let ((ov (make-overlay 1 1))) (buffer-swap-text other) @@ -1070,8 +1303,8 @@ with parameters from the *Messages* buffer modification." (should (eq ov (car (overlays-in 1 1))))))))) ;; properties -(ert-deftest test-buffer-swap-text-1 () - (test-with-temp-buffers (buffer other) +(ert-deftest test-buffer-swap-text-2 () + (buffer-tests--with-temp-buffers (buffer other) (with-current-buffer other (overlay-put (make-overlay 1 1) 'buffer 'other)) (with-current-buffer buffer @@ -1083,10 +1316,10 @@ with parameters from the *Messages* buffer modification." (should (= 1 (length (overlays-in 1 1)))) (should (eq (overlay-get (car (overlays-in 1 1)) 'buffer) 'buffer))))) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | priorities -;; +===================================================================================+ +;; +==========================================================================+ (ert-deftest test-overlay-priorities-1 () (with-temp-buffer @@ -1107,10 +1340,10 @@ with parameters from the *Messages* buffer modification." (overlay-put ov 'value i))) (should (eq 9 (get-char-property 1 'value))))) - -;; +===================================================================================+ + +;; +==========================================================================+ ;; | Other -;; +===================================================================================+ +;; +==========================================================================+ (defun test-overlay-regions () (sort (mapcar (lambda (ov) @@ -1226,9 +1459,10 @@ with parameters from the *Messages* buffer modification." (nonempty-eob (make-overlay 4 5)) (empty-eob (make-overlay 5 5))) (set-buffer-multibyte nil) - (cl-macrolet ((ovshould (ov begin end) - `(should (equal (list (overlay-start ,ov) (overlay-end ,ov)) - (list ,begin ,end))))) + (cl-macrolet + ((ovshould (ov begin end) + `(should (equal (list (overlay-start ,ov) (overlay-end ,ov)) + (list ,begin ,end))))) (ovshould nonempty-bob 1 3) (ovshould empty-bob 1 1) (ovshould empty 3 3) @@ -1257,9 +1491,10 @@ with parameters from the *Messages* buffer modification." (nonempty-eob-end (make-overlay 6 9)) (empty-eob (make-overlay 9 9))) (set-buffer-multibyte t) - (cl-macrolet ((ovshould (ov begin end) - `(should (equal (list (overlay-start ,ov) (overlay-end ,ov)) - (list ,begin ,end))))) + (cl-macrolet + ((ovshould (ov begin end) + `(should (equal (list (overlay-start ,ov) (overlay-end ,ov)) + (list ,begin ,end))))) (ovshould nonempty-bob-end 1 2) (ovshould nonempty-bob-beg 1 2) (ovshould empty-bob 1 1) @@ -1280,6 +1515,7 @@ with parameters from the *Messages* buffer modification." ;; | Autogenerated insert/delete/narrow tests ;; +===================================================================================+ +(when nil ;; Let's comment these out for now. ;; (defun test-overlay-generate-test (name) ;; (interactive) @@ -7733,4 +7969,247 @@ with parameters from the *Messages* buffer modification." (101 . 138) (103 . 103)))))) +) ;; End of `when nil' for autogenerated insert/delete/narrow tests. + +(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 (ignore)) + (with-output-to-string (ignore)) + (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)))) + +(ert-deftest buffer-tests-inhibit-buffer-hooks-indirect () + "Indirect buffers do not call `get-buffer-create'." + (dolist (inhibit '(nil t)) + (let ((base (get-buffer-create "foo" inhibit))) + (unwind-protect + (dotimes (_i 11) + (let* (flag* + (flag (lambda () (prog1 t (setq flag* t)))) + (indirect (make-indirect-buffer base "foo[indirect]" nil + inhibit))) + (unwind-protect + (progn + (with-current-buffer indirect + (add-hook 'kill-buffer-query-functions flag nil t)) + (kill-buffer indirect) + (if inhibit + (should-not flag*) + (should flag*))) + (let (kill-buffer-query-functions) + (when (buffer-live-p indirect) + (kill-buffer indirect)))))) + (let (kill-buffer-query-functions) + (when (buffer-live-p base) + (kill-buffer base))))))) + +(ert-deftest zero-length-overlays-and-not () + (with-temp-buffer + (insert "hello") + (let ((long-overlay (make-overlay 2 4)) + (zero-overlay (make-overlay 3 3))) + ;; Exclude. + (should (= (length (overlays-at 3)) 1)) + (should (eq (car (overlays-at 3)) long-overlay)) + ;; Include. + (should (= (length (overlays-in 3 3)) 2)) + (should (memq long-overlay (overlays-in 3 3))) + (should (memq zero-overlay (overlays-in 3 3)))))) + +(ert-deftest test-remove-overlays () + (with-temp-buffer + (insert "foo") + (make-overlay (point) (point)) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (remove-overlays) + (should (= (length (overlays-in (point-min) (point-max))) 0))) + + (with-temp-buffer + (insert "foo") + (goto-char 2) + (make-overlay (point) (point)) + ;; We only count zero-length overlays at the end of the buffer. + (should (= (length (overlays-in 1 2)) 0)) + (narrow-to-region 1 2) + ;; We've now narrowed, so the zero-length overlay is at the end of + ;; the (accessible part of the) buffer. + (should (= (length (overlays-in 1 2)) 1)) + (remove-overlays) + (should (= (length (overlays-in (point-min) (point-max))) 0)))) + +(ert-deftest test-kill-buffer-auto-save-default () + (ert-with-temp-file file + (let (auto-save) + ;; Always answer yes. + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) + (unwind-protect + (progn + (find-file file) + (auto-save-mode t) + (insert "foo\n") + (should buffer-auto-save-file-name) + (setq auto-save buffer-auto-save-file-name) + (do-auto-save) + (should (file-exists-p auto-save)) + (kill-buffer (current-buffer)) + (should (file-exists-p auto-save))) + (when auto-save + (ignore-errors (delete-file auto-save)))))))) + +(ert-deftest test-kill-buffer-auto-save-delete () + (ert-with-temp-file file + (let (auto-save) + (should (file-exists-p file)) + (setq kill-buffer-delete-auto-save-files t) + ;; Always answer yes. + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) + (unwind-protect + (progn + (find-file file) + (auto-save-mode t) + (insert "foo\n") + (should buffer-auto-save-file-name) + (setq auto-save buffer-auto-save-file-name) + (do-auto-save) + (should (file-exists-p auto-save)) + ;; This should delete the auto-save file. + (kill-buffer (current-buffer)) + (should-not (file-exists-p auto-save))) + (ignore-errors (delete-file file)) + (when auto-save + (ignore-errors (delete-file auto-save))))) + ;; Answer no to deletion. + (cl-letf (((symbol-function #'yes-or-no-p) + (lambda (prompt) + (not (string-search "Delete auto-save file" prompt))))) + (unwind-protect + (progn + (find-file file) + (auto-save-mode t) + (insert "foo\n") + (should buffer-auto-save-file-name) + (setq auto-save buffer-auto-save-file-name) + (do-auto-save) + (should (file-exists-p auto-save)) + ;; This should not delete the auto-save file. + (kill-buffer (current-buffer)) + (should (file-exists-p auto-save))) + (when auto-save + (ignore-errors (delete-file auto-save)))))))) + +(ert-deftest test-buffer-modifications () + (ert-with-temp-file file + (with-current-buffer (find-file file) + (auto-save-mode 1) + (should-not (buffer-modified-p)) + (insert "foo") + (should (buffer-modified-p)) + (should-not (eq (buffer-modified-p) 'autosaved)) + (do-auto-save nil t) + (should (eq (buffer-modified-p) 'autosaved)) + (with-silent-modifications + (put-text-property 1 3 'face 'bold)) + (should (eq (buffer-modified-p) 'autosaved)) + (save-buffer) + (should-not (buffer-modified-p)) + (with-silent-modifications + (put-text-property 1 3 'face 'italic)) + (should-not (buffer-modified-p))))) + +(ert-deftest test-restore-buffer-modified-p () + (ert-with-temp-file file + ;; This avoids the annoying "foo and bar are the same file" on + ;; MS-Windows. + (setq file (file-truename file)) + (with-current-buffer (find-file file) + (auto-save-mode 1) + (should-not (eq (buffer-modified-p) t)) + (insert "foo") + (should (buffer-modified-p)) + (restore-buffer-modified-p nil) + (should-not (buffer-modified-p)) + (insert "bar") + (do-auto-save nil t) + (should (eq (buffer-modified-p) 'autosaved)) + (insert "zot") + (restore-buffer-modified-p 'autosaved) + (should (eq (buffer-modified-p) 'autosaved)) + + ;; Clean up. + (when (file-exists-p buffer-auto-save-file-name) + (delete-file buffer-auto-save-file-name)))) + + (ert-with-temp-file file + (setq file (file-truename file)) + (with-current-buffer (find-file file) + (auto-save-mode 1) + (should-not (eq (buffer-modified-p) t)) + (insert "foo") + (should (buffer-modified-p)) + (should-not (eq (buffer-modified-p) 'autosaved)) + (restore-buffer-modified-p 'autosaved) + (should (eq (buffer-modified-p) 'autosaved))))) + +(ert-deftest test-buffer-chars-modified-ticks () + "Test `buffer-chars-modified-tick'." + (setq temporary-file-directory (file-truename temporary-file-directory)) + (let ((text "foobar") + f1 f2) + (unwind-protect + (progn + (setq f1 (make-temp-file "buf-modiff-tests") + f2 (make-temp-file "buf-modiff-tests")) + (with-current-buffer (find-file f1) + (should (= (buffer-chars-modified-tick) 1)) + (should (= (buffer-chars-modified-tick) (buffer-modified-tick))) + (write-region text nil f2 nil 'silent) + (insert-file-contents f2) + (should (= (buffer-chars-modified-tick) (buffer-modified-tick))) + (should (> (buffer-chars-modified-tick) 1)))) + (if f1 (delete-file f1)) + (if f2 (delete-file f2)) + ))) + ;;; buffer-tests.el ends here diff --git a/test/src/callint-tests.el b/test/src/callint-tests.el new file mode 100644 index 00000000000..5a633fdc2bd --- /dev/null +++ b/test/src/callint-tests.el @@ -0,0 +1,68 @@ +;;; callint-tests.el --- unit tests for callint.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2018-2022 Free Software Foundation, Inc. + +;; Author: Philipp Stephani <phst@google.com> + +;; 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/>. + +;;; Commentary: + +;; Unit tests for src/callint.c. + +;;; Code: + +(require 'ert) + +(ert-deftest call-interactively/incomplete-multibyte-sequence () + "Check that Bug#30004 is fixed." + (let* ((text-quoting-style 'grave) + (data (should-error (call-interactively (lambda () (interactive "\xFF")))))) + (should + (equal + (cdr data) + '("Invalid control letter `\u00FF' (#o377, #x00ff) in interactive calling string"))))) + +(ert-deftest call-interactively/embedded-nulls () + "Check that Bug#30005 is fixed." + (should (equal (let ((unread-command-events '(?a ?b))) + (call-interactively (lambda (a b) + (interactive "ka\0a: \nkb: ") + (list a b)))) + '("a" "b")))) + +(ert-deftest call-interactively-prune-command-history () + "Check that Bug#31211 is fixed." + (let ((history-length 1) + (command-history ())) + (dotimes (_ (1+ history-length)) + (call-interactively #'ignore t)) + (should (= (length command-history) history-length)))) + +(defun callint-test-int-args (foo bar &optional zot) + (declare (interactive-args + (bar 10) + (zot 11))) + (interactive (list 1 1 1)) + (+ foo bar zot)) + +(ert-deftest test-interactive-args () + (let ((history-length 1) + (command-history ())) + (should (= (call-interactively 'callint-test-int-args t) 3)) + (should (equal command-history '((callint-test-int-args 1 10 11)))))) + +;;; callint-tests.el ends here diff --git a/test/src/callproc-tests.el b/test/src/callproc-tests.el index fcba6914a5d..f44c7e199f6 100644 --- a/test/src/callproc-tests.el +++ b/test/src/callproc-tests.el @@ -1,6 +1,6 @@ ;;; callproc-tests.el --- callproc.c tests -*- lexical-binding: t -*- -;; Copyright (C) 2016-2017 Free Software Foundation, Inc. +;; Copyright (C) 2016-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -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) @@ -37,3 +42,38 @@ (split-string-and-unquote (buffer-string))) (should (equal initial-shell "nil")) (should-not (equal initial-shell shell)))) + +(ert-deftest call-process-w32-debug-spawn-error () + "Check that debugger runs on `call-process' failure (Bug#33016)." + (skip-unless (eq system-type 'windows-nt)) + (let* ((debug-on-error t) + (have-called-debugger nil) + (debugger (lambda (&rest _) + (setq have-called-debugger t) + ;; Allow entering the debugger later in the same + ;; test run, before going back to the command + ;; loop. + (setq internal-when-entered-debugger -1)))) + (should (eq :got-error ;; NOTE: `should-error' would inhibit debugger. + (condition-case-unless-debug () + ;; On MS-Windows, "nul.FOO" resolves to the null + ;; device, and thus acts like an always-empty + ;; file, for any FOO, in any directory. So + ;; c:/null.exe passes Emacs' test for the file's + ;; existence, and ensures we hit an error in the + ;; w32 process spawn code. + (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 0a9b6c20ec9..652af417293 100644 --- a/test/src/casefiddle-tests.el +++ b/test/src/casefiddle-tests.el @@ -1,6 +1,6 @@ ;;; casefiddle-tests.el --- tests for casefiddle.c functions -*- lexical-binding: t -*- -;; Copyright (C) 2015-2016 Free Software Foundation, Inc. +;; Copyright (C) 2015-2016, 2018-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -57,7 +57,7 @@ errors))) (setq expected (cdr expected))))) (when errors - (ert-fail (mapconcat (lambda (line) line) (nreverse errors) ""))))) + (ert-fail (mapconcat #'identity (nreverse errors)))))) (defconst casefiddle-tests--characters @@ -98,7 +98,7 @@ errors))) (setq props (cdr props) tabs (cdr tabs) expected (cdr expected))))) (when errors - (mapconcat (lambda (line) line) (nreverse errors) ""))))) + (mapconcat #'identity (nreverse errors)))))) (ert-deftest casefiddle-tests-casing-character () @@ -116,7 +116,7 @@ errors))) (setq funcs (cdr funcs) expected (cdr expected))))) (when errors - (mapconcat (lambda (line) line) (nreverse errors) ""))))) + (mapconcat (lambda (line) line) (nreverse errors)))))) (ert-deftest casefiddle-tests-casing-word () @@ -196,7 +196,7 @@ ("fish" "FISH" "fish" "Fish" "Fish") ("Straße" "STRASSE" "straße" "Straße" "Straße") - ;; The word repeated twice to test behaviour at the end of a word + ;; The word repeated twice to test behavior at the end of a word ;; inside of an input string as well as at the end of the string. ("ΌΣΟΣ ΌΣΟΣ" "ΌΣΟΣ ΌΣΟΣ" "όσος όσος" "Όσος Όσος" "ΌΣΟΣ ΌΣΟΣ") ;; What should be done with sole sigma? It is ‘final’ but on the @@ -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)) @@ -259,5 +260,38 @@ (should (eq tc (capitalize ch))) (should (eq tc (upcase-initials ch)))))) +(defvar casefiddle-oldfunc region-extract-function) + +(defun casefiddle-loopfunc (method) + (if (eq method 'bounds) + (let ((looping (list '(1 . 1)))) + (setcdr looping looping)) + (funcall casefiddle-oldfunc method))) + +(defun casefiddle-badfunc (method) + (if (eq method 'bounds) + '(()) + (funcall casefiddle-oldfunc method))) + +(ert-deftest casefiddle-invalid-region-extract-function () + (dolist (region-extract-function '(casefiddle-badfunc casefiddle-loopfunc)) + (with-temp-buffer + (should-error (upcase-region nil nil t))))) + +(ert-deftest casefiddle-turkish () + (skip-unless (member "tr_TR.utf8" (get-locale-names))) + ;; See bug#50752. The point is that unibyte and multibyte strings + ;; are upcased differently in the "dotless i" case in Turkish, + ;; turning ASCII into non-ASCII, which is very unusual. + (with-locale-environment "tr_TR.utf8" + (should (string-equal (downcase "I ı") "ı ı")) + (should (string-equal (downcase "İ i") "i̇ i")) + (should (string-equal (downcase "I") "i")) + (should (string-equal (capitalize "bIte") "Bite")) + (should (string-equal (capitalize "bIté") "Bıté")) + (should (string-equal (capitalize "indIa") "India")) + ;; This does not work -- it produces "Indıa". + ;;(should (string-equal (capitalize "indIá") "İndıa")) + )) ;;; casefiddle-tests.el ends here diff --git a/test/src/character-tests.el b/test/src/character-tests.el new file mode 100644 index 00000000000..f83bac333d7 --- /dev/null +++ b/test/src/character-tests.el @@ -0,0 +1,47 @@ +;;; character-tests.el --- tests for character.c -*- lexical-binding:t -*- + +;; Copyright (C) 2021-2022 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) + +(ert-deftest character-test-string-width () + "Test `string-width' with and without compositions." + (should (= (string-width "1234") 4)) + (should (= (string-width "12\t34") (+ 4 tab-width))) + (should (= (string-width "áëòç") 4)) + (should (= (string-width "áëòç") 4)) + (should (= (string-width "הַרְבֵּה אַהֲבָה") 9)) + (should (= (string-width "1234" 1 3) 2)) + (should (= (string-width "1234" nil -1) 3)) + (should (= (string-width "1234" 2) 2)) + (should-error (string-width "1234" nil 5)) + (should-error (string-width "1234" -5)) + (should (= (string-width "12\t34") (+ 4 tab-width))) + (should (= (string-width "1234\t56") (+ 6 tab-width))) + (should (= (string-width "áëòç") 4)) + (should (= (string-width "áëòç" nil 3) 3)) + (should (= (string-width "áëòç" 1 3) 2)) + (should (= (string-width "áëòç" nil 2) 1)) + (should (= (string-width "áëòç" nil 3) 2)) + (should (= (string-width "áëòç" nil 4) 2)) + (should (= (string-width "הַרְבֵּה אַהֲבָה") 9)) + (should (= (string-width "הַרְבֵּה אַהֲבָה" nil 8) 4))) + +;;; character-tests.el ends here diff --git a/test/src/charset-tests.el b/test/src/charset-tests.el index c3f09ec1a0a..51eb040e77a 100644 --- a/test/src/charset-tests.el +++ b/test/src/charset-tests.el @@ -1,26 +1,30 @@ -;;; charset-tests.el --- Tests for charset.c +;;; charset-tests.el --- Tests for charset.c -*- lexical-binding: t -*- -;; Copyright 2017 Free Software Foundation, Inc. +;; Copyright 2017-2022 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: (require 'ert) (ert-deftest charset-decode-char () - "Test decode-char." + "Test `decode-char'." (should-error (decode-char 'ascii 0.5))) (provide 'charset-tests) + +;;; charset-tests.el ends here diff --git a/test/src/chartab-tests.el b/test/src/chartab-tests.el index 2c57f27ff8b..e4c4b065376 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-2017 Free Software Foundation, Inc. +;; Copyright (C) 2016-2022 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 a545d0e08b5..73e933eb372 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-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 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: @@ -30,5 +32,13 @@ (let ((last-command-event ?a)) (should-error (self-insert-command -1)))) +(ert-deftest forward-line-with-bignum () + (with-temp-buffer + (insert "x\n") + (let ((shortage (forward-line (1- most-negative-fixnum)))) + (should (= shortage most-negative-fixnum))) + (let ((shortage (forward-line (+ 2 most-positive-fixnum)))) + (should (= shortage (1+ most-positive-fixnum)))))) + (provide 'cmds-tests) ;;; cmds-tests.el ends here diff --git a/test/src/coding-tests.el b/test/src/coding-tests.el index e0cefa94356..f65d575d0c2 100644 --- a/test/src/coding-tests.el +++ b/test/src/coding-tests.el @@ -1,6 +1,6 @@ -;;; coding-tests.el --- tests for text encoding and decoding +;;; coding-tests.el --- tests for text encoding and decoding -*- lexical-binding: t -*- -;; Copyright (C) 2013-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 Free Software Foundation, Inc. ;; Author: Eli Zaretskii <eliz@gnu.org> ;; Author: Kenichi Handa <handa@gnu.org> @@ -56,21 +56,22 @@ (set-buffer-multibyte nil) (insert (encode-coding-string "あ" 'euc-jp) "\xd" "\n") (decode-coding-region (point-min) (point-max) 'euc-jp-dos) - (should-not (string-match-p "\^M" (buffer-string))))) + (should-not (string-search "\^M" (buffer-string))))) ;; Return the contents (specified by CONTENT-TYPE; ascii, latin, or ;; binary) of a test file. (defun coding-tests-file-contents (content-type) - (let* ((ascii "ABCDEFGHIJKLMNOPQRSTUVWXYZ\n") - (latin (concat ascii "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏ\n")) - (binary (string-to-multibyte - (concat (string-as-unibyte latin) - (unibyte-string #xC0 #xC1 ?\n))))) - (cond ((eq content-type 'ascii) ascii) - ((eq content-type 'latin) latin) - ((eq content-type 'binary) binary) - (t - (error "Invalid file content type: %s" content-type))))) + (with-suppressed-warnings ((obsolete string-as-unibyte)) + (let* ((ascii "ABCDEFGHIJKLMNOPQRSTUVWXYZ\n") + (latin (concat ascii "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏ\n")) + (binary (string-to-multibyte + (concat (string-as-unibyte latin) + (unibyte-string #xC0 #xC1 ?\n))))) + (cond ((eq content-type 'ascii) ascii) + ((eq content-type 'latin) latin) + ((eq content-type 'binary) binary) + (t + (error "Invalid file content type: %s" content-type)))))) ;; Generate FILE with CONTENTS encoded by CODING-SYSTEM. ;; whose encoding specified by CODING-SYSTEM. @@ -143,7 +144,7 @@ ;; Optional 5th arg TRANSLATOR is a function to translate the original ;; file contents to match with the expected result of decoding. For ;; instance, when a file of dos eol-type is read by unix eol-type, -;; `decode-test-lf-to-crlf' must be specified. +;; `coding-tests-lf-to-crlf' must be specified. (defun coding-tests (content-type write-coding read-coding detected-coding &optional translator) @@ -296,7 +297,7 @@ ;;; decoder, not for regression testing. (defun generate-ascii-file () - (dotimes (i 100000) + (dotimes (_i 100000) (insert-char ?a 80) (insert "\n"))) @@ -309,13 +310,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"))) @@ -359,7 +360,7 @@ (delete-region (point-min) (point)))))) (defun benchmark-decoder () - (let ((gc-cons-threshold 4000000)) + (let ((gc-cons-threshold (max gc-cons-threshold 4000000))) (insert "Without optimization:\n") (dolist (files test-file-list) (dolist (file (cdr files)) @@ -375,9 +376,59 @@ (with-temp-buffer (insert-file-contents (car file)))))) (insert (format "%s: %s\n" (car file) result))))))) -;; Local Variables: -;; byte-compile-warnings: (not obsolete) -;; End: +(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)))) (provide 'coding-tests) -;; coding-tests.el ends here +;;; coding-tests.el ends here diff --git a/test/src/comp-resources/comp-test-45603.el b/test/src/comp-resources/comp-test-45603.el new file mode 100644 index 00000000000..65147ee0156 --- /dev/null +++ b/test/src/comp-resources/comp-test-45603.el @@ -0,0 +1,29 @@ +;;; -*- lexical-binding: t; -*- + +;; Reduced from ivy.el. + +(defvar comp-test-45603-last) +(defvar comp-test-45603-mark-prefix) +(defvar comp-test-45603-directory) +(defvar comp-test-45603-marked-candidates) + +(defun comp-test-45603--call-marked (_action) + (let* ((prefix-len (length comp-test-45603-mark-prefix)) + (marked-candidates + (mapcar + (lambda (s) + (let ((cand (substring s prefix-len))) + (if comp-test-45603-directory + (expand-file-name cand comp-test-45603-directory) + cand))) + comp-test-45603-marked-candidates)) + (_multi-action (comp-test-45603--get-multi-action comp-test-45603-last))) + marked-candidates)) + +(defalias 'comp-test-45603--file-local-name + (if (fboundp 'file-local-name) + #'file-local-name + (lambda (file) + (or (file-remote-p file 'localname) file)))) + +(provide 'comp-test-45603) diff --git a/test/src/comp-resources/comp-test-funcs-dyn.el b/test/src/comp-resources/comp-test-funcs-dyn.el new file mode 100644 index 00000000000..07f8671c6d9 --- /dev/null +++ b/test/src/comp-resources/comp-test-funcs-dyn.el @@ -0,0 +1,50 @@ +;;; comp-test-funcs-dyn.el --- compilation unit tested by comp-tests.el -*- lexical-binding: nil; -*- + +;; Copyright (C) 2020-2022 Free Software Foundation, Inc. + +;; Author: Andrea Corallo <akrl@sdf.org> + +;; 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/>. + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) + +(defun comp-tests-ffuncall-callee-dyn-f (a b) + (list a b)) + +(defun comp-tests-ffuncall-callee-opt-dyn-f (a b &optional c d) + (list a b c d)) + +(defun comp-tests-ffuncall-callee-rest-dyn-f (a b &rest c) + (list a b c)) + +(defun comp-tests-ffuncall-callee-opt-rest-dyn-f (a b &optional c &rest d) + (list a b c d)) + +(defun comp-tests-cl-macro-exp-f () + (cl-loop for xxx in '(a b) + for yyy = xxx + collect xxx)) + +(cl-defun comp-tests-cl-uninterned-arg-parse-f (a &optional b &aux) + (list a b)) + +(provide 'comp-test-dyn-funcs) + +;;; comp-test-funcs-dyn.el ends here diff --git a/test/src/comp-resources/comp-test-funcs.el b/test/src/comp-resources/comp-test-funcs.el new file mode 100644 index 00000000000..9092f040c80 --- /dev/null +++ b/test/src/comp-resources/comp-test-funcs.el @@ -0,0 +1,713 @@ +;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2019-2022 Free Software Foundation, Inc. + +;; Author: Andrea Corallo <akrl@sdf.org> + +;; 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/>. + +;;; Commentary: + +;;; Code: + +(defvar comp-tests-var1 3) + +(defun comp-tests-varref-f () + comp-tests-var1) + +(defun comp-tests-list-f () + (list 1 2 3)) +(defun comp-tests-list2-f (a b c) + (list a b c)) +(defun comp-tests-car-f (x) + ;; Bcar + (car x)) +(defun comp-tests-cdr-f (x) + ;; Bcdr + (cdr x)) +(defun comp-tests-car-safe-f (x) + ;; Bcar_safe + (car-safe x)) +(defun comp-tests-cdr-safe-f (x) + ;; Bcdr_safe + (cdr-safe x)) + +(defun comp-tests-cons-car-f () + (car (cons 1 2))) +(defun comp-tests-cons-cdr-f (x) + (cdr (cons 'foo x))) + +(defun comp-tests-hint-fixnum-f (n) + (1+ (comp-hint-fixnum n))) + +(defun comp-tests-hint-cons-f (c) + (car (comp-hint-cons c))) + +(defun comp-tests-varset0-f () + (setq comp-tests-var1 55)) +(defun comp-tests-varset1-f () + (setq comp-tests-var1 66) + 4) + +(defun comp-tests-length-f () + (length '(1 2 3))) + +(defun comp-tests-aref-aset-f () + (let ((vec (make-vector 3 0))) + (aset vec 2 100) + (aref vec 2))) + +(defvar comp-tests-var2 3) +(defun comp-tests-symbol-value-f () + (symbol-value 'comp-tests-var2)) + +(defun comp-tests-concat-f (x) + (concat "a" "b" "c" "d" + (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) + +(defun comp-tests-ffuncall-callee-f (x y z) + (list x y z)) + +(defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) + (list a b c d)) + +(defun comp-tests-ffuncall-callee-rest-f (a b &rest c) + (list a b c)) + +(defun comp-tests-ffuncall-callee-more8-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 p10) + ;; More then 8 args. + (list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10)) + +(defun comp-tests-ffuncall-callee-more8-rest-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 &rest p10) + ;; More then 8 args. + (list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10)) + +(defun comp-tests-ffuncall-native-f () + "Call a primitive with no dedicate op." + (make-vector 1 nil)) + +(defun comp-tests-ffuncall-native-rest-f () + "Call a primitive with no dedicate op with &rest." + (vector 1 2 3)) + +(defun comp-tests-ffuncall-apply-many-f (x) + (apply #'list x)) + +(defun comp-tests-ffuncall-lambda-f (x) + (let ((fun (lambda (x) + (1+ x)))) + (funcall fun x))) + +(defun comp-tests-jump-table-1-f (x) + (pcase x + ('x 'a) + ('y 'b) + (_ 'c))) + +(defun comp-tests-jump-table-2-f (x) + (pcase x + ("aaa" 'a) + ("bbb" 'b))) + +(defun comp-tests-conditionals-1-f (x) + ;; Generate goto-if-nil + (if x 1 2)) +(defun comp-tests-conditionals-2-f (x) + ;; Generate goto-if-nil-else-pop + (when x + 1340)) + +(defun comp-tests-fixnum-1-minus-f (x) + ;; Bsub1 + (1- x)) +(defun comp-tests-fixnum-1-plus-f (x) + ;; Badd1 + (1+ x)) +(defun comp-tests-fixnum-minus-f (x) + ;; Bnegate + (- x)) + +(defun comp-tests-eqlsign-f (x y) + ;; Beqlsign + (= x y)) +(defun comp-tests-gtr-f (x y) + ;; Bgtr + (> x y)) +(defun comp-tests-lss-f (x y) + ;; Blss + (< x y)) +(defun comp-tests-les-f (x y) + ;; Bleq + (<= x y)) +(defun comp-tests-geq-f (x y) + ;; Bgeq + (>= x y)) + +(defun comp-tests-setcar-f (x y) + (setcar x y) + x) +(defun comp-tests-setcdr-f (x y) + (setcdr x y) + x) + +(defun comp-bubble-sort-f (list) + (let ((i (length list))) + (while (> i 1) + (let ((b list)) + (while (cdr b) + (when (< (cadr b) (car b)) + (setcar b (prog1 (cadr b) + (setcdr b (cons (car b) (cddr b)))))) + (setq b (cdr b)))) + (setq i (1- i))) + list)) + +(defun comp-tests-consp-f (x) + ;; Bconsp + (consp x)) +(defun comp-tests-setcar2-f (x) + ;; Bsetcar + (setcar x 3)) + +(defun comp-tests-integerp-f (x) + ;; Bintegerp + (integerp x)) +(defun comp-tests-numberp-f (x) + ;; Bnumberp + (numberp x)) + +(defun comp-tests-discardn-f (_x) + ;; BdiscardN + (1+ (let ((a 1) + (_b) + (_c)) + a))) +(defun comp-tests-insertn-f (a b c d) + ;; Binsert + (insert a b c d)) + +(defun comp-tests-err-arith-f () + (/ 1 0)) +(defun comp-tests-err-foo-f () + (error "Foo")) + +(defun comp-tests-condition-case-0-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-arith-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) +(defun comp-tests-condition-case-1-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-foo-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) +(defun comp-tests-catch-f (f) + (catch 'foo + (funcall f))) +(defun comp-tests-throw-f (x) + (throw 'foo x)) + +(defun comp-tests-buff0-f () + (with-temp-buffer + (insert "foo") + (buffer-string))) + +(defun comp-tests-lambda-return-f () + (lambda (x) (1+ x))) + +(defun comp-tests-fib-f (n) + (cond ((= n 0) 0) + ((= n 1) 1) + (t (+ (comp-tests-fib-f (- n 1)) + (comp-tests-fib-f (- n 2)))))) + +(defmacro comp-tests-macro-m (x) + x) + +(defun comp-tests-string-trim-f (url) + (string-trim url)) + +(defun comp-tests-trampoline-removal-f () + (make-hash-table)) + +(defun comp-tests-signal-f () + (signal 'foo t)) + +(defun comp-tests-func-call-removal-f () + (let ((a 10) + (b 3)) + (% a b))) + +(defun comp-tests-doc-f () + "A nice docstring." + t) + +(defun comp-test-interactive-form0-f (dir) + (interactive "D") + dir) + +(defun comp-test-interactive-form1-f (x y) + (interactive '(1 2)) + (+ x y)) + +(defun comp-test-interactive-form2-f () + (interactive)) + +(defun comp-test-40187-2-f () + 'foo) + +(defalias 'comp-test-40187-1-f (symbol-function 'comp-test-40187-2-f)) + +(defun comp-test-40187-2-f () + 'bar) + +(defun comp-test-speed--1-f () + (declare (speed -1)) + 3) + +(defun comp-test-42360-f (str end-column + &optional start-column padding ellipsis + ellipsis-text-property) + ;; From `truncate-string-to-width'. A large enough function to + ;; potentially use all registers and that is modifying local + ;; variables inside condition-case. + (let ((str-len (length str)) + (_str-width 14) + (_ellipsis-width 3) + (idx 0) + (column 0) + (head-padding "") (tail-padding "") + ch last-column last-idx from-idx) + (condition-case nil + (while (< column start-column) + (setq ch (aref str idx) + column (+ column (char-width ch)) + idx (1+ idx))) + (args-out-of-range (setq idx str-len))) + (if (< column start-column) + (if padding (make-string end-column padding) "") + (when (and padding (> column start-column)) + (setq head-padding (make-string (- column start-column) padding))) + (setq from-idx idx) + (when (>= end-column column) + (condition-case nil + (while (< column end-column) + (setq last-column column + last-idx idx + ch (aref str idx) + column (+ column (char-width ch)) + idx (1+ idx))) + (args-out-of-range (setq idx str-len))) + (when (> column end-column) + (setq column last-column + idx last-idx)) + (when (and padding (< column end-column)) + (setq tail-padding (make-string (- end-column column) padding)))) + (if (and ellipsis-text-property + (not (equal ellipsis "")) + idx) + (concat head-padding + (substring str from-idx idx) + (propertize (substring str idx) 'display (or ellipsis ""))) + (concat head-padding (substring str from-idx idx) + tail-padding ellipsis))))) + +(defun comp-test-primitive-advice-f (x y) + (declare (speed 2)) + (+ x y)) + +(defun comp-test-primitive-redefine-f (x y) + (declare (speed 2)) + (- x y)) + +(defsubst comp-test-defsubst-f () + t) + +(defvar comp-test-and-3-var 1) +(defun comp-test-and-3-f (x) + (and (atom x) + comp-test-and-3-var + 2)) + +(defun comp-test-copy-insn-f (insn) + ;; From `comp-copy-insn'. + (if (consp insn) + (let (result) + (while (consp insn) + (let ((newcar (car insn))) + (if (or (consp (car insn)) (comp-mvar-p (car insn))) + (setf newcar (comp-copy-insn (car insn)))) + (push newcar result)) + (setf insn (cdr insn))) + (nconc (nreverse result) + (if (comp-mvar-p insn) (comp-copy-insn insn) insn))) + (if (comp-mvar-p insn) + (copy-comp-mvar insn) + insn))) + +(defun comp-test-cond-rw-1-1-f ()) + +(defun comp-test-cond-rw-1-2-f () + (let ((it (comp-test-cond-rw-1-1-f)) + (key 't)) + (if (or (equal it key) + (eq key t)) + it + nil))) + +(defun comp-test-44968-f (start end) + (let ((dirlist) + (dir (expand-file-name start)) + (end (expand-file-name end))) + (while (not (or (equal dir (car dirlist)) + (file-equal-p dir end))) + (push dir dirlist) + (setq dir (directory-file-name (file-name-directory dir)))) + (nreverse dirlist))) + +(defun comp-test-45342-f (n) + (pcase n + (1 " ➊") (2 " ➋") (3 " ➌") (4 " ➍") (5 " ➎") (6 " ➏") + (7 " ➐") (8 " ➑") (9 " ➒") (10 " ➓") (_ ""))) + +(defun comp-test-assume-double-neg-f (collection value) + ;; Reduced from `auth-source-search-collection'. + (when (atom collection) + (setq collection (list collection))) + (or (eq value t) + ;; value is (not (member t)) + (eq collection value) + ;; collection is t, not (member t)! + (member value collection))) + +(defun comp-test-assume-in-loop-1-f (arg) + ;; Reduced from `comint-delim-arg'. + (let ((args nil) + (pos 0) + (len (length arg))) + (while (< pos len) + (let ((start pos)) + (while (< pos len) + (setq pos (1+ pos))) + (setq args (cons (substring arg start pos) args)))) + args)) + +(defun comp-test-45376-1-f () + ;; Reduced from `eshell-ls-find-column-lengths'. + (let* (res + (len 2) + (i 0) + (j 0)) + (while (< j len) + (if (= i len) + (setq i 0)) + (setq res (cons i res) + j (1+ j) + i (1+ i))) + res)) + +(defun comp-test-45376-2-f () + ;; Also reduced from `eshell-ls-find-column-lengths'. + (let* ((x 1) + res) + (while x + (let* ((y 4) + (i 0)) + (while (> y 0) + (when (= i x) + (setq i 0)) + (setf res (cons i res)) + (setq y (1- y) + i (1+ i))) + (if (>= x 3) + (setq x nil) + (setq x (1+ x))))) + res)) + +(defun comp-test-not-cons-f (x) + ;; Reduced from `cl-copy-list'. + (if (consp x) + (print x) + (car x))) + +(defun comp-test-45576-f () + ;; Reduced from `eshell-find-alias-function'. + (let ((sym (intern-soft "eval"))) + (if (and (functionp sym) + '(eshell-ls eshell-pred eshell-prompt eshell-script + eshell-term eshell-unix)) + sym))) + +(defun comp-test-45635-f (&rest args) + ;; Reduced from `set-face-attribute'. + (let ((spec args) + family) + (while spec + (cond ((eq (car spec) :family) + (setq family (cadr spec)))) + (setq spec (cddr spec))) + (when (and (stringp family) + (string-match "\\([^-]*\\)-\\([^-]*\\)" family)) + (setq family (match-string 2 family))) + (when (or (stringp family) + (eq family 'unspecified)) + family))) + +;; This function doesn't have a doc string on purpose. +(defun comp-test-46670-1-f (_) + "foo") + +(defun comp-test-46670-2-f (s) + (and (equal (comp-test-46670-1-f (length s)) s) + s)) + +(cl-defun comp-test-46824-1-f () + (let ((next-repos '(1))) + (while t + (let ((_recipe (car next-repos))) + (cl-block loop + (while t + (let ((err + (condition-case e + (progn + (setq next-repos + (cdr next-repos)) + (cl-return-from loop)) + (error e)))) + (format "%S" + (error-message-string err)))))) + (cl-return-from comp-test-46824-1-f)))) + +(defun comp-test-47868-1-f () + " ") + +(defun comp-test-47868-2-f () + #(" " 0 1 (face font-lock-keyword-face))) + +(defun comp-test-47868-3-f () + " ") + +(defun comp-test-47868-4-f () + #(" " 0 1 (face font-lock-keyword-face))) + +(defun comp-test-48029-nonascii-žžž-f (arg) + (when arg t)) + + +;;;;;;;;;;;;;;;;;;;; +;; Tromey's tests ;; +;;;;;;;;;;;;;;;;;;;; + +;; Test Bconsp. +(defun comp-test-consp (x) (consp x)) + +;; Test Blistp. +(defun comp-test-listp (x) (listp x)) + +;; Test Bstringp. +(defun comp-test-stringp (x) (stringp x)) + +;; Test Bsymbolp. +(defun comp-test-symbolp (x) (symbolp x)) + +;; Test Bintegerp. +(defun comp-test-integerp (x) (integerp x)) + +;; Test Bnumberp. +(defun comp-test-numberp (x) (numberp x)) + +;; Test Badd1. +(defun comp-test-add1 (x) (1+ x)) + +;; Test Bsub1. +(defun comp-test-sub1 (x) (1- x)) + +;; Test Bneg. +(defun comp-test-negate (x) (- x)) + +;; Test Bnot. +(defun comp-test-not (x) (not x)) + +;; Test Bbobp, Beobp, Bpoint, Bpoint_min, Bpoint_max. +(defun comp-test-bobp () (bobp)) +(defun comp-test-eobp () (eobp)) +(defun comp-test-point () (point)) +(defun comp-test-point-min () (point-min)) +(defun comp-test-point-max () (point-max)) + +;; Test Bcar and Bcdr. +(defun comp-test-car (x) (car x)) +(defun comp-test-cdr (x) (cdr x)) + +;; Test Bcar_safe and Bcdr_safe. +(defun comp-test-car-safe (x) (car-safe x)) +(defun comp-test-cdr-safe (x) (cdr-safe x)) + +;; Test Beq. +(defun comp-test-eq (x y) (eq x y)) + +;; Test Bgotoifnil. +(defun comp-test-if (x y) (if x x y)) + +;; Test Bgotoifnilelsepop. +(defun comp-test-and (x y) (and x y)) + +;; Test Bgotoifnonnilelsepop. +(defun comp-test-or (x y) (or x y)) + +;; Test Bsave_excursion. +(defun comp-test-save-excursion () + (save-excursion + (insert "XYZ"))) + +;; Test Bcurrent_buffer. +(defun comp-test-current-buffer () (current-buffer)) + +;; Test Bgtr. +(defun comp-test-> (a b) + (> a b)) + +;; Test Bpushcatch. +(defun comp-test-catch (&rest l) + (catch 'done + (dolist (v l) + (when (> v 23) + (throw 'done v))))) + +;; Test Bmemq. +(defun comp-test-memq (val list) + (memq val list)) + +;; Test BlistN. +(defun comp-test-listN (x) + (list x x x x x x x x x x x x x x x x)) + +;; Test BconcatN. +(defun comp-test-concatN (x) + (concat x x x x x x)) + +;; Test optional and rest arguments. +(defun comp-test-opt-rest (a &optional b &rest c) + (list a b c)) + +;; Test for too many arguments. +(defun comp-test-opt (a &optional b) + (cons a b)) + +;; Test for unwind-protect. +(defvar comp-test-up-val nil) +(defun comp-test-unwind-protect (fun) + (setq comp-test-up-val nil) + (unwind-protect + (progn + (setq comp-test-up-val 23) + (funcall fun) + (setq comp-test-up-val 24)) + (setq comp-test-up-val 999))) + +;; Non tested functions that proved just to be difficult to compile. + +(defun comp-test-callee (_ __) t) +(defun comp-test-silly-frame1 (x) + ;; Check robustness against dead code. + (cl-case x + (0 (comp-test-callee + (pcase comp-tests-var1 + (1 1) + (2 2)) + 3)))) + +(defun comp-test-silly-frame2 (_token) + ;; Check robustness against dead code. + (while c + (cl-case c + (?< 1) + (?> 2)))) + +(defun comp-test-big-interactive (filename &optional force arg load) + "Check non trivial interactive form using `byte-recompile-file'." + (interactive + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (derived-mode-p 'emacs-lisp-mode) + (setq file-name (file-name-nondirectory file) + file-dir (file-name-directory file))) + (list (read-file-name (if current-prefix-arg + "Byte compile file: " + "Byte recompile file: ") + file-dir file-name nil) + current-prefix-arg))) + (let ((dest (byte-compile-dest-file filename)) + ;; Expand now so we get the current buffer's defaults + (filename (expand-file-name filename))) + (if (if (file-exists-p dest) + ;; File was already compiled + ;; Compile if forced to, or filename newer + (or force + (file-newer-than-file-p filename dest)) + (and arg + (or (eq 0 arg) + (y-or-n-p (concat "Compile " + filename "? "))))) + (progn + (if (and noninteractive (not byte-compile-verbose)) + (message "Compiling %s..." filename)) + (byte-compile-file filename)) + (when load + (load (if (file-exists-p dest) dest filename))) + 'no-byte-compile))) + +(defun comp-test-no-return-1 (x) + (while x + (error "Foo"))) + +(defun comp-test-no-return-2 (x) + (cond + ((eql x '2) t) + ((error "Bar") nil))) + +(defun comp-test-no-return-3 ()) +(defun comp-test-no-return-4 (x) + (when x + (error "Foo") + (while (comp-test-no-return-3) + (comp-test-no-return-3)))) + +(defun comp-test-=-nan (x) + (when (= x 0.0e+NaN) + x)) + +(defun comp-test-=-infinity (x) + (when (= x 1.0e+INF) + x)) + +(provide 'comp-test-funcs) + +;;; comp-test-funcs.el ends here diff --git a/test/src/comp-resources/comp-test-pure.el b/test/src/comp-resources/comp-test-pure.el new file mode 100644 index 00000000000..788739e04cc --- /dev/null +++ b/test/src/comp-resources/comp-test-pure.el @@ -0,0 +1,40 @@ +;;; comp-test-pure.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-2022 Free Software Foundation, Inc. + +;; Author: Andrea Corallo <akrl@sdf.org> + +;; 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/>. + +;;; Commentary: + +;;; Code: + +(defun comp-tests-pure-callee-f (x) + (1+ x)) + +(defun comp-tests-pure-caller-f () + (comp-tests-pure-callee-f 3)) + +(defun comp-tests-pure-fibn-f (a b count) + (if (= count 0) + b + (comp-tests-pure-fibn-f (+ a b) a (- count 1)))) + +(defun comp-tests-pure-fibn-entry-f () + (comp-tests-pure-fibn-f 1 0 20)) + +;;; comp-test-pure.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el new file mode 100644 index 00000000000..1edbd1777c6 --- /dev/null +++ b/test/src/comp-tests.el @@ -0,0 +1,1480 @@ +;;; comp-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2019-2022 Free Software Foundation, Inc. + +;; Author: Andrea Corallo <akrl@sdf.org> + +;; 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/>. + +;;; Commentary: + +;; Unit tests for src/comp.c. + +;;; Code: + +(require 'ert) +(require 'ert-x) +(require 'cl-lib) +(require 'comp) +(require 'comp-cstr) + +(eval-and-compile + (defconst comp-test-src (ert-resource-file "comp-test-funcs.el")) + (defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el"))) + +(when (native-comp-available-p) + (message "Compiling tests...") + (load (native-compile comp-test-src)) + (load (native-compile comp-test-dyn-src))) + +;; Load the test code here so the compiler can check the function +;; names used in this file. +(require 'comp-test-funcs comp-test-src) +(require 'comp-test-dyn-funcs comp-test-dyn-src) ;Non-standard feature name! + +(defmacro comp-deftest (name args &rest docstring-and-body) + "Define a test for the native compiler tagging it as :nativecomp." + (declare (indent defun) + (doc-string 3)) + `(ert-deftest ,(intern (concat "comp-tests-" (symbol-name name))) ,args + :tags '(:nativecomp) + ,@(and (stringp (car docstring-and-body)) + (list (pop docstring-and-body))) + ;; Some of the tests leave spill files behind -- so create a + ;; sub-dir where native-comp can do its work, and then delete it + ;; at the end. + (ert-with-temp-directory dir + (let ((temporary-file-directory dir)) + ,@docstring-and-body)))) + + + +(ert-deftest comp-tests-bootstrap () + "Compile the compiler and load it to compile it-self. +Check that the resulting binaries do not differ." + :tags '(:expensive-test :nativecomp) + (ert-with-temp-file comp1-src + :suffix "-comp-stage1.el" + (ert-with-temp-file comp2-src + :suffix "-comp-stage2.el" + (let* ((byte+native-compile t) ; FIXME HACK + (comp-src (expand-file-name "../../../lisp/emacs-lisp/comp.el" + (ert-resource-directory))) + ;; Can't use debug symbols. + (native-comp-debug 0)) + (copy-file comp-src comp1-src t) + (copy-file comp-src comp2-src t) + (let ((load-no-native t)) + (load (concat comp-src "c") nil nil t t)) + (should-not (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage1...") + (let* ((t0 (current-time)) + (comp1-eln (native-compile comp1-src))) + (message "Done in %d secs" (float-time (time-since t0))) + (load comp1-eln nil nil t t) + (should (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage2...") + (let ((t0 (current-time)) + (comp2-eln (native-compile comp2-src))) + (message "Done in %d secs" (float-time (time-since t0))) + (message "Comparing %s %s" comp1-eln comp2-eln) + (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))))) + +(comp-deftest provide () + "Testing top level provide." + (should (featurep 'comp-test-funcs))) + +(comp-deftest varref () + "Testing varref." + (should (= (comp-tests-varref-f) 3))) + +(comp-deftest list () + "Testing cons car cdr." + (should (equal (comp-tests-list-f) '(1 2 3))) + (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) + (should (= (comp-tests-car-f '(1 . 2)) 1)) + (should (null (comp-tests-car-f nil))) + (should-error (comp-tests-car-f 3) + :type 'wrong-type-argument) + (should (= (comp-tests-cdr-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-f nil))) + (should-error (comp-tests-cdr-f 3) + :type 'wrong-type-argument) + (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) + (should (null (comp-tests-car-safe-f 'a))) + (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-safe-f 'a)))) + +(comp-deftest comp-tests-cons-car-cdr () + "Testing cons car cdr." + (should (= (comp-tests-cons-car-f) 1)) + (should (= (comp-tests-cons-cdr-f 3) 3))) + +(comp-deftest varset () + "Testing varset." + (comp-tests-varset0-f) + (should (= comp-tests-var1 55)) + + (should (= (comp-tests-varset1-f) 4)) + (should (= comp-tests-var1 66))) + +(comp-deftest length () + "Testing length." + (should (= (comp-tests-length-f) 3))) + +(comp-deftest aref-aset () + "Testing aref and aset." + (should (= (comp-tests-aref-aset-f) 100))) + +(comp-deftest symbol-value () + "Testing aref and aset." + (should (= (comp-tests-symbol-value-f) 3))) + +(comp-deftest concat () + "Testing concatX opcodes." + (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) + +(comp-deftest ffuncall () + "Test calling conventions." + + ;; (defun comp-tests-ffuncall-caller-f () + ;; (comp-tests-ffuncall-callee-f 1 2 3)) + + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + + ;; ;; After it gets compiled + ;; (native-compile #'comp-tests-ffuncall-callee-f) + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + + ;; ;; Recompiling the caller once with callee already compiled + ;; (defun comp-tests-ffuncall-caller-f () + ;; (comp-tests-ffuncall-callee-f 1 2 3)) + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) + '(1 2 3 4))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) + '(1 2 nil nil))) + + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) + '(1 2 nil))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) + '(1 2 (3)))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) + '(1 2 (3 4)))) + + (should (equal (comp-tests-ffuncall-callee-more8-f 1 2 3 4 5 6 7 8 9 10) + '(1 2 3 4 5 6 7 8 9 10))) + + (should (equal (comp-tests-ffuncall-callee-more8-rest-f 1 2 3 4 5 6 7 8 9 10 11) + '(1 2 3 4 5 6 7 8 9 (10 11)))) + + (should (equal (comp-tests-ffuncall-native-f) [nil])) + + (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) + + (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) + '(1 2 3))) + + (should (= (comp-tests-ffuncall-lambda-f 1) 2))) + +(comp-deftest jump-table () + "Testing jump tables" + (should (eq (comp-tests-jump-table-1-f 'x) 'a)) + (should (eq (comp-tests-jump-table-1-f 'y) 'b)) + (should (eq (comp-tests-jump-table-1-f 'xxx) 'c)) + + ;; Jump table not with eq as test + (should (eq (comp-tests-jump-table-2-f "aaa") 'a)) + (should (eq (comp-tests-jump-table-2-f "bbb") 'b))) + +(comp-deftest conditionals () + "Testing conditionals." + (should (= (comp-tests-conditionals-1-f t) 1)) + (should (= (comp-tests-conditionals-1-f nil) 2)) + (should (= (comp-tests-conditionals-2-f t) 1340)) + (should (eq (comp-tests-conditionals-2-f nil) nil))) + +(comp-deftest fixnum () + "Testing some fixnum inline operation." + (should (= (comp-tests-fixnum-1-minus-f 10) 9)) + (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) + (1- most-negative-fixnum))) + (should-error (comp-tests-fixnum-1-minus-f 'a) + :type 'wrong-type-argument) + (should (= (comp-tests-fixnum-1-plus-f 10) 11)) + (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) + (1+ most-positive-fixnum))) + (should-error (comp-tests-fixnum-1-plus-f 'a) + :type 'wrong-type-argument) + (should (= (comp-tests-fixnum-minus-f 10) -10)) + (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) + (- most-negative-fixnum))) + (should-error (comp-tests-fixnum-minus-f 'a) + :type 'wrong-type-argument)) + +(comp-deftest type-hints () + "Just test compiler hints are transparent in this case." + ;; FIXME we should really check they are also effective. + (should (= (comp-tests-hint-fixnum-f 3) 4)) + (should (= (comp-tests-hint-cons-f (cons 1 2)) 1))) + +(comp-deftest arith-comp () + "Testing arithmetic comparisons." + (should (eq (comp-tests-eqlsign-f 4 3) nil)) + (should (eq (comp-tests-eqlsign-f 3 3) t)) + (should (eq (comp-tests-eqlsign-f 2 3) nil)) + (should (eq (comp-tests-gtr-f 4 3) t)) + (should (eq (comp-tests-gtr-f 3 3) nil)) + (should (eq (comp-tests-gtr-f 2 3) nil)) + (should (eq (comp-tests-lss-f 4 3) nil)) + (should (eq (comp-tests-lss-f 3 3) nil)) + (should (eq (comp-tests-lss-f 2 3) t)) + (should (eq (comp-tests-les-f 4 3) nil)) + (should (eq (comp-tests-les-f 3 3) t)) + (should (eq (comp-tests-les-f 2 3) t)) + (should (eq (comp-tests-geq-f 4 3) t)) + (should (eq (comp-tests-geq-f 3 3) t)) + (should (eq (comp-tests-geq-f 2 3) nil))) + +(comp-deftest setcarcdr () + "Testing setcar setcdr." + (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) + (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) + (should-error (comp-tests-setcar-f 3 10) + :type 'wrong-type-argument) + (should-error (comp-tests-setcdr-f 3 10) + :type 'wrong-type-argument)) + +(comp-deftest bubble-sort () + "Run bubble sort." + (let* ((list1 (mapcar #'random (make-list 1000 most-positive-fixnum))) + (list2 (copy-sequence list1))) + (should (equal (comp-bubble-sort-f list1) + (sort list2 #'<))))) + +(comp-deftest apply () + "Test some inlined list functions." + (should (eq (comp-tests-consp-f '(1)) t)) + (should (eq (comp-tests-consp-f 1) nil)) + (let ((x (cons 1 2))) + (should (= (comp-tests-setcar2-f x) 3)) + (should (equal x '(3 . 2))))) + +(comp-deftest num-inline () + "Test some inlined number functions." + (should (eq (comp-tests-integerp-f 1) t)) + (should (eq (comp-tests-integerp-f '(1)) nil)) + (should (eq (comp-tests-integerp-f 3.5) nil)) + (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) + + (should (eq (comp-tests-numberp-f 1) t)) + (should (eq (comp-tests-numberp-f 'a) nil)) + (should (eq (comp-tests-numberp-f 3.5) t))) + +(comp-deftest stack () + "Test some stack operation." + (should (= (comp-tests-discardn-f 10) 2)) + (should (string= (with-temp-buffer + (comp-tests-insertn-f "a" "b" "c" "d") + (buffer-string)) + "abcd"))) + +(comp-deftest non-locals () + "Test non locals." + (should (string= (comp-tests-condition-case-0-f) + "arith-error Arithmetic error catched")) + (should (string= (comp-tests-condition-case-1-f) + "error Foo catched")) + (should (= (comp-tests-catch-f + (lambda () (throw 'foo 3))) + 3)) + (should (= (catch 'foo + (comp-tests-throw-f 3))))) + +(comp-deftest gc () + "Try to do some longer computation to let the GC kick in." + (dotimes (_ 100000) + (comp-tests-cons-cdr-f 3)) + (should (= (comp-tests-cons-cdr-f 3) 3))) + +(comp-deftest buffer () + (should (string= (comp-tests-buff0-f) "foo"))) + +(comp-deftest lambda-return () + (let ((f (comp-tests-lambda-return-f))) + (should (subr-native-elisp-p f)) + (should (= (funcall f 3) 4)))) + +(comp-deftest recursive () + (should (= (comp-tests-fib-f 10) 55))) + +(comp-deftest macro () + "Just check we can define macros" + (should (macrop (symbol-function 'comp-tests-macro-m)))) + +(comp-deftest string-trim () + (should (string= (comp-tests-string-trim-f "dsaf ") "dsaf"))) + +(comp-deftest trampoline-removal () + ;; This tests that we can call primitives with no dedicated bytecode. + ;; At speed >= 2 the trampoline will not be used. + (should (hash-table-p (comp-tests-trampoline-removal-f)))) + +(comp-deftest signal () + (should (equal (condition-case err + (comp-tests-signal-f) + (t err)) + '(foo . t)))) + +(comp-deftest func-call-removal () + ;; See `comp-propagate-insn' `comp-function-call-remove'. + (should (= (comp-tests-func-call-removal-f) 1))) + +(comp-deftest doc () + (should (string= (documentation #'comp-tests-doc-f) + "A nice docstring.")) + ;; Check a preloaded function, we can't use `comp-tests-doc-f' now + ;; as this is loaded manually with no .elc. + (should (string-match "\\.*.elc\\'" (symbol-file #'error)))) + +(comp-deftest interactive-form () + (should (equal (interactive-form #'comp-test-interactive-form0-f) + '(interactive "D"))) + (should (equal (interactive-form #'comp-test-interactive-form1-f) + '(interactive '(1 2)))) + (should (equal (interactive-form #'comp-test-interactive-form2-f) + '(interactive nil))) + (should (cl-every #'commandp '(comp-test-interactive-form0-f + comp-test-interactive-form1-f + comp-test-interactive-form2-f))) + (should-not (commandp #'comp-tests-doc-f))) + +(declare-function comp-tests-free-fun-f nil) + +(comp-deftest free-fun () + "Check we are able to compile a single function." + (eval '(defun comp-tests-free-fun-f () + "Some doc." + (interactive) + 3) + t) + (native-compile #'comp-tests-free-fun-f) + + (should (subr-native-elisp-p (symbol-function 'comp-tests-free-fun-f))) + (should (= (comp-tests-free-fun-f) 3)) + (should (string= (documentation #'comp-tests-free-fun-f) + "Some doc.")) + (should (commandp #'comp-tests-free-fun-f)) + (should (equal (interactive-form #'comp-tests-free-fun-f) + '(interactive)))) + +(declare-function comp-tests/free\fun-f nil) + +(comp-deftest free-fun-silly-name () + "Check we are able to compile a single function." + (eval '(defun comp-tests/free\fun-f ()) t) + (native-compile #'comp-tests/free\fun-f) + (should (subr-native-elisp-p (symbol-function 'comp-tests/free\fun-f)))) + +(comp-deftest bug-40187 () + "Check function name shadowing. +https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." + (should (eq (comp-test-40187-1-f) 'foo)) + (should (eq (comp-test-40187-2-f) 'bar))) + +(comp-deftest speed--1 () + "Check that at speed -1 we do not native compile." + (should (= (comp-test-speed--1-f) 3)) + (should-not (subr-native-elisp-p (symbol-function 'comp-test-speed--1-f)))) + +(comp-deftest bug-42360 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-07/msg00418.html>." + (should (string= (comp-test-42360-f "Nel mezzo del " 18 0 32 "yyy" nil) + "Nel mezzo del yyy"))) + +(comp-deftest bug-44968 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-11/msg02357.html>" + (comp-test-44968-f "/tmp/test/foo" "/tmp")) + +(comp-deftest bug-45342 () + "Preserve multibyte immediate strings. +<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01771.html>" + (should (string= " ➊" (comp-test-45342-f 1)))) + +(comp-deftest assume-double-neg () + "In fwprop assumptions (not (not (member x))) /= (member x)." + (should-not (comp-test-assume-double-neg-f "bar" "foo"))) + +(comp-deftest assume-in-loop-1 () + "Broken call args assumptions lead to infinite loop." + (should (equal (comp-test-assume-in-loop-1-f "cd") '("cd")))) + +(comp-deftest bug-45376-1 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01883.html>" + (should (equal (comp-test-45376-1-f) '(1 0)))) + +(comp-deftest bug-45376-2 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01883.html>" + (should (equal (comp-test-45376-2-f) '(0 2 1 0 1 0 1 0 0 0 0 0)))) + +(defvar comp-test-primitive-advice) +(comp-deftest primitive-advice () + "Test effectiveness of primitive advising." + (let (comp-test-primitive-advice + (f (lambda (&rest args) + (setq comp-test-primitive-advice args)))) + (advice-add #'+ :before f) + (unwind-protect + (progn + (should (= (comp-test-primitive-advice-f 3 4) 7)) + (should (equal comp-test-primitive-advice '(3 4)))) + (advice-remove #'+ f)))) + +(defvar comp-test-primitive-redefine-args) +(comp-deftest primitive-redefine () + "Test effectiveness of primitive redefinition." + (cl-letf ((comp-test-primitive-redefine-args nil) + ((symbol-function '-) + (lambda (&rest args) + (setq comp-test-primitive-redefine-args args) + 'xxx))) + (should (eq (comp-test-primitive-redefine-f 10 2) 'xxx)) + (should (equal comp-test-primitive-redefine-args '(10 2))))) + +(comp-deftest compile-forms () + "Verify lambda form native compilation." + (should-error (native-compile '(+ 1 foo))) + (let ((lexical-binding t) + (f (native-compile '(lambda (x) (1+ x))))) + (should (subr-native-elisp-p f)) + (should (= (funcall f 2) 3))) + (let* ((lexical-binding nil) + (f (native-compile '(lambda (x) (1+ x))))) + (should (subr-native-elisp-p f)) + (should (= (funcall f 2) 3)))) + +(comp-deftest comp-test-defsubst () + ;; Bug#42664, Bug#43280, Bug#44209. + (should-not (subr-native-elisp-p (symbol-function 'comp-test-defsubst-f)))) + +(comp-deftest primitive-redefine-compile-44221 () + "Test the compiler still works while primitives are redefined (bug#44221)." + (cl-letf (((symbol-function 'delete-region) + (lambda (_ _)))) + (should (subr-native-elisp-p + (native-compile + '(lambda () + (delete-region (point-min) (point-max)))))))) + +(comp-deftest and-3 () + (should (= (comp-test-and-3-f t) 2)) + (should (null (comp-test-and-3-f '(1 2))))) + +(comp-deftest copy-insn () + (should (equal (comp-test-copy-insn-f '(1 2 3 (4 5 6))) + '(1 2 3 (4 5 6)))) + (should (null (comp-test-copy-insn-f nil)))) + +(comp-deftest cond-rw-1 () + "Check cond-rw does not break target blocks with multiple predecessor." + (should (null (comp-test-cond-rw-1-2-f)))) + +(comp-deftest not-cons-1 () + (should-not (comp-test-not-cons-f nil))) + +(comp-deftest 45576-1 () + "Functionp satisfies also symbols. +<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-01/msg00029.html>." + (should (eq (comp-test-45576-f) 'eval))) + +(comp-deftest 45635-1 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-01/msg00158.html>." + (should (string= (comp-test-45635-f :height 180 :family "PragmataPro Liga") + "PragmataPro Liga"))) + +(comp-deftest 46670-1 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-02/msg01413.html>" + (should (string= (comp-test-46670-2-f "foo") "foo")) + (should (equal (subr-type (symbol-function 'comp-test-46670-2-f)) + '(function (t) t)))) + +(comp-deftest 46824-1 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-02/msg01949.html>" + (should (equal (comp-test-46824-1-f) nil))) + +(comp-deftest comp-test-47868-1 () + "Verify string hash consing strategy. + +<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-04/msg00921.html>" + (should-not (equal-including-properties (comp-test-47868-1-f) + (comp-test-47868-2-f))) + (should (eq (comp-test-47868-1-f) (comp-test-47868-3-f))) + (should (eq (comp-test-47868-2-f) (comp-test-47868-4-f)))) + +(comp-deftest 48029-1 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2022-07/msg00666.html>" + (should (subr-native-elisp-p + (symbol-function 'comp-test-48029-nonascii-žžž-f)))) + + +;;;;;;;;;;;;;;;;;;;;; +;; Tromey's tests. ;; +;;;;;;;;;;;;;;;;;;;;; + +(comp-deftest consp () + (should-not (comp-test-consp 23)) + (should-not (comp-test-consp nil)) + (should (comp-test-consp '(1 . 2)))) + +(comp-deftest listp () + (should-not (comp-test-listp 23)) + (should (comp-test-listp nil)) + (should (comp-test-listp '(1 . 2)))) + +(comp-deftest stringp () + (should-not (comp-test-stringp 23)) + (should-not (comp-test-stringp nil)) + (should (comp-test-stringp "hi"))) + +(comp-deftest symbolp () + (should-not (comp-test-symbolp 23)) + (should-not (comp-test-symbolp "hi")) + (should (comp-test-symbolp 'whatever))) + +(comp-deftest integerp () + (should (comp-test-integerp 23)) + (should-not (comp-test-integerp 57.5)) + (should-not (comp-test-integerp "hi")) + (should-not (comp-test-integerp 'whatever))) + +(comp-deftest numberp () + (should (comp-test-numberp 23)) + (should (comp-test-numberp 57.5)) + (should-not (comp-test-numberp "hi")) + (should-not (comp-test-numberp 'whatever))) + +(comp-deftest add1 () + (should (eq (comp-test-add1 23) 24)) + (should (eq (comp-test-add1 -17) -16)) + (should (eql (comp-test-add1 1.0) 2.0)) + (should-error (comp-test-add1 nil) + :type 'wrong-type-argument)) + +(comp-deftest sub1 () + (should (eq (comp-test-sub1 23) 22)) + (should (eq (comp-test-sub1 -17) -18)) + (should (eql (comp-test-sub1 1.0) 0.0)) + (should-error (comp-test-sub1 nil) + :type 'wrong-type-argument)) + +(comp-deftest negate () + (should (eq (comp-test-negate 23) -23)) + (should (eq (comp-test-negate -17) 17)) + (should (eql (comp-test-negate 1.0) -1.0)) + (should-error (comp-test-negate nil) + :type 'wrong-type-argument)) + +(comp-deftest not () + (should (eq (comp-test-not 23) nil)) + (should (eq (comp-test-not nil) t)) + (should (eq (comp-test-not t) nil))) + +(comp-deftest bobp-and-eobp () + (with-temp-buffer + (should (comp-test-bobp)) + (should (comp-test-eobp)) + (insert "hi") + (goto-char (point-min)) + (should (eq (comp-test-point-min) (point-min))) + (should (eq (comp-test-point) (point-min))) + (should (comp-test-bobp)) + (should-not (comp-test-eobp)) + (goto-char (point-max)) + (should (eq (comp-test-point-max) (point-max))) + (should (eq (comp-test-point) (point-max))) + (should-not (comp-test-bobp)) + (should (comp-test-eobp)))) + +(comp-deftest car-cdr () + (let ((pair '(1 . b))) + (should (eq (comp-test-car pair) 1)) + (should (eq (comp-test-car nil) nil)) + (should-error (comp-test-car 23) + :type 'wrong-type-argument) + (should (eq (comp-test-cdr pair) 'b)) + (should (eq (comp-test-cdr nil) nil)) + (should-error (comp-test-cdr 23) + :type 'wrong-type-argument))) + +(comp-deftest car-cdr-safe () + (let ((pair '(1 . b))) + (should (eq (comp-test-car-safe pair) 1)) + (should (eq (comp-test-car-safe nil) nil)) + (should (eq (comp-test-car-safe 23) nil)) + (should (eq (comp-test-cdr-safe pair) 'b)) + (should (eq (comp-test-cdr-safe nil) nil)) + (should (eq (comp-test-cdr-safe 23) nil)))) + +(comp-deftest eq () + (should (comp-test-eq 'a 'a)) + (should (comp-test-eq 5 5)) + (should-not (comp-test-eq 'a 'b))) + +(comp-deftest if () + (should (eq (comp-test-if 'a 'b) 'a)) + (should (eq (comp-test-if 0 23) 0)) + (should (eq (comp-test-if nil 'b) 'b))) + +(comp-deftest and () + (should (eq (comp-test-and 'a 'b) 'b)) + (should (eq (comp-test-and 0 23) 23)) + (should (eq (comp-test-and nil 'b) nil))) + +(comp-deftest or () + (should (eq (comp-test-or 'a 'b) 'a)) + (should (eq (comp-test-or 0 23) 0)) + (should (eq (comp-test-or nil 'b) 'b))) + +(comp-deftest save-excursion () + (with-temp-buffer + (comp-test-save-excursion) + (should (eq (point) (point-min))) + (should (eq (comp-test-current-buffer) (current-buffer))))) + +(comp-deftest > () + (should (eq (comp-test-> 0 23) nil)) + (should (eq (comp-test-> 23 0) t))) + +(comp-deftest catch () + (should (eq (comp-test-catch 0 1 2 3 4) nil)) + (should (eq (comp-test-catch 20 21 22 23 24 25 26 27 28) 24))) + +(comp-deftest memq () + (should (equal (comp-test-memq 0 '(5 4 3 2 1 0)) '(0))) + (should (eq (comp-test-memq 72 '(5 4 3 2 1 0)) nil))) + +(comp-deftest listN () + (should (equal (comp-test-listN 57) + '(57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57)))) + +(comp-deftest concatN () + (should (equal (comp-test-concatN "x") "xxxxxx"))) + +(comp-deftest opt-rest () + (should (equal (comp-test-opt-rest 1) '(1 nil nil))) + (should (equal (comp-test-opt-rest 1 2) '(1 2 nil))) + (should (equal (comp-test-opt-rest 1 2 3) '(1 2 (3)))) + (should (equal (comp-test-opt-rest 1 2 56 57 58) + '(1 2 (56 57 58))))) + +(comp-deftest opt () + (should (equal (comp-test-opt 23) '(23))) + (should (equal (comp-test-opt 23 24) '(23 . 24))) + (should-error (comp-test-opt) + :type 'wrong-number-of-arguments) + (should-error (comp-test-opt nil 24 97) + :type 'wrong-number-of-arguments)) + +(comp-deftest unwind-protect () + (comp-test-unwind-protect 'ignore) + (should (eq comp-test-up-val 999)) + (condition-case nil + (comp-test-unwind-protect (lambda () (error "HI"))) + (error + nil)) + (should (eq comp-test-up-val 999))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Tests for dynamic scope. ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(comp-deftest dynamic-ffuncall () + "Test calling convention for dynamic binding." + + (should (equal (comp-tests-ffuncall-callee-dyn-f 1 2) + '(1 2))) + + (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2 3 4) + '(1 2 3 4))) + (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2) + '(1 2 nil nil))) + + (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2) + '(1 2 nil))) + (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2 3) + '(1 2 (3)))) + (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2 3 4) + '(1 2 (3 4)))) + + (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2) + '(1 2 nil nil))) + (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3 4) + '(1 2 3 (4))))) + +(comp-deftest dynamic-arity () + "Test func-arity on dynamic scope functions." + (should (equal '(2 . 2) + (func-arity #'comp-tests-ffuncall-callee-dyn-f))) + (should (equal '(2 . 4) + (func-arity #'comp-tests-ffuncall-callee-opt-dyn-f))) + (should (equal '(2 . many) + (func-arity #'comp-tests-ffuncall-callee-rest-dyn-f))) + (should (equal '(2 . many) + (func-arity #'comp-tests-ffuncall-callee-opt-rest-dyn-f)))) + +(comp-deftest dynamic-help-arglist () + "Test `help-function-arglist' works on lisp/d (bug#42572)." + (should (equal (help-function-arglist + (symbol-function 'comp-tests-ffuncall-callee-opt-rest-dyn-f) + t) + '(a b &optional c &rest d)))) + +(comp-deftest cl-macro-exp () + "Verify CL macro expansion (bug#42088)." + (should (equal (comp-tests-cl-macro-exp-f) '(a b)))) + +(comp-deftest cl-uninterned-arg-parse-f () + "Verify the parsing of a lambda list with uninterned symbols (bug#42120)." + (should (equal (comp-tests-cl-uninterned-arg-parse-f 1 2) + '(1 2)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Middle-end specific tests. ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun comp-tests-mentioned-p-1 (x insn) + (cl-loop for y in insn + when (cond + ((consp y) (comp-tests-mentioned-p x y)) + ((and (comp-mvar-p y) (comp-cstr-imm-vld-p y)) + (equal (comp-cstr-imm y) x)) + (t (equal x y))) + return t)) + +(defun comp-tests-mentioned-p (x insn) + "Check if X is actively mentioned in INSN." + (unless (eq (car-safe insn) + 'comment) + (comp-tests-mentioned-p-1 x insn))) + +(defun comp-tests-map-checker (func-name checker) + "Apply CHECKER to each insn of FUNC-NAME. +Return a list of results." + (cl-loop + with func-c-name = (comp-c-func-name (or func-name 'anonymous-lambda) "F" t) + with f = (gethash func-c-name (comp-ctxt-funcs-h comp-ctxt)) + for bb being each hash-value of (comp-func-blocks f) + nconc + (cl-loop + for insn in (comp-block-insns bb) + collect (funcall checker insn)))) + +(defun comp-tests-tco-checker (_) + "Check that inside `comp-tests-tco-f' we have no recursion." + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-tco-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-tco-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) + insn))))))) + +(declare-function comp-tests-tco-f nil) + +(comp-deftest tco () + "Check for tail recursion elimination." + (let ((native-comp-speed 3) + ;; Disable ipa-pure otherwise `comp-tests-tco-f' gets + ;; optimized-out. + (comp-disabled-passes '(comp-ipa-pure)) + (comp-post-pass-hooks '((comp-tco comp-tests-tco-checker) + (comp-final comp-tests-tco-checker)))) + (eval '(defun comp-tests-tco-f (a b count) + (if (= count 0) + b + (comp-tests-tco-f (+ a b) a (- count 1)))) + t) + (native-compile #'comp-tests-tco-f) + (should (subr-native-elisp-p (symbol-function 'comp-tests-tco-f))) + (should (= (comp-tests-tco-f 1 0 10) 55)))) + +(defun comp-tests-fw-prop-checker-1 (_) + "Check that inside `comp-tests-fw-prop-f' `concat' and `length' are folded." + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-fw-prop-1-f + (lambda (insn) + (or (comp-tests-mentioned-p 'concat insn) + (comp-tests-mentioned-p 'length insn))))))) + +(declare-function comp-tests-fw-prop-1-f nil) + +(comp-deftest fw-prop-1 () + "Some tests for forward propagation." + (let ((native-comp-speed 2) + (comp-post-pass-hooks '((comp-final comp-tests-fw-prop-checker-1)))) + (eval '(defun comp-tests-fw-prop-1-f () + (let* ((a "xxx") + (b "yyy") + (c (concat a b))) ; <= has to optimize + (length c))) ; <= has to optimize + t) + (native-compile #'comp-tests-fw-prop-1-f) + (should (subr-native-elisp-p (symbol-function 'comp-tests-fw-prop-1-f))) + (should (= (comp-tests-fw-prop-1-f) 6)))) + +(defun comp-tests-check-ret-type-spec (func-form ret-type) + (let ((lexical-binding t) + (native-comp-speed 2) + (f-name (cl-second func-form))) + (eval func-form t) + (native-compile f-name) + (should (equal (cl-third (subr-type (symbol-function f-name))) + ret-type)))) + +(cl-eval-when (compile eval load) + (defconst comp-tests-type-spec-tests + ;; Why we quote everything here, you ask? So that values of + ;; `most-positive-fixnum' and `most-negative-fixnum', which can be + ;; architecture-dependent, do not end up hardcoded in the + ;; resulting byte-compiled file, and thus we could run the same + ;; .elc file on several architectures without fear. + '( + ;; 1 + ((defun comp-tests-ret-type-spec-f (x) + x) + 't) + + ;; 2 + ((defun comp-tests-ret-type-spec-f () + 1) + '(integer 1 1)) + + ;; 3 + ((defun comp-tests-ret-type-spec-f (x) + (if x 1 3)) + '(or (integer 1 1) (integer 3 3))) + + ;; 4 + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (if x + (setf y 1) + (setf y 2)) + y)) + '(integer 1 2)) + + ;; 5 + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (if x + (setf y 1) + (setf y 3)) + y)) + '(or (integer 1 1) (integer 3 3))) + + ;; 6 + ((defun comp-tests-ret-type-spec-f (x) + (if x + (list x) + 3)) + '(or cons (integer 3 3))) + + ;; 7 + ((defun comp-tests-ret-type-spec-f (x) + (if x + 'foo + 3)) + '(or (member foo) (integer 3 3))) + + ;; 8 + ((defun comp-tests-ret-type-spec-f (x) + (if (eq x 3) + x + 'foo)) + '(or (member foo) (integer 3 3))) + + ;; 9 + ((defun comp-tests-ret-type-spec-f (x) + (if (eq 3 x) + x + 'foo)) + '(or (member foo) (integer 3 3))) + + ;; 10 + ((defun comp-tests-ret-type-spec-f (x) + (if (eql x 3) + x + 'foo)) + '(or (member foo) (integer 3 3))) + + ;; 11 + ((defun comp-tests-ret-type-spec-f (x) + (if (eql 3 x) + x + 'foo)) + '(or (member foo) (integer 3 3))) + + ;; 12 + ((defun comp-tests-ret-type-spec-f (x) + (if (eql x 3) + 'foo + x)) + '(not (integer 3 3))) + + ;; 13 + ((defun comp-tests-ret-type-spec-f (x y) + (if (= x y) + x + 'foo)) + '(or (member foo) marker number)) + + ;; 14 + ((defun comp-tests-ret-type-spec-f (x) + (comp-hint-fixnum x)) + `(integer ,most-negative-fixnum ,most-positive-fixnum)) + + ;; 15 + ((defun comp-tests-ret-type-spec-f (x) + (comp-hint-cons x)) + 'cons) + + ;; 16 + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (when x + (setf y 4)) + y)) + '(or null (integer 4 4))) + + ;; 17 + ((defun comp-tests-ret-type-spec-f () + (let (x + (y 3)) + (setf x y) + y)) + '(integer 3 3)) + + ;; 18 + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when x + (setf y x)) + y)) + 't) + + ;; 19 + ((defun comp-tests-ret-type-spec-f (x y) + (eq x y)) + 'boolean) + + ;; 20 + ((defun comp-tests-ret-type-spec-f (x) + (when x + 'foo)) + '(or (member foo) null)) + + ;; 21 + ((defun comp-tests-ret-type-spec-f (x) + (unless x + 'foo)) + '(or (member foo) null)) + + ;; 22 + ((defun comp-tests-ret-type-spec-f (x) + (when (> x 3) + x)) + '(or null float (integer 4 *))) + + ;; 23 + ((defun comp-tests-ret-type-spec-f (x) + (when (>= x 3) + x)) + '(or null float (integer 3 *))) + + ;; 24 + ((defun comp-tests-ret-type-spec-f (x) + (when (< x 3) + x)) + '(or null float (integer * 2))) + + ;; 25 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= x 3) + x)) + '(or null float (integer * 3))) + + ;; 26 + ((defun comp-tests-ret-type-spec-f (x) + (when (> 3 x) + x)) + '(or null float (integer * 2))) + + ;; 27 + ((defun comp-tests-ret-type-spec-f (x) + (when (>= 3 x) + x)) + '(or null float (integer * 3))) + + ;; 28 + ((defun comp-tests-ret-type-spec-f (x) + (when (< 3 x) + x)) + '(or null float (integer 4 *))) + + ;; 29 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= 3 x) + x)) + '(or null float (integer 3 *))) + + ;; 30 + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when (> x y) + x))) + '(or null float (integer 4 *))) + + ;; 31 + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when (> y x) + x))) + '(or null float (integer * 2))) + + ;; 32 + ((defun comp-tests-ret-type-spec-f (x) + (when (and (> x 3) + (< x 10)) + x)) + '(or null float (integer 4 9))) + + ;; 33 + ((defun comp-tests-ret-type-spec-f (x) + (when (or (> x 3) + (< x 10)) + x)) + '(or null float integer)) + + ;; 34 + ((defun comp-tests-ret-type-spec-f (x) + (when (or (< x 3) + (> x 10)) + x)) + '(or null float (integer * 2) (integer 11 *))) + + ;; 35 No float range support. + ((defun comp-tests-ret-type-spec-f (x) + (when (> x 1.0) + x)) + '(or null marker number)) + + ;; 36 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (> x 3) + (> y 2)) + (+ x y))) + '(or null float (integer 7 *))) + + ;; 37 + ;; SBCL: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 3) + (<= y 2)) + (+ x y))) + '(or null float (integer * 5))) + + ;; 38 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (< 1 x 5) + (< 1 y 5)) + (+ x y))) + '(or null float (integer 4 8))) + + ;; 39 + ;; SBCL gives: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (+ x y))) + '(or null float (integer 3 13))) + + ;; 40 + ;; SBCL: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (- x y))) + '(or null float (integer -2 8))) + + ;; 41 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x) + (<= 2 y 3)) + (- x y))) + '(or null float (integer -2 *))) + + ;; 42 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y)) + (- x y))) + '(or null float (integer * 8))) + + ;; 43 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 10) + (<= 2 y)) + (- x y))) + '(or null float (integer * 8))) + + ;; 44 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 10) + (<= y 3)) + (- x y))) + '(or null float integer)) + + ;; 45 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 2 x) + (<= 3 y)) + (- x y))) + '(or null float integer)) + + ;; 46 + ;; SBCL: (OR (RATIONAL (6) (30)) (SINGLE-FLOAT 6.0 30.0) + ;; (DOUBLE-FLOAT 6.0d0 30.0d0) NULL) + ((defun comp-tests-ret-type-spec-f (x y z i j k) + (when (and (< 1 x 5) + (< 1 y 5) + (< 1 z 5) + (< 1 i 5) + (< 1 j 5) + (< 1 k 5)) + (+ x y z i j k))) + '(or null float (integer 12 24))) + + ;; 47 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= 1 x 5) + (1+ x))) + '(or null float (integer 2 6))) + + ;;48 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= 1 x 5) + (1- x))) + '(or null float (integer 0 4))) + + ;; 49 + ((defun comp-tests-ret-type-spec-f () + (error "Foo")) + 'nil) + + ;; 50 + ((defun comp-tests-ret-type-spec-f (x) + (if (stringp x) + x + 'bar)) + '(or (member bar) string)) + + ;; 51 + ((defun comp-tests-ret-type-spec-f (x) + (if (stringp x) + 'bar + x)) + '(not string)) + + ;; 52 + ((defun comp-tests-ret-type-spec-f (x) + (if (integerp x) + x + 'bar)) + '(or (member bar) integer)) + + ;; 53 + ((defun comp-tests-ret-type-spec-f (x) + (when (integerp x) + x)) + '(or null integer)) + + ;; 54 + ((defun comp-tests-ret-type-spec-f (x) + (unless (symbolp x) + x)) + 't) + + ;; 55 + ((defun comp-tests-ret-type-spec-f (x) + (unless (integerp x) + x)) + '(not integer)) + + ;; 56 + ((defun comp-tests-ret-type-spec-f (x) + (cl-ecase x + (1 (message "one")) + (5 (message "five"))) + x) + 't + ;; FIXME improve `comp-cond-cstrs-target-mvar' to cross block + ;; boundary if necessary as this should return: + ;; (or (integer 1 1) (integer 5 5)) + ) + + ;; 57 + ((defun comp-tests-ret-type-spec-f (x) + (unless (or (eq x 'foo) + (eql x 3)) + (error "Not foo or 3")) + x) + '(or (member foo) (integer 3 3))) + + ;;58 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (natnump x) + (natnump y) + (<= x y)) + x + (error ""))) + '(integer 0 *)) + + ;; 59 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (>= x 3) + (<= y 10) + (<= x y)) + x + (error ""))) + '(or float (integer 3 10))) + + ;; 60 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (<= x 10) + (>= y 3) + (>= x y)) + x + (error ""))) + '(or float (integer 3 10))) + + ;; 61 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.0) + x + (error ""))) + '(or (member 1.0) (integer 1 1))) + + ;; 62 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.0) + x + (error ""))) + '(or (member 1.0) (integer 1 1))) + + ;; 63 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.1) + x + (error ""))) + '(member 1.1)) + + ;; 64 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1) + x + (error ""))) + '(or (member 1.0) (integer 1 1))) + + ;; 65 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1) + x + (error ""))) + '(or (member 1.0) (integer 1 1))) + + ;; 66 + ((defun comp-tests-ret-type-spec-f (x) + (if (eql x 0.0) + x + (error ""))) + 'float) + + ;; 67 + ((defun comp-tests-ret-type-spec-f (x) + (if (equal x '(1 2 3)) + x + (error ""))) + 'cons) + + ;; 68 + ((defun comp-tests-ret-type-spec-f (x) + (if (and (floatp x) + (= x 1)) + x + (error ""))) + ;; Conservative (see cstr relax in `comp-cstr-='). + '(or (member 1.0) (integer 1 1))) + + ;; 69 + ((defun comp-tests-ret-type-spec-f (x) + (if (and (integer x) + (= x 1)) + x + (error ""))) + ;; Conservative (see cstr relax in `comp-cstr-='). + '(or (member 1.0) (integer 1 1))) + + ;; 70 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (floatp x) + (integerp y) + (= x y)) + x + (error ""))) + '(or float integer)) + + ;; 71 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 0.0) + x + (error ""))) + '(or (member -0.0 0.0) (integer 0 0))) + + ;; 72 + ((defun comp-tests-ret-type-spec-f (x) + (unless (= x 0.0) + (error "")) + (unless (eql x -0.0) + (error "")) + x) + 'float) + + ;; 73 + ((defun comp-tests-ret-type-spec-f (x) + (when (eql x 1.0) + (error "")) + x) + 't) + + ;; 74 + ((defun comp-tests-ret-type-spec-f (x) + (if (eq x 0) + (error "") + (1+ x))) + 'number))) + + (defun comp-tests-define-type-spec-test (number x) + `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () + ,(format "Type specifier test number %d." number) + (let ((comp-ctxt (make-comp-cstr-ctxt))) + (comp-tests-check-ret-type-spec ',(car x) ,(cadr x)))))) + +(defmacro comp-tests-define-type-spec-tests () + "Define all type specifier tests." + `(progn + ,@(cl-loop + for test in comp-tests-type-spec-tests + for n from 1 + collect (comp-tests-define-type-spec-test n test)))) + +(comp-tests-define-type-spec-tests) + +(defun comp-tests-pure-checker-1 (_) + "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is +folded." + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-pure-caller-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-pure-callee-f insn) + (comp-tests-mentioned-p (comp-c-func-name + 'comp-tests-pure-callee-f "F" t) + insn))))))) + +(defun comp-tests-pure-checker-2 (_) + "Check that `comp-tests-pure-fibn-f' is folded." + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-pure-fibn-entry-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-pure-fibn-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-fibn-f "F" t) + insn))))))) + +(comp-deftest pure () + "Some tests for pure functions optimization." + (let ((native-comp-speed 3) + (comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1 + comp-tests-pure-checker-2)))) + (load (native-compile (ert-resource-file "comp-test-pure.el"))) + (declare-function comp-tests-pure-caller-f nil) + (declare-function comp-tests-pure-fibn-entry-f nil) + + (should (subr-native-elisp-p (symbol-function 'comp-tests-pure-caller-f))) + (should (= (comp-tests-pure-caller-f) 4)) + + (should (subr-native-elisp-p (symbol-function 'comp-tests-pure-fibn-entry-f))) + (should (= (comp-tests-pure-fibn-entry-f) 6765)))) + +(defvar comp-tests-cond-rw-checked-function nil + "Function to be checked.") +(defun comp-tests-cond-rw-checker-val (_) + "Check we manage to propagate the correct return value." + (should + (cl-some + #'identity + (comp-tests-map-checker + comp-tests-cond-rw-checked-function + (lambda (insn) + (pcase insn + (`(return ,mvar) + (and (comp-cstr-imm-vld-p mvar) + (eql (comp-cstr-imm mvar) 123))))))))) + +(defvar comp-tests-cond-rw-expected-type nil + "Type to expect in `comp-tests-cond-rw-checker-type'.") +(defun comp-tests-cond-rw-checker-type (_) + "Check we manage to propagate the correct return type." + (should + (cl-some + #'identity + (comp-tests-map-checker + comp-tests-cond-rw-checked-function + (lambda (insn) + (pcase insn + (`(return ,mvar) + (equal (comp-mvar-typeset mvar) + comp-tests-cond-rw-expected-type)))))))) + +;;; comp-tests.el ends here diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 374d1689b9e..463a894d095 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -1,6 +1,6 @@ -;;; data-tests.el --- tests for src/data.c +;;; data-tests.el --- tests for src/data.c -*- lexical-binding:t -*- -;; Copyright (C) 2013-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -23,13 +23,21 @@ (require 'cl-lib) +(defconst data-tests--float-greater-than-fixnums (+ 1.0 most-positive-fixnum) + "A floating-point value that is greater than all fixnums. +It is also as small as conveniently possible, to make the tests sharper. +Adding 1.0 to `most-positive-fixnum' should suffice on all +practical Emacs platforms, since the result is a power of 2 and +this is exactly representable and is greater than +`most-positive-fixnum', which is just less than a power of 2.") + (ert-deftest data-tests-= () (should-error (=)) (should (= 1)) (should (= 2 2)) (should (= 9 9 9 9 9 9 9 9 9)) (should (= most-negative-fixnum (float most-negative-fixnum))) - (should-not (= most-positive-fixnum (+ 1.0 most-positive-fixnum))) + (should-not (= most-positive-fixnum data-tests--float-greater-than-fixnums)) (should-not (apply #'= '(3 8 3))) (should-error (= 9 9 'foo)) ;; Short circuits before getting to bad arg @@ -40,7 +48,7 @@ (should (< 1)) (should (< 2 3)) (should (< -6 -1 0 2 3 4 8 9 999)) - (should (< 0.5 most-positive-fixnum (+ 1.0 most-positive-fixnum))) + (should (< 0.5 most-positive-fixnum data-tests--float-greater-than-fixnums)) (should-not (apply #'< '(3 8 3))) (should-error (< 9 10 'foo)) ;; Short circuits before getting to bad arg @@ -51,7 +59,7 @@ (should (> 1)) (should (> 3 2)) (should (> 6 1 0 -2 -3 -4 -8 -9 -999)) - (should (> (+ 1.0 most-positive-fixnum) most-positive-fixnum 0.5)) + (should (> data-tests--float-greater-than-fixnums most-positive-fixnum 0.5)) (should-not (apply #'> '(3 8 3))) (should-error (> 9 8 'foo)) ;; Short circuits before getting to bad arg @@ -62,7 +70,7 @@ (should (<= 1)) (should (<= 2 3)) (should (<= -6 -1 -1 0 0 0 2 3 4 8 999)) - (should (<= 0.5 most-positive-fixnum (+ 1.0 most-positive-fixnum))) + (should (<= 0.5 most-positive-fixnum data-tests--float-greater-than-fixnums)) (should-not (apply #'<= '(3 8 3 3))) (should-error (<= 9 10 'foo)) ;; Short circuits before getting to bad arg @@ -73,7 +81,7 @@ (should (>= 1)) (should (>= 3 2)) (should (>= 666 1 0 0 -2 -3 -3 -3 -4 -8 -8 -9 -999)) - (should (>= (+ 1.0 most-positive-fixnum) most-positive-fixnum)) + (should (>= data-tests--float-greater-than-fixnums most-positive-fixnum)) (should-not (apply #'>= '(3 8 3))) (should-error (>= 9 8 'foo)) ;; Short circuits before getting to bad arg @@ -97,7 +105,7 @@ (should (= 2 (min 3 2))) (should (= -999 (min 666 1 0 0 -2 -3 -3 -3 -4 -8 -8 -9 -999))) (should (= most-positive-fixnum - (min (+ 1.0 most-positive-fixnum) most-positive-fixnum))) + (min data-tests--float-greater-than-fixnums most-positive-fixnum))) (should (= 3 (apply #'min '(3 8 3)))) (should-error (min 9 8 'foo)) (should-error (min (make-marker))) @@ -105,15 +113,17 @@ (should (isnan (min 0.0e+NaN))) (should (isnan (min 0.0e+NaN 1 2))) (should (isnan (min 1.0 0.0e+NaN))) - (should (isnan (min 1.0 0.0e+NaN 1.1)))) + (should (isnan (min 1.0 0.0e+NaN 1.1))) + (should (isnan (min 1.0 0.0e+NaN 1.1 (1+ most-positive-fixnum)))) + (should (isnan (max 1.0 0.0e+NaN 1.1 (1+ most-positive-fixnum))))) (defun data-tests-popcnt (byte) "Calculate the Hamming weight of BYTE." (if (< byte 0) (setq byte (lognot byte))) - (setq byte (- byte (logand (lsh byte -1) #x55555555))) - (setq byte (+ (logand byte #x33333333) (logand (lsh byte -2) #x33333333))) - (lsh (* (logand (+ byte (lsh byte -4)) #x0f0f0f0f) #x01010101) -24)) + (if (zerop byte) + 0 + (+ (logand byte 1) (data-tests-popcnt (ash byte -1))))) (ert-deftest data-tests-logcount () (should (cl-loop for n in (number-sequence -255 255) @@ -164,7 +174,7 @@ sum 1)) (defun test-bool-vector-bv-from-hex-string (desc) - (let (bv nchars nibbles) + (let (bv nibbles) (dolist (c (string-to-list desc)) (push (string-to-number (char-to-string c) @@ -176,29 +186,28 @@ (dotimes (_ 4) (aset bv i (> (logand 1 n) 0)) (cl-incf i) - (setf n (lsh n -1))))) + (setf n (ash n -1))))) bv)) (defun test-bool-vector-to-hex-string (bv) (let (nibbles (v (cl-coerce bv 'list))) (while v (push (logior - (lsh (if (nth 0 v) 1 0) 0) - (lsh (if (nth 1 v) 1 0) 1) - (lsh (if (nth 2 v) 1 0) 2) - (lsh (if (nth 3 v) 1 0) 3)) + (ash (if (nth 0 v) 1 0) 0) + (ash (if (nth 1 v) 1 0) 1) + (ash (if (nth 2 v) 1 0) 2) + (ash (if (nth 3 v) 1 0) 3)) nibbles) (setf v (nthcdr 4 v))) (mapconcat (lambda (n) (format "%X" n)) - (nreverse nibbles) - ""))) + (nreverse nibbles)))) (defun test-bool-vector-count-consecutive-tc (desc) - "Run a test case for bool-vector-count-consecutive. + "Run a test case for `bool-vector-count-consecutive'. DESC is a string describing the test. It is a sequence of hexadecimal digits describing the bool vector. We exhaustively test all counts at all possible positions in the vector by -comparing the subr with a much slower lisp implementation." +comparing the subr with a much slower Lisp implementation." (let ((bv (test-bool-vector-bv-from-hex-string desc))) (cl-loop for lf in '(nil t) @@ -234,9 +243,9 @@ comparing the subr with a much slower lisp implementation." (defun test-bool-vector-apply-mock-op (mock a b c) "Compute (slowly) the correct result of a bool-vector set operation." - (let (changed nv) + (let (changed) (cl-assert (eql (length b) (length c))) - (if a (setf nv a) + (unless a (setf a (make-bool-vector (length b) nil)) (setf changed t)) @@ -314,7 +323,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." @@ -328,13 +337,55 @@ comparing the subr with a much slower lisp implementation." (should (eq binding-test-some-local 'local)))) (ert-deftest binding-test-setq-default () - "Test that a setq-default has no effect when there is a local binding." + "Test that a `setq-default' has no effect when there is a local binding." (with-current-buffer binding-test-buffer-B ;; This variable is not local in this buffer. (let ((binding-test-some-local 'something-else)) (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 (not (local-variable-p var))) + (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 data-tests--let-buffer-local-no-unwind-other-buffers () + "Test that a let-binding for a buffer-local unwinds only current-buffer." + (let ((blvar (make-symbol "blvar"))) + (set-default blvar 0) + (make-variable-buffer-local blvar) + (dolist (var (list blvar 'left-margin)) + (let* ((def (default-value var)) + (newdef (+ def 1)) + (otherbuf (generate-new-buffer "otherbuf"))) + (with-temp-buffer + (cl-progv (list var) (list newdef) + (with-current-buffer otherbuf + (set var 123) + (should (local-variable-p var)) + (should (equal (symbol-value var) 123)) + (should (equal (default-value var) newdef)))) + (with-current-buffer otherbuf + (should (local-variable-p var)) + (should (equal (symbol-value var) 123)) + (should (equal (default-value var) def))) + ))))) + (ert-deftest binding-test-makunbound () "Tests of makunbound, from the manual." (with-current-buffer binding-test-buffer-B @@ -347,30 +398,62 @@ comparing the subr with a much slower lisp implementation." (eq binding-test-some-local 'outer)))))) (ert-deftest binding-test-defvar-bool () - "Test DEFVAR_BOOL" + "Test DEFVAR_BOOL." (let ((display-hourglass 5)) (should (eq display-hourglass t)))) (ert-deftest binding-test-defvar-int () - "Test DEFVAR_INT" + "Test DEFVAR_INT." (should-error (setq gc-cons-threshold 5.0) :type 'wrong-type-argument)) (ert-deftest binding-test-set-constant-t () - "Test setting the constant t" + "Test setting the constant t." (with-no-warnings (should-error (setq t 'bob) :type 'setting-constant))) (ert-deftest binding-test-set-constant-nil () - "Test setting the constant nil" + "Test setting the constant nil." (with-no-warnings (should-error (setq nil 'bob) :type 'setting-constant))) (ert-deftest binding-test-set-constant-keyword () - "Test setting a keyword constant" + "Test setting a keyword constant." (with-no-warnings (should-error (setq :keyword 'bob) :type 'setting-constant))) -(ert-deftest binding-test-set-constant-nil () - "Test setting a keyword to itself" +(ert-deftest binding-test-set-constant-itself () + "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. + (when (fboundp 'current-cpu-time) ; silence byte-compiler + (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 @@ -474,7 +557,7 @@ comparing the subr with a much slower lisp implementation." (should-have-watch-data `(data-tests-lvar 3 set ,buf1))) (should-have-watch-data `(data-tests-lvar 1 unlet ,buf1)) (setq-default data-tests-lvar 4) - (should-have-watch-data `(data-tests-lvar 4 set nil)) + (should-have-watch-data '(data-tests-lvar 4 set nil)) (with-temp-buffer (setq buf2 (current-buffer)) (setq data-tests-lvar 1) @@ -491,7 +574,7 @@ comparing the subr with a much slower lisp implementation." (kill-all-local-variables) (should-have-watch-data `(data-tests-lvar nil makunbound ,buf2))) (setq-default data-tests-lvar 4) - (should-have-watch-data `(data-tests-lvar 4 set nil)) + (should-have-watch-data '(data-tests-lvar 4 set nil)) (makunbound 'data-tests-lvar) (should-have-watch-data '(data-tests-lvar nil makunbound nil)) (setq data-tests-lvar 5) @@ -499,3 +582,194 @@ comparing the subr with a much slower lisp implementation." (remove-variable-watcher 'data-tests-lvar collect-watch-data) (setq data-tests-lvar 6) (should (null watch-data))))) + +(ert-deftest data-tests-kill-all-local-variables () ;bug#30846 + (with-temp-buffer + (setq-local data-tests-foo1 1) + (setq-local data-tests-foo2 2) + (setq-local data-tests-foo3 3) + (let ((oldfoo2 nil)) + (add-variable-watcher 'data-tests-foo2 + (lambda (&rest _) + (setq oldfoo2 (bound-and-true-p data-tests-foo2)))) + (kill-all-local-variables) + (should (equal oldfoo2 '2)) ;Watcher is run before changing the var. + (should (not (or (bound-and-true-p data-tests-foo1) + (bound-and-true-p data-tests-foo2) + (bound-and-true-p data-tests-foo3))))))) + +(ert-deftest data-tests-bignum () + (should (bignump (+ most-positive-fixnum 1))) + (let ((f0 (+ (float most-positive-fixnum) 1)) + (f-1 (- (float most-negative-fixnum) 1)) + (b0 (+ most-positive-fixnum 1)) + (b-1 (- most-negative-fixnum 1))) + (should (> b0 -1)) + (should (> b0 f-1)) + (should (> b0 b-1)) + (should (>= b0 -1)) + (should (>= b0 f-1)) + (should (>= b0 b-1)) + (should (>= b-1 b-1)) + + (should (< -1 b0)) + (should (< f-1 b0)) + (should (< b-1 b0)) + (should (<= -1 b0)) + (should (<= f-1 b0)) + (should (<= b-1 b0)) + (should (<= b-1 b-1)) + + (should (= (+ f0 b0) (+ b0 f0))) + (should (= (+ f0 b-1) (+ b-1 f0))) + (should (= (+ f-1 b0) (+ b0 f-1))) + (should (= (+ f-1 b-1) (+ b-1 f-1))) + + (should (= (* f0 b0) (* b0 f0))) + (should (= (* f0 b-1) (* b-1 f0))) + (should (= (* f-1 b0) (* b0 f-1))) + (should (= (* f-1 b-1) (* b-1 f-1))) + + (should (= b0 f0)) + (should (= b0 b0)) + + (should (/= b0 f-1)) + (should (/= b0 b-1)) + + (should (/= b0 0.0e+NaN)) + (should (/= b-1 0.0e+NaN)))) + +(ert-deftest data-tests-+ () + (should-not (fixnump (+ most-positive-fixnum most-positive-fixnum))) + (should (> (+ most-positive-fixnum most-positive-fixnum) most-positive-fixnum)) + (should (eq (- (+ most-positive-fixnum most-positive-fixnum) + (+ most-positive-fixnum most-positive-fixnum)) + 0))) + +(ert-deftest data-tests-/ () + (let* ((x (* most-positive-fixnum 8)) + (y (* most-negative-fixnum 8)) + (z (- y))) + (should (= most-positive-fixnum (/ x 8))) + (should (= most-negative-fixnum (/ y 8))) + (should (= -1 (/ y z))) + (should (= -1 (/ z y))) + (should (= 0 (/ x (* 2 x)))) + (should (= 0 (/ y (* 2 y)))) + (should (= 0 (/ z (* 2 z)))))) + +(ert-deftest data-tests-number-predicates () + (should (fixnump 0)) + (should (fixnump most-negative-fixnum)) + (should (fixnump most-positive-fixnum)) + (should (integerp (+ most-positive-fixnum 1))) + (should (integer-or-marker-p (+ most-positive-fixnum 1))) + (should (numberp (+ most-positive-fixnum 1))) + (should (number-or-marker-p (+ most-positive-fixnum 1))) + (should (natnump (+ most-positive-fixnum 1))) + (should-not (fixnump (+ most-positive-fixnum 1))) + (should (bignump (+ most-positive-fixnum 1)))) + +(ert-deftest data-tests-number-to-string () + (let* ((s "99999999999999999999999999999") + (v (read s))) + (should (equal (number-to-string v) s)))) + +(ert-deftest data-tests-1+ () + (should (> (1+ most-positive-fixnum) most-positive-fixnum)) + (should (fixnump (1+ (1- most-negative-fixnum))))) + +(ert-deftest data-tests-1- () + (should (< (1- most-negative-fixnum) most-negative-fixnum)) + (should (fixnump (1- (1+ most-positive-fixnum))))) + +(ert-deftest data-tests-logand () + (should (= -1 (logand) (logand -1) (logand -1 -1))) + (let ((n (1+ most-positive-fixnum))) + (should (= (logand -1 n) n))) + (let ((n (* 2 most-negative-fixnum))) + (should (= (logand -1 n) n)))) + +(ert-deftest data-tests-logcount-2 () + (should (= (logcount (read "#xffffffffffffffffffffffffffffffff")) 128))) + +(ert-deftest data-tests-logior () + (should (= -1 (logior -1) (logior -1 -1))) + (should (= -1 (logior most-positive-fixnum most-negative-fixnum)))) + +(ert-deftest data-tests-logxor () + (should (= -1 (logxor -1) (logxor -1 -1 -1))) + (let ((n (1+ most-positive-fixnum))) + (should (= (logxor -1 n) (lognot n))))) + +(ert-deftest data-tests-minmax () + (let ((a (- most-negative-fixnum 1)) + (b (+ most-positive-fixnum 1)) + (c 0)) + (should (= (min a b c) a)) + (should (= (max a b c) b)))) + +(defun data-tests-check-sign (x y) + (should (eq (cl-signum x) (cl-signum y)))) + +(ert-deftest data-tests-%-mod () + (let* ((b1 (+ most-positive-fixnum 1)) + (nb1 (- b1)) + (b3 (+ most-positive-fixnum 3)) + (nb3 (- b3))) + (data-tests-check-sign (% 1 3) (% b1 b3)) + (data-tests-check-sign (mod 1 3) (mod b1 b3)) + (data-tests-check-sign (% 1 -3) (% b1 nb3)) + (data-tests-check-sign (mod 1 -3) (mod b1 nb3)) + (data-tests-check-sign (% -1 3) (% nb1 b3)) + (data-tests-check-sign (mod -1 3) (mod nb1 b3)) + (data-tests-check-sign (% -1 -3) (% nb1 nb3)) + (data-tests-check-sign (mod -1 -3) (mod nb1 nb3)))) + +(ert-deftest data-tests-mod-0 () + (dolist (num (list (1- most-negative-fixnum) -1 0 1 + (1+ most-positive-fixnum))) + (should-error (mod num 0))) + (when (ignore-errors (/ 0.0 0)) + (should (equal (abs (mod 0.0 0)) (abs (- 0.0 (/ 0.0 0))))))) + +(ert-deftest data-tests-ash-lsh () + (should (= (ash most-negative-fixnum 1) + (* most-negative-fixnum 2))) + (should (= (ash 0 (* 2 most-positive-fixnum)) 0)) + (should (= (ash 1000 (* 2 most-negative-fixnum)) 0)) + (should (= (ash -1000 (* 2 most-negative-fixnum)) -1)) + (should (= (ash (* 2 most-negative-fixnum) (* 2 most-negative-fixnum)) -1)) + (should (= (ash (* 2 most-negative-fixnum) -1) + most-negative-fixnum)) + (with-suppressed-warnings ((suspicious lsh)) + (should (= (lsh most-negative-fixnum 1) + (* most-negative-fixnum 2))) + (should (= (lsh most-positive-fixnum -1) (/ most-positive-fixnum 2))) + (should (= (lsh most-negative-fixnum -1) (lsh (- most-negative-fixnum) -1))) + (should (= (lsh -1 -1) most-positive-fixnum)) + (should-error (lsh (1- most-negative-fixnum) -1)))) + +(ert-deftest data-tests-make-local-forwarded-var () ;bug#34318 + ;; Boy, this bug is tricky to trigger. You need to: + ;; - call make-local-variable on a forwarded var (i.e. one that + ;; has a corresponding C var linked via DEFVAR_(LISP|INT|BOOL)) + ;; - cause the C code to modify this variable from the C side of the + ;; forwarding, but this needs to happen before the var is accessed + ;; from the Lisp side and before we switch to another buffer. + ;; The trigger in bug#34318 doesn't exist any more because the C code has + ;; changed. Instead I found the trigger below. + (with-temp-buffer + (setq last-coding-system-used 'bug34318) + (make-local-variable 'last-coding-system-used) + ;; This should set last-coding-system-used to `no-conversion'. + (decode-coding-string "hello" nil) + (should (equal (list last-coding-system-used + (default-value 'last-coding-system-used)) + '(no-conversion bug34318))))) + +(ert-deftest data-tests-make_symbol_constant () + "Can't set variable marked with 'make_symbol_constant'." + (should-error (setq most-positive-fixnum 1) :type 'setting-constant)) + +;;; data-tests.el ends here diff --git a/test/src/decompress-tests.el b/test/src/decompress-tests.el index 8a6f4d1fb95..47d67b7bda4 100644 --- a/test/src/decompress-tests.el +++ b/test/src/decompress-tests.el @@ -1,6 +1,6 @@ -;;; decompress-tests.el --- Test suite for decompress. +;;; decompress-tests.el --- Test suite for decompress. -*- lexical-binding: t -*- -;; Copyright (C) 2013-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 Free Software Foundation, Inc. ;; Author: Lars Ingebrigtsen <larsi@gnus.org> @@ -23,23 +23,25 @@ (require 'ert) +(declare-function zlib-decompress-region "decompress.c") + (defvar zlib-tests-data-directory (expand-file-name "data/decompress" (getenv "EMACS_TEST_DIRECTORY")) "Directory containing zlib test data.") (ert-deftest zlib--decompress () "Test decompressing a gzipped file." - (when (and (fboundp 'zlib-available-p) - (zlib-available-p)) - (should (string= - (with-temp-buffer - (set-buffer-multibyte nil) - (insert-file-contents-literally - (expand-file-name "foo.gz" zlib-tests-data-directory)) - (zlib-decompress-region (point-min) (point-max)) - (buffer-string)) - "foo\n")))) + (skip-unless (and (fboundp 'zlib-available-p) + (zlib-available-p))) + (should (string= + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-literally + (expand-file-name "foo.gz" zlib-tests-data-directory)) + (zlib-decompress-region (point-min) (point-max)) + (buffer-string)) + "foo\n"))) (provide 'decompress-tests) -;;; decompress-tests.el ends here. +;;; decompress-tests.el ends here diff --git a/test/src/doc-tests.el b/test/src/doc-tests.el index d8e4320bc6f..ee4f02347ec 100644 --- a/test/src/doc-tests.el +++ b/test/src/doc-tests.el @@ -1,92 +1,43 @@ -;;; doc-tests.el --- Tests for doc.c +;;; doc-tests.el --- tests for doc.c functions -*- lexical-binding: t -*- -;; Copyright (C) 2016-2017 Free Software Foundation, Inc. +;; Copyright (C) 2022 Free Software Foundation, Inc. -;; Author: Eli Zaretskii <eliz@gnu.org> +;; 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) -(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. - (should (string= (substitute-command-keys - "\\{minibuffer-local-must-match-map}") - "\ -key binding ---- ------- +(ert-deftest doc-tests-documentation/c-primitive () + (should (stringp (documentation 'defalias)))) -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 +(ert-deftest doc-tests-documentation/preloaded () + (should (stringp (documentation 'defun)))) -M-v switch-to-completions +(ert-deftest doc-tests-documentation/autoloaded-macro () + (skip-unless noninteractive) + (should (autoloadp (symbol-function 'benchmark-run))) + (should (stringp (documentation 'benchmark-run)))) ; See Bug#52969. -M-n next-history-element -M-p previous-history-element -M-r previous-matching-history-element -M-s next-matching-history-element +(ert-deftest doc-tests-documentation/autoloaded-defun () + (skip-unless noninteractive) + (should (autoloadp (symbol-function 'tetris))) + (should (stringp (documentation 'tetris)))) ; See Bug#52969. -")) - (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 "\\=") "\\=")) - ) +(ert-deftest doc-tests-quoting-style () + (should (memq (text-quoting-style) '(grave straight curve)))) -(provide 'doc-tests) ;;; doc-tests.el ends here diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index 70dc9372fad..5fe896fbbd1 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-2017 Free Software Foundation, Inc. +;; Copyright (C) 2016-2022 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: @@ -23,16 +23,16 @@ (ert-deftest format-properties () ;; Bug #23730 - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "%d" 'face '(:background "red")) 1) #("1" 0 1 (face (:background "red"))))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "%2d" 'face '(:background "red")) 1) #(" 1" 0 2 (face (:background "red"))))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "%02d" 'face '(:background "red")) 1) #("01" 0 2 (face (:background "red"))))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat (propertize "%2d" 'x 'X) (propertize "a" 'a 'A) (propertize "b" 'b 'B)) @@ -40,27 +40,27 @@ #(" 1ab" 0 2 (x X) 2 3 (a A) 3 4 (b B)))) ;; Bug #5306 - (should (ert-equal-including-properties + (should (equal-including-properties (format "%.10s" (concat "1234567890aaaa" (propertize "12345678901234567890" 'xxx 25))) "1234567890")) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%.10s" (concat "123456789" (propertize "12345678901234567890" 'xxx 25))) #("1234567891" 9 10 (xxx 25)))) ;; Bug #23859 - (should (ert-equal-including-properties + (should (equal-including-properties (format "%4s" (propertize "hi" 'face 'bold)) #(" hi" 2 4 (face bold)))) ;; Bug #23897 - (should (ert-equal-including-properties + (should (equal-including-properties (format "%s" (concat (propertize "01234" 'face 'bold) "56789")) #("0123456789" 0 5 (face bold)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) "45")) @@ -68,27 +68,69 @@ ;; The last property range is extended to include padding on the ;; right, but the first range is not extended to the left to include ;; padding on the left! - (should (ert-equal-including-properties + (should (equal-including-properties (format "%12s" (concat (propertize "01234" 'face 'bold) "56789")) #(" 0123456789" 2 7 (face bold)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%-12s" (concat (propertize "01234" 'face 'bold) "56789")) #("0123456789 " 0 5 (face bold)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%10s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) "45")) #(" 012345" 4 6 (face bold) 6 8 (face underline)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%-10s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) "45")) #("012345 " 0 2 (face bold) 2 4 (face underline)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%-10s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) (propertize "45" 'face 'italic))) - #("012345 " 0 2 (face bold) 2 4 (face underline) 4 10 (face italic))))) + #("012345 " + 0 2 (face bold) 2 4 (face underline) 4 10 (face italic)))) + ;; Bug #38191 + (should (equal-including-properties + (format (propertize "‘foo’ %s bar" 'face 'bold) "xxx") + #("‘foo’ xxx bar" 0 13 (face bold)))) + ;; Bug #32404 + (should (equal-including-properties + (format (concat (propertize "%s" 'face 'bold) + "" + (propertize "%s" 'face 'error)) + "foo" "bar") + #("foobar" 0 3 (face bold) 3 6 (face error)))) + (should (equal-including-properties + (format (concat "%s" (propertize "%s" 'face 'error)) "foo" "bar") + #("foobar" 3 6 (face error)))) + (should (equal-including-properties + (format (concat "%s " (propertize "%s" 'face 'error)) "foo" "bar") + #("foo bar" 4 7 (face error)))) + ;; Bug #46317 + (let ((s (propertize "X" 'prop "val"))) + (should (equal-including-properties + (format (concat "%3s/" s) 12) + #(" 12/X" 4 5 (prop "val")))) + (should (equal-including-properties + (format (concat "%3S/" s) 12) + #(" 12/X" 4 5 (prop "val")))) + (should (equal-including-properties + (format (concat "%3d/" s) 12) + #(" 12/X" 4 5 (prop "val")))) + (should (equal-including-properties + (format (concat "%-3s/" s) 12) + #("12 /X" 4 5 (prop "val")))) + (should (equal-including-properties + (format (concat "%-3S/" s) 12) + #("12 /X" 4 5 (prop "val")))) + (should (equal-including-properties + (format (concat "%-3d/" s) 12) + #("12 /X" 4 5 (prop "val")))))) + +(ert-deftest propertize/error-even-number-of-args () + "Number of args for `propertize' must be odd." + (should-error (propertize "foo" 'bar) :type 'wrong-number-of-arguments)) ;; Tests for bug#5131. (defun transpose-test-reverse-word (start end) @@ -106,8 +148,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 @@ -136,54 +178,59 @@ (ert-deftest format-c-float () (should-error (format "%c" 0.5))) -;;; Check format-time-string with various TZ settings. -;;; Use only POSIX-compatible TZ values, since the tests should work -;;; even if tzdb is not in use. -(ert-deftest format-time-string-with-zone () - ;; Don’t use (0 0 0 0) as the test case, as there are too many bugs - ;; in MS-Windows (and presumably other) C libraries when formatting - ;; time stamps near the Epoch of 1970-01-01 00:00:00 UTC, and this - ;; test is for GNU Emacs, not for C runtimes. Instead, look before - ;; you leap: "look" is the timestamp just before the first leap - ;; second on 1972-06-30 23:59:60 UTC, so it should format to the - ;; same string regardless of whether the underlying C library - ;; ignores leap seconds, while avoiding circa-1970 glitches. - ;; - ;; Similarly, stick to the limited set of time zones that are - ;; supported by both POSIX and MS-Windows: exactly 3 ASCII letters - ;; in the abbreviation, and no DST. - (let ((look '(1202 22527 999999 999999)) - (format "%Y-%m-%d %H:%M:%S.%3N %z (%Z)")) - ;; UTC. - (should (string-equal - (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" look t) - "1972-06-30 23:59:59.999 +0000")) - ;; "UTC0". - (should (string-equal - (format-time-string format look "UTC0") - "1972-06-30 23:59:59.999 +0000 (UTC)")) - ;; Negative UTC offset, as a Lisp list. - (should (string-equal - (format-time-string format look '(-28800 "PST")) - "1972-06-30 15:59:59.999 -0800 (PST)")) - ;; Negative UTC offset, as a Lisp integer. - (should (string-equal - (format-time-string format look -28800) - ;; MS-Windows build replaces unrecognizable TZ values, - ;; such as "-08", with "ZZZ". - (if (eq system-type 'windows-nt) - "1972-06-30 15:59:59.999 -0800 (ZZZ)" - "1972-06-30 15:59:59.999 -0800 (-08)"))) - ;; Positive UTC offset that is not an hour multiple, as a string. - (should (string-equal - (format-time-string format look "IST-5:30") - "1972-07-01 05:29:59.999 +0530 (IST)")))) - -;;; This should not dump core. -(ert-deftest format-time-string-with-outlandish-zone () - (should (stringp - (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" nil - (concat (make-string 2048 ?X) "0"))))) +;;; Test for Bug#29609. +(ert-deftest format-sharp-0-x () + (should (string-equal (format "%#08x" #x10) "0x000010")) + (should (string-equal (format "%#05X" #x10) "0X010")) + (should (string-equal (format "%#04x" 0) "0000"))) + + +;;; Tests for Bug#30408. + +(ert-deftest format-%d-large-float () + (should (string-equal (format "%d" 18446744073709551616.0) + "18446744073709551616")) + (should (string-equal (format "%d" -18446744073709551616.0) + "-18446744073709551616"))) + +(ert-deftest format-%x-large-float () + (should (string-equal (format "%x" 18446744073709551616.0) + "10000000000000000"))) +(ert-deftest read-large-integer () + (should (eq (type-of (read (format "%d0" most-negative-fixnum))) 'integer)) + (should (eq (type-of (read (format "%+d" (* -8.0 most-negative-fixnum)))) + 'integer)) + (should (eq (type-of (read (substring (format "%d" most-negative-fixnum) 1))) + 'integer)) + (should (eq (type-of (read (format "#x%x" most-negative-fixnum))) + 'integer)) + (should (eq (type-of (read (format "#o%o" most-negative-fixnum))) + 'integer)) + (should (eq (type-of (read (format "#32rG%x" most-positive-fixnum))) + 'integer)) + (dolist (fmt '("%d" "%s" "#o%o" "#x%x")) + (dolist (val (list most-negative-fixnum (1+ most-negative-fixnum) + -1 0 1 + (1- most-positive-fixnum) most-positive-fixnum)) + (should (eq val (read (format fmt val))))) + (dolist (val (list (1+ most-positive-fixnum) + (* 2 (1+ most-positive-fixnum)) + (* 4 (1+ most-positive-fixnum)) + (* 8 (1+ most-positive-fixnum)) + 18446744073709551616.0)) + (should (= val (read (format fmt val))))))) + +(ert-deftest format-%o-negative-float () + (should (string-equal (format "%o" -1e-37) "0"))) + +;; Bug#31938 +(ert-deftest format-%d-float () + (should (string-equal (format "%d" -1.1) "-1")) + (should (string-equal (format "%d" -0.9) "0")) + (should (string-equal (format "%d" -0.0) "0")) + (should (string-equal (format "%d" 0.0) "0")) + (should (string-equal (format "%d" 0.9) "0")) + (should (string-equal (format "%d" 1.1) "1"))) (ert-deftest format-with-field () (should (equal (format "First argument %2$s, then %3$s, then %1$s" 1 2 3) @@ -247,4 +294,136 @@ (buffer-string) "foo bar baz qux")))))) +(ert-deftest replace-buffer-contents-bug31837 () + (switch-to-buffer "a") + (insert-char (char-from-name "SMILE")) + (insert "1234") + (switch-to-buffer "b") + (insert-char (char-from-name "SMILE")) + (insert "5678") + (replace-buffer-contents "a") + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + (concat (string (char-from-name "SMILE")) "1234")))) + +(ert-deftest delete-region-undo-markers-1 () + "Make sure we don't end up with freed markers reachable from Lisp." + ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=30931#40 + (with-temp-buffer + (insert "1234567890") + (setq buffer-undo-list nil) + (narrow-to-region 2 5) + ;; `save-restriction' in a narrowed buffer creates two markers + ;; representing the current restriction. + (save-restriction + (widen) + ;; Any markers *within* the deleted region are put onto the undo + ;; list. + (delete-region 1 6)) + ;; (princ (format "%S" buffer-undo-list) #'external-debugging-output) + ;; `buffer-undo-list' is now + ;; (("12345" . 1) (#<temp-marker1> . -1) (#<temp-marker2> . 1)) + ;; + ;; If temp-marker1 or temp-marker2 are freed prematurely, calling + ;; `type-of' on them will cause Emacs to abort. Calling + ;; `garbage-collect' will also abort if it finds any reachable + ;; freed objects. + (should (eq (type-of (car (nth 1 buffer-undo-list))) 'marker)) + (should (eq (type-of (car (nth 2 buffer-undo-list))) 'marker)) + (garbage-collect))) + +(ert-deftest delete-region-undo-markers-2 () + "Make sure we don't end up with freed markers reachable from Lisp." + ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=30931#55 + (with-temp-buffer + (insert "1234567890") + (setq buffer-undo-list nil) + ;; signal_before_change creates markers delimiting a change + ;; region. + (let ((before-change-functions + (list (lambda (beg end) + (delete-region (1- beg) (1+ end)))))) + (delete-region 2 5)) + ;; (princ (format "%S" buffer-undo-list) #'external-debugging-output) + ;; `buffer-undo-list' is now + ;; (("678" . 1) ("12345" . 1) (#<marker in no buffer> . -1) + ;; (#<temp-marker1> . -1) (#<temp-marker2> . -4)) + ;; + ;; If temp-marker1 or temp-marker2 are freed prematurely, calling + ;; `type-of' on them will cause Emacs to abort. Calling + ;; `garbage-collect' will also abort if it finds any reachable + ;; freed objects. + (should (eq (type-of (car (nth 3 buffer-undo-list))) 'marker)) + (should (eq (type-of (car (nth 4 buffer-undo-list))) 'marker)) + (garbage-collect))) + +(ert-deftest format-bignum () + (let* ((s1 "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF") + (v1 (read (concat "#x" s1))) + (s2 "99999999999999999999999999999999") + (v2 (read s2)) + (v3 #x-3ffffffffffffffe000000000000000)) + (should (> v1 most-positive-fixnum)) + (should (equal (format "%X" v1) s1)) + (should (> v2 most-positive-fixnum)) + (should (equal (format "%d" v2) s2)) + (should (equal (format "%d" v3) "-5316911983139663489309385231907684352")) + (should (equal (format "%+d" v3) "-5316911983139663489309385231907684352")) + (should (equal (format "%+d" (- v3)) + "+5316911983139663489309385231907684352")) + (should (equal (format "% d" (- v3)) + " 5316911983139663489309385231907684352")) + (should (equal (format "%o" v3) + "-37777777777777777777600000000000000000000")) + (should (equal (format "%#50.40x" v3) + " -0x000000003ffffffffffffffe000000000000000")) + (should (equal (format "%-#50.40x" v3) + "-0x000000003ffffffffffffffe000000000000000 ")))) + +(ert-deftest test-group-name () + (let ((group-name (group-name (group-gid)))) + ;; If the GID has no associated entry in /etc/group there's no + ;; name for it and `group-name' should return nil! + (should (or (null group-name) (stringp group-name)))) + (should-error (group-name 'foo)) + (cond + ((memq system-type '(windows-nt ms-dos)) + (should-not (group-name 123456789))) + ((executable-find "getent") + (with-temp-buffer + (let (stat name) + (dolist (gid (list 0 1212345 (group-gid))) + (erase-buffer) + (setq stat (ignore-errors + (call-process "getent" nil '(t nil) nil "group" + (number-to-string gid)))) + (setq name (group-name gid)) + (goto-char (point-min)) + (cond ((eq stat 0) + (if (looking-at "\\([[:alnum:]_-]+\\):") + (should (string= (match-string 1) name)))) + ((eq stat 2) + (should-not name))))))))) + +(ert-deftest test-translate-region-internal () + (with-temp-buffer + (let ((max-char #16r3FFFFF) + (tt (make-char-table 'translation-table))) + (aset tt max-char ?*) + (insert max-char) + (translate-region-internal (point-min) (point-max) tt) + (should (string-equal (buffer-string) "*"))))) + +(ert-deftest find-fields () + (with-temp-buffer + (insert "foo" (propertize "bar" 'field 'bar) "zot") + (goto-char (point-min)) + (should (= (field-beginning) (point-min))) + (should (= (field-end) 4)) + (goto-char 5) + (should (= (field-beginning) 4)) + (should (= (field-end) 7)) + (goto-char 8) + (should (= (field-beginning) 7)) + (should (= (field-end) (point-max))))) + ;;; editfns-tests.el ends here 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..187af821c22 --- /dev/null +++ b/test/src/emacs-module-resources/mod-test.c @@ -0,0 +1,868 @@ +/* Test GNU Emacs modules. + +Copyright 2015-2022 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> + +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 + +/* 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]; +}; + +static void signal_errno (emacs_env *, char const *); + +/* 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); + if (!p) + { + signal_errno (env, "calloc"); + return NULL; + } + 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); +} + +#ifdef CLOCK_REALTIME + +/* Whether A <= B. */ +static bool +timespec_le (struct timespec a, struct timespec b) +{ + return (a.tv_sec < b.tv_sec + || (a.tv_sec == b.tv_sec && a.tv_nsec <= b.tv_nsec)); +} + +/* 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 = { .tv_nsec = 10000000 }; + while (true) + { + struct timespec now; + if (clock_gettime (CLOCK_REALTIME, &now) != 0) + return NULL; + if (timespec_le (until, now)) + 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"); +} +#endif + +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; +} + +#ifdef CLOCK_REALTIME +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); + 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; +} +#endif + +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 = { .tv_nsec = 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) +{ + /* These smoke tests don't use _Static_assert because too many + compilers lack support for _Static_assert. */ + assert (0 < EMACS_LIMB_MAX); + assert (1000000000 <= ULONG_MAX); + + /* 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); +#ifdef CLOCK_REALTIME + DEFUN ("mod-test-sleep-until", Fmod_test_sleep_until, 2, 2, NULL, NULL); +#endif + DEFUN ("mod-test-add-nanosecond", Fmod_test_add_nanosecond, 1, 1, NULL, NULL); +#ifdef CLOCK_REALTIME + DEFUN ("mod-test-nanoseconds", Fmod_test_nanoseconds, 1, 1, NULL, NULL); +#endif + 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 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 diff --git a/test/src/emacs-tests.el b/test/src/emacs-tests.el new file mode 100644 index 00000000000..52888135c12 --- /dev/null +++ b/test/src/emacs-tests.el @@ -0,0 +1,249 @@ +;;; emacs-tests.el --- unit tests for emacs.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-2022 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/>. + +;;; Commentary: + +;; Unit tests for src/emacs.c. + +;;; Code: + +(require 'cl-lib) +(require 'ert) +(require 'ert-x) ; ert-with-temp-file +(require 'rx) +(require 'subr-x) + +(defconst emacs-tests--lib-src + (substitute-in-file-name "$EMACS_TEST_DIRECTORY/../lib-src/") + "Location of the lib-src directory.") + +(ert-deftest emacs-tests/seccomp/absent-file () + (skip-unless (string-match-p (rx bow "SECCOMP" eow) + system-configuration-features)) + (let ((emacs + (expand-file-name invocation-name invocation-directory)) + (process-environment nil)) + (skip-unless (file-executable-p emacs)) + (should-not (file-exists-p "/does-not-exist.bpf")) + (should-not + (eql (call-process emacs nil nil nil + "--quick" "--batch" + "--seccomp=/does-not-exist.bpf") + 0)))) + +(ert-deftest emacs-tests/seccomp/empty-file () + (skip-unless (string-match-p (rx bow "SECCOMP" eow) + system-configuration-features)) + (let ((emacs + (expand-file-name invocation-name invocation-directory)) + (process-environment nil)) + (skip-unless (file-executable-p emacs)) + (ert-with-temp-file filter + :prefix "seccomp-invalid-" :suffix ".bpf" + ;; The --seccomp option is processed early, without filename + ;; handlers. Therefore remote or quoted filenames wouldn't + ;; work. + (should-not (file-remote-p filter)) + (cl-callf file-name-unquote filter) + ;; According to the Seccomp man page, a filter must have at + ;; least one element, so Emacs should reject an empty file. + (should-not + (eql (call-process emacs nil nil nil + "--quick" "--batch" + (concat "--seccomp=" filter)) + 0))))) + +(ert-deftest emacs-tests/seccomp/file-too-large () + (skip-unless (string-match-p (rx bow "SECCOMP" eow) + system-configuration-features)) + (let ((emacs + (expand-file-name invocation-name invocation-directory)) + (process-environment nil) + ;; This value should be correct on all supported systems. + (ushort-max #xFFFF) + ;; Either 8 or 16, but 16 should be large enough in all cases. + (filter-size 16)) + (skip-unless (file-executable-p emacs)) + (ert-with-temp-file filter + :prefix "seccomp-too-large-" :suffix ".bpf" + :text (make-string (* (1+ ushort-max) filter-size) ?a) + ;; The --seccomp option is processed early, without filename + ;; handlers. Therefore remote or quoted filenames wouldn't + ;; work. + (should-not (file-remote-p filter)) + (cl-callf file-name-unquote filter) + ;; The filter count must fit into an `unsigned short'. A bigger + ;; file should be rejected. + (should-not + (eql (call-process emacs nil nil nil + "--quick" "--batch" + (concat "--seccomp=" filter)) + 0))))) + +(ert-deftest emacs-tests/seccomp/invalid-file-size () + (skip-unless (string-match-p (rx bow "SECCOMP" eow) + system-configuration-features)) + (let ((emacs + (expand-file-name invocation-name invocation-directory)) + (process-environment nil)) + (skip-unless (file-executable-p emacs)) + (ert-with-temp-file filter + :prefix "seccomp-invalid-" :suffix ".bpf" :text "123456" + ;; The --seccomp option is processed early, without filename + ;; handlers. Therefore remote or quoted filenames wouldn't + ;; work. + (should-not (file-remote-p filter)) + (cl-callf file-name-unquote filter) + ;; The Seccomp filter file must have a file size that's a + ;; multiple of the size of struct sock_filter, which is 8 or 16, + ;; but never 6. + (should-not + (eql (call-process emacs nil nil nil + "--quick" "--batch" + (concat "--seccomp=" filter)) + 0))))) + +(ert-deftest emacs-tests/seccomp/allows-stdout () + (skip-unless (string-match-p (rx bow "SECCOMP" eow) + system-configuration-features)) + (let ((emacs + (expand-file-name invocation-name invocation-directory)) + (filter (expand-file-name "seccomp-filter.bpf" + emacs-tests--lib-src)) + (process-environment nil)) + (skip-unless (file-executable-p emacs)) + (skip-unless (file-readable-p filter)) + ;; The --seccomp option is processed early, without filename + ;; handlers. Therefore remote or quoted filenames wouldn't work. + (should-not (file-remote-p filter)) + (cl-callf file-name-unquote filter) + (with-temp-buffer + (let ((start-time (current-time)) + (status (call-process + emacs nil t nil + "--quick" "--batch" + (concat "--seccomp=" filter) + (format "--eval=%S" '(message "Hi")))) + (end-time (current-time))) + (ert-info ((emacs-tests--seccomp-debug start-time end-time)) + (should (eql status 0))) + (should (equal (string-trim (buffer-string)) "Hi")))))) + +(ert-deftest emacs-tests/seccomp/forbids-subprocess () + (skip-unless (string-match-p (rx bow "SECCOMP" eow) + system-configuration-features)) + (let ((emacs + (expand-file-name invocation-name invocation-directory)) + (filter (expand-file-name "seccomp-filter.bpf" + emacs-tests--lib-src)) + (process-environment nil)) + (skip-unless (file-executable-p emacs)) + (skip-unless (file-readable-p filter)) + ;; The --seccomp option is processed early, without filename + ;; handlers. Therefore remote or quoted filenames wouldn't work. + (should-not (file-remote-p filter)) + (cl-callf file-name-unquote filter) + (with-temp-buffer + (let ((start-time (current-time)) + (status + (call-process + emacs nil t nil + "--quick" "--batch" + (concat "--seccomp=" filter) + (format "--eval=%S" `(call-process ,emacs nil nil nil + "--version")))) + (end-time (current-time))) + (ert-info ((emacs-tests--seccomp-debug start-time end-time)) + (should-not (eql status 0))))))) + +(ert-deftest emacs-tests/bwrap/allows-stdout () + (let ((bash (executable-find "bash")) + (bwrap (executable-find "bwrap")) + (emacs + (expand-file-name invocation-name invocation-directory)) + (filter (expand-file-name "seccomp-filter-exec.bpf" + emacs-tests--lib-src)) + (process-environment nil)) + (skip-unless bash) + (skip-unless bwrap) + (skip-unless (file-executable-p emacs)) + (skip-unless (file-readable-p filter)) + (should-not (file-remote-p bwrap)) + (should-not (file-remote-p emacs)) + (should-not (file-remote-p filter)) + (with-temp-buffer + (let* ((command + (concat + (mapconcat #'shell-quote-argument + `(,(file-name-unquote bwrap) + "--ro-bind" "/" "/" + "--seccomp" "20" + "--" + ,(file-name-unquote emacs) + "--quick" "--batch" + ,(format "--eval=%S" '(message "Hi"))) + " ") + " 20< " + (shell-quote-argument (file-name-unquote filter)))) + (start-time (current-time)) + (status (call-process bash nil t nil "-c" command)) + (end-time (current-time))) + (ert-info ((emacs-tests--seccomp-debug start-time end-time)) + (should (eql status 0))) + (should (equal (string-trim (buffer-string)) "Hi")))))) + +(defun emacs-tests--seccomp-debug (start-time end-time) + "Return potentially useful debugging information for Seccomp. +Assume that the current buffer contains subprocess output for the +failing process. START-TIME and END-TIME are time values between +which the process was running." + ;; Add a bit of slack for the timestamps. + (cl-callf time-subtract start-time 5) + (cl-callf time-add end-time 5) + (with-output-to-string + (princ "Process output:") + (terpri) + (princ (buffer-substring-no-properties (point-min) (point-max))) + ;; Search audit logs for Seccomp messages. + (when-let ((ausearch (executable-find "ausearch"))) + (terpri) + (princ "Potentially relevant Seccomp audit events:") + (terpri) + (let ((process-environment '("LC_TIME=C"))) + (call-process ausearch nil standard-output nil + "--message" "SECCOMP" + "--start" + (format-time-string "%D" start-time) + (format-time-string "%T" start-time) + "--end" + (format-time-string "%D" end-time) + (format-time-string "%T" end-time) + "--interpret"))) + ;; Print coredump information if available. + (when-let ((coredumpctl (executable-find "coredumpctl"))) + (terpri) + (princ "Potentially useful coredump information:") + (terpri) + (call-process coredumpctl nil standard-output nil + "info" + "--since" (format-time-string "%F %T" start-time) + "--until" (format-time-string "%F %T" end-time) + "--no-pager")))) + +;;; emacs-tests.el ends here diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el index 7ff60dd01c4..bb2f04e8ee1 100644 --- a/test/src/eval-tests.el +++ b/test/src/eval-tests.el @@ -1,6 +1,6 @@ ;;; eval-tests.el --- unit tests for src/eval.c -*- lexical-binding: t; -*- -;; Copyright (C) 2016-2017 Free Software Foundation, Inc. +;; Copyright (C) 2016-2022 Free Software Foundation, Inc. ;; Author: Philipp Stephani <phst@google.com> @@ -26,28 +26,53 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'cl-lib)) +(require 'subr-x) (ert-deftest eval-tests--bug24673 () - "Checks that Bug#24673 has been fixed." + "Check that Bug#24673 has been fixed." ;; This should not crash. (should-error (funcall '(closure)) :type 'invalid-function)) (defvar byte-compile-debug) (ert-deftest eval-tests--bugs-24912-and-24913 () - "Checks that Emacs doesn’t accept weird argument lists. + "Check that Emacs doesn't accept weird argument lists. Bug#24912 and Bug#24913." - (dolist (args '((&optional) (&rest) (&optional &rest) (&rest &optional) - (&optional &rest a) (&optional a &rest) - (&rest a &optional) (&rest &optional a) - (&optional &optional) (&optional &optional a) - (&optional a &optional b) - (&rest &rest) (&rest &rest a) - (&rest a &rest b))) - (should-error (eval `(funcall (lambda ,args)) t) :type 'invalid-function) - (should-error (byte-compile-check-lambda-list args)) - (let ((byte-compile-debug t)) - (should-error (eval `(byte-compile (lambda ,args)) t))))) + (dolist (lb '(t false)) + (ert-info ((prin1-to-string lb) :prefix "lexical-binding: ") + (let ((lexical-binding lb)) + (dolist (args '((&rest &optional) + (&rest a &optional) (&rest &optional a) + (&optional &optional) (&optional &optional a) + (&optional a &optional b) + (&rest &rest) (&rest &rest a) + (&rest a &rest b) + (&rest) (&optional &rest) + )) + (ert-info ((prin1-to-string args) :prefix "args: ") + (should-error + (eval `(funcall (lambda ,args)) lb) :type 'invalid-function) + (should-error (byte-compile-check-lambda-list args)) + (let ((byte-compile-debug t)) + (should-error (eval `(byte-compile (lambda ,args)) lb))))))))) + +(ert-deftest eval-tests-accept-empty-optional () + "Check that Emacs accepts empty &optional arglists. +Bug#24912." + (dolist (lb '(t false)) + (ert-info ((prin1-to-string lb) :prefix "lexical-binding: ") + (let ((lexical-binding lb)) + (dolist (args '((&optional) (&optional &rest a))) + (ert-info ((prin1-to-string args) :prefix "args: ") + (let ((fun `(lambda ,args 'ok))) + (ert-info ("eval") + (should (eq (funcall (eval fun lb)) 'ok))) + (ert-info ("byte comp check") + (byte-compile-check-lambda-list args)) + (ert-info ("bytecomp") + (let ((byte-compile-debug t)) + (should (eq (funcall (byte-compile fun)) 'ok))))))))))) (dolist (form '(let let*)) @@ -61,22 +86,165 @@ Bug#24912 and Bug#24913." (ert-deftest eval-tests--if-dot-string () "Check that Emacs rejects (if . \"string\")." - (should-error (eval '(if . "abc")) :type 'wrong-type-argument) + (should-error (eval '(if . "abc") nil) :type 'wrong-type-argument) + (should-error (eval '(if . "abc") t) :type 'wrong-type-argument) (let ((if-tail (list '(setcdr if-tail "abc") t))) - (should-error (eval (cons 'if if-tail)))) + (should-error (eval (cons 'if if-tail) nil) :type 'void-variable) + (should-error (eval (cons 'if if-tail) t) :type 'void-variable)) (let ((if-tail (list '(progn (setcdr if-tail "abc") nil) t))) - (should-error (eval (cons 'if if-tail))))) + (should-error (eval (cons 'if if-tail) nil) :type 'void-variable) + (should-error (eval (cons 'if if-tail) t) :type 'void-variable))) (ert-deftest eval-tests--let-with-circular-defs () "Check that Emacs reports an error for (let VARS ...) when VARS is circular." (let ((vars (list 'v))) (setcdr vars vars) (dolist (let-sym '(let let*)) - (should-error (eval (list let-sym vars)))))) + (should-error (eval (list let-sym vars) nil))))) (ert-deftest eval-tests--mutating-cond () "Check that Emacs doesn't crash on a cond clause that mutates during eval." (let ((clauses (list '((progn (setcdr clauses "ouch") nil))))) - (should-error (eval (cons 'cond clauses))))) + (should-error (eval (cons 'cond clauses) nil)) + (should-error (eval (cons 'cond clauses) t)))) + +(ert-deftest defvar/bug31072 () + "Check that Bug#31072 is fixed." + (should-error (eval '(defvar 1) t) :type 'wrong-type-argument)) + +(ert-deftest defvaralias-overwrite-warning () + "Test for Bug#5950." + (defvar eval-tests--foo) + (setq eval-tests--foo 2) + (defvar eval-tests--foo-alias) + (setq eval-tests--foo-alias 1) + (cl-letf (((symbol-function 'display-warning) + (lambda (type &rest _) + (throw 'got-warning type)))) + ;; Warn if we lose a value through aliasing. + (should (equal + '(defvaralias losing-value eval-tests--foo-alias) + (catch 'got-warning + (defvaralias 'eval-tests--foo-alias 'eval-tests--foo)))) + ;; Don't warn if we don't. + (makunbound 'eval-tests--foo-alias) + (should (eq 'no-warning + (catch 'got-warning + (defvaralias 'eval-tests--foo-alias 'eval-tests--foo) + 'no-warning))))) + +(ert-deftest eval-tests-byte-code-being-evaluated-is-protected-from-gc () + "Regression test for Bug#33014. +Check that byte-compiled objects being executed by exec-byte-code +are found on the stack and therefore not garbage collected." + (should (string= (eval-tests-33014-func) + "before after: ok foo: (e) bar: (a b c d e) baz: a bop: c"))) + +(defvar eval-tests-33014-var "ok") +(defun eval-tests-33014-func () + "A function which has a non-trivial constants vector when byte-compiled." + (let ((result "before ")) + (eval-tests-33014-redefine) + (garbage-collect) + (setq result (concat result (format "after: %s" eval-tests-33014-var))) + (let ((vals '(0 1 2 3)) + (things '(a b c d e))) + (dolist (val vals) + (setq result + (concat result " " + (cond + ((= val 0) (format "foo: %s" (last things))) + ((= val 1) (format "bar: %s" things)) + ((= val 2) (format "baz: %s" (car things))) + (t (format "bop: %s" (nth 2 things)))))))) + result)) + +(defun eval-tests-33014-redefine () + "Remove the Lisp reference to the byte-compiled object." + (setf (symbol-function #'eval-tests-33014-func) nil)) + +(ert-deftest eval-tests-19790-backquote-comma-dot-substitution () + "Regression test for Bug#19790. +Don't handle destructive splicing in backquote expressions (like +in Common Lisp). Instead, make sure substitution in backquote +expressions works for identifiers starting with period." + (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) nil)) 'ok)) + (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) t)) '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\")"))))) + +(ert-deftest eval-tests/funcall-with-delayed-message () + ;; Check that `funcall-with-delayed-message' displays its message before + ;; its function terminates iff the timeout is short enough. + + ;; This also serves as regression test for bug#55628 where a short + ;; timeout was rounded up to the next whole second. + (dolist (params '((0.8 0.4) + (0.1 0.8))) + (let ((timeout (nth 0 params)) + (work-time (nth 1 params))) + (ert-info ((prin1-to-string params) :prefix "params: ") + (with-current-buffer "*Messages*" + (let ((inhibit-read-only t)) + (erase-buffer)) + (let ((stop (+ (float-time) work-time))) + (funcall-with-delayed-message + timeout "timed out" + (lambda () + (while (< (float-time) stop)) + (message "finished")))) + (let ((expected-messages + (if (< timeout work-time) + "timed out\nfinished" + "finished"))) + (should (equal (string-trim (buffer-string)) + expected-messages)))))))) ;;; eval-tests.el ends here diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el index 01c280d2752..08582c8a862 100644 --- a/test/src/fileio-tests.el +++ b/test/src/fileio-tests.el @@ -1,6 +1,6 @@ -;;; unit tests for src/fileio.c -*- lexical-binding: t; -*- +;;; fileio-tests.el --- unit tests for src/fileio.c -*- lexical-binding: t; -*- -;; Copyright 2017 Free Software Foundation, Inc. +;; Copyright 2017-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -17,6 +17,8 @@ ;; 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) (defun try-link (target link) @@ -95,3 +97,124 @@ Also check that an encoding error can appear in a symlink." (should (equal (file-name-as-directory "d:/abc/") "d:/abc/")) (should (equal (file-name-as-directory "D:\\abc/") "d:/abc/")) (should (equal (file-name-as-directory "D:/abc//") "d:/abc//"))) + +(ert-deftest fileio-tests--relative-HOME () + "Test that `expand-file-name' works even when HOME is relative." + (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"))))) + +(ert-deftest fileio-tests--insert-file-interrupt () + (let ((text "-*- coding: binary -*-\n\xc3\xc3help") + f) + (unwind-protect + (progn + (setq f (make-temp-file "ftifi")) + (write-region text nil f nil 'silent) + (with-temp-buffer + (catch 'toto + (let ((set-auto-coding-function (lambda (&rest _) (throw 'toto nil)))) + (insert-file-contents f))) + (goto-char (point-min)) + (unless (eobp) + (forward-line 1) + (let ((c1 (char-after))) + (forward-char 1) + (should (equal c1 (char-before))) + (should (equal c1 (char-after))))))) + (if f (delete-file f))))) + +(ert-deftest fileio-tests--relative-default-directory () + "Test `expand-file-name' when `default-directory' is relative." + (let ((default-directory "some/relative/name")) + (should (file-name-absolute-p (expand-file-name "foo")))) + (let* ((default-directory "~foo") + (name (expand-file-name "bar"))) + (should (and (file-name-absolute-p name) + (not (eq (aref name 0) ?~)))))) + +(ert-deftest fileio-tests--expand-file-name-null-bytes () + "Test that `expand-file-name' checks for null bytes in filenames." + (should-error (expand-file-name (concat "file" (char-to-string ?\0) ".txt")) + :type 'wrong-type-argument) + (should-error (expand-file-name "file.txt" (concat "dir" (char-to-string ?\0))) + :type 'wrong-type-argument) + (let ((default-directory (concat "dir" (char-to-string ?\0)))) + (should-error (expand-file-name "file.txt") :type 'wrong-type-argument))) + +(ert-deftest fileio-tests--file-name-absolute-p () + "Test `file-name-absolute-p'." + (dolist (suffix '("" "/" "//" "/foo" "/foo/" "/foo//" "/foo/bar")) + (unless (string-equal suffix "") + (should (file-name-absolute-p suffix))) + (should (file-name-absolute-p (concat "~" suffix))) + (when (user-full-name user-login-name) + (should (file-name-absolute-p (concat "~" user-login-name suffix)))) + (unless (user-full-name "nosuchuser") + (should (not (file-name-absolute-p (concat "~nosuchuser" suffix))))))) + +(ert-deftest fileio-tests--circular-after-insert-file-functions () + "Test `after-insert-file-functions' as a circular list." + (let ((f (make-temp-file "fileio")) + (after-insert-file-functions (list 'identity))) + (setcdr after-insert-file-functions after-insert-file-functions) + (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)) + +(ert-deftest fileio-tests/file-name-concat () + (should (equal (file-name-concat "foo" "bar") "foo/bar")) + (should (equal (file-name-concat "foo" "bar") "foo/bar")) + (should (equal (file-name-concat "foo" "bar" "zot") "foo/bar/zot")) + (should (equal (file-name-concat "foo/" "bar") "foo/bar")) + (should (equal (file-name-concat "foo//" "bar") "foo//bar")) + (should (equal (file-name-concat "foo/" "bar/" "zot") "foo/bar/zot")) + (should (equal (file-name-concat "fóo" "bar") "fóo/bar")) + (should (equal (file-name-concat "foo" "bár") "foo/bár")) + (should (equal (file-name-concat "fóo" "bár") "fóo/bár")) + (let ((string (make-string 5 ?a))) + (should (not (multibyte-string-p string))) + (aset string 2 255) + (should (not (multibyte-string-p string))) + (should (equal (file-name-concat "fóo" string) "fóo/aa\377aa"))) + (should (equal (file-name-concat "foo") "foo")) + (should (equal (file-name-concat "foo/") "foo/")) + (should (equal (file-name-concat "foo" "") "foo")) + (should (equal (file-name-concat "foo" "" "" "" nil) "foo")) + (should (equal (file-name-concat "" "bar") "bar")) + (should (equal (file-name-concat "" "") ""))) + +(ert-deftest fileio-tests--non-regular-insert () + (skip-unless (file-exists-p "/dev/urandom")) + (with-temp-buffer + (set-buffer-multibyte nil) + (should-error (insert-file-contents "/dev/urandom" nil 5 10)) + (insert-file-contents "/dev/urandom" nil nil 10) + (should (= (buffer-size) 10)))) + +(defun fileio-tests--identity-expand-handler (_ file &rest _) + file) +(put 'fileio-tests--identity-expand-handler 'operations '(expand-file-name)) + +(ert-deftest fileio--file-name-case-insensitive-p () + ;; Check that we at least don't crash if given nonexisting files + ;; without a directory (bug#56443). + + ;; Use an identity file-name handler, as if called by `ffap'. + (let* ((file-name-handler-alist + '(("^mailto:" . fileio-tests--identity-expand-handler))) + (file "mailto:snowball@hell.com")) + ;; Check that `expand-file-name' is identity for this name. + (should (equal (expand-file-name file nil) file)) + (file-name-case-insensitive-p file))) + +;;; fileio-tests.el ends here diff --git a/test/src/filelock-tests.el b/test/src/filelock-tests.el new file mode 100644 index 00000000000..97642669a0d --- /dev/null +++ b/test/src/filelock-tests.el @@ -0,0 +1,217 @@ +;;; filelock-tests.el --- test file locking -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 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 this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file tests code in src/filelock.c and, to some extent, the +;; related code in src/fileio.c. +;; +;; See also (info "(emacs)Interlocking") and (info "(elisp)File Locks") + +;;; Code: + +(require 'cl-macs) +(require 'ert) +(require 'ert-x) +(require 'seq) + +(defmacro filelock-tests--fixture (&rest body) + "Call BODY under a test fixture. +Create a test directory and a buffer whose `buffer-file-name' and +`buffer-file-truename' are a file within it, then call BODY. +Finally, delete the buffer and the test directory." + (declare (debug (body))) + `(ert-with-temp-directory temp-dir + (let ((name (concat (file-name-as-directory temp-dir) + "userfile")) + (create-lockfiles t)) + (with-temp-buffer + (setq buffer-file-name name + buffer-file-truename name) + (unwind-protect + (save-current-buffer + ,@body) + ;; Set `buffer-file-truename' nil to prevent unlocking, + ;; which might prompt the user and/or signal errors. + (setq buffer-file-name nil + buffer-file-truename nil)))))) + +(defun filelock-tests--make-lock-name (file-name) + "Return the lock file name for FILE-NAME. +Equivalent logic in Emacs proper is implemented in C and +unavailable to Lisp." + (concat (file-name-directory (expand-file-name file-name)) + ".#" + (file-name-nondirectory file-name))) + +(defun filelock-tests--spoil-lock-file (file-name) + "Spoil the lock file for FILE-NAME. +Cause Emacs to report errors for various file locking operations +on FILE-NAME going forward. Create a file that is incompatible +with Emacs' file locking protocol, but uses the same name as +FILE-NAME's lock file. A directory file is used, which is +portable in practice." + (make-directory (filelock-tests--make-lock-name file-name))) + +(defun filelock-tests--unspoil-lock-file (file-name) + "Remove the lock file spoiler for FILE-NAME. +See `filelock-tests--spoil-lock-file'." + (delete-directory (filelock-tests--make-lock-name file-name) t)) + +(defun filelock-tests--should-be-locked () + "Abort the current test if the current buffer is not locked. +Exception: on systems without lock file support, aborts the +current test if the current file is locked (which should never +the case)." + (if (eq system-type 'ms-dos) + (should-not (file-locked-p buffer-file-truename)) + (should (file-locked-p buffer-file-truename)))) + +(ert-deftest filelock-tests-lock-unlock-no-errors () + "Check that locking and unlocking works without error." + (filelock-tests--fixture + (should-not (file-locked-p (buffer-file-name))) + + ;; Inserting text should lock the buffer's file. + (insert "this locks the buffer's file") + (filelock-tests--should-be-locked) + (unlock-buffer) + (set-buffer-modified-p nil) + (should-not (file-locked-p (buffer-file-name))) + + ;; `set-buffer-modified-p' should lock the buffer's file. + (set-buffer-modified-p t) + (filelock-tests--should-be-locked) + (unlock-buffer) + (should-not (file-locked-p (buffer-file-name))) + + (should-not (file-locked-p (buffer-file-name))))) + +(ert-deftest filelock-tests-lock-spoiled () + "Check `lock-buffer'." + (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support + (filelock-tests--fixture + (filelock-tests--spoil-lock-file buffer-file-truename) + ;; FIXME: errors when locking a file are ignored; should they be? + (set-buffer-modified-p t) + (filelock-tests--unspoil-lock-file buffer-file-truename) + (should-not (file-locked-p buffer-file-truename)))) + +(ert-deftest filelock-tests-file-locked-p-spoiled () + "Check that `file-locked-p' fails if the lockfile is \"spoiled\"." + (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support + (filelock-tests--fixture + (filelock-tests--spoil-lock-file buffer-file-truename) + (let ((err (should-error (file-locked-p (buffer-file-name))))) + (should (equal (seq-subseq err 0 2) + (if (eq system-type 'windows-nt) + '(permission-denied "Testing file lock") + '(file-error "Testing file lock"))))))) + +(ert-deftest filelock-tests-unlock-spoiled () + "Check that `unlock-buffer' fails if the lockfile is \"spoiled\"." + (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support + (filelock-tests--fixture + ;; Set the buffer modified with file locking temporarily disabled. + (let ((create-lockfiles nil)) + (set-buffer-modified-p t)) + (should-not (file-locked-p buffer-file-truename)) + (filelock-tests--spoil-lock-file buffer-file-truename) + + ;; Errors from `unlock-buffer' should call + ;; `userlock--handle-unlock-error' (bug#46397). + (cl-letf (((symbol-function 'userlock--handle-unlock-error) + (lambda (err) (signal (car err) (cdr err))))) + (should (equal + (if (eq system-type 'windows-nt) + '(permission-denied "Unlocking file") + '(file-error "Unlocking file")) + (seq-subseq (should-error (unlock-buffer)) 0 2)))))) + +(ert-deftest filelock-tests-kill-buffer-spoiled () + "Check that `kill-buffer' fails if a lockfile is \"spoiled\"." + (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support + (filelock-tests--fixture + ;; Set the buffer modified with file locking temporarily disabled. + (let ((create-lockfiles nil)) + (set-buffer-modified-p t)) + (should-not (file-locked-p buffer-file-truename)) + (filelock-tests--spoil-lock-file buffer-file-truename) + + ;; Kill the current buffer. Because the buffer is modified Emacs + ;; will attempt to unlock it. Temporarily bind `yes-or-no-p' to a + ;; function that fakes a "yes" answer for the "Buffer modified; + ;; kill anyway?" prompt. + ;; + ;; File errors from unlocking files should call + ;; `userlock--handle-unlock-error' (bug#46397). + (cl-letf (((symbol-function 'yes-or-no-p) #'always) + ((symbol-function 'userlock--handle-unlock-error) + (lambda (err) (signal (car err) (cdr err))))) + (should (equal + (if (eq system-type 'windows-nt) + '(permission-denied "Unlocking file") + '(file-error "Unlocking file")) + (seq-subseq (should-error (kill-buffer)) 0 2)))))) + +(ert-deftest filelock-tests-detect-external-change () + "Check that an external file modification is reported." + (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support + (skip-unless (executable-find "touch")) + (skip-unless (executable-find "echo")) + (dolist (cl '(t nil)) + (filelock-tests--fixture + (let ((create-lockfiles cl)) + (write-region "foo" nil (buffer-file-name)) + (revert-buffer nil 'noconfirm) + (should-not (file-locked-p (buffer-file-name))) + + ;; Just changing the file modification on disk doesn't hurt, + ;; because file contents in buffer and on disk look equal. + (shell-command (format "touch %s" (buffer-file-name))) + (insert "bar") + (when cl (filelock-tests--should-be-locked)) + + ;; Bug#53207: with `create-lockfiles' nil, saving the buffer + ;; results in a prompt. + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (_) (ert-fail "Test failed unexpectedly")))) + (save-buffer)) + (should-not (file-locked-p (buffer-file-name))) + + ;; Changing the file contents on disk hurts when buffer is + ;; modified. There shall be a query, which we answer. + ;; *Messages* buffer is checked for prompt. + (shell-command (format "echo bar >>%s" (buffer-file-name))) + (cl-letf (((symbol-function 'read-char-choice) + (lambda (prompt &rest _) (message "%s" prompt) ?y))) + (ert-with-message-capture captured-messages + ;; `ask-user-about-supersession-threat' does not work in + ;; batch mode, let's simulate interactiveness. + (let (noninteractive) + (insert "baz")) + (should (string-match-p + (format + "^%s changed on disk; really edit the buffer\\?" + (file-name-nondirectory (buffer-file-name))) + captured-messages)))) + (when cl (filelock-tests--should-be-locked)))))) + +(provide 'filelock-tests) +;;; filelock-tests.el ends here diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el index aa4e55e4897..aa709e3c2f5 100644 --- a/test/src/floatfns-tests.el +++ b/test/src/floatfns-tests.el @@ -1,6 +1,6 @@ -;;; floatfns-tests.el --- tests for floating point operations +;;; floatfns-tests.el --- tests for floating point operations -*- lexical-binding: t -*- -;; Copyright 2017 Free Software Foundation, Inc. +;; Copyright 2017-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -17,13 +17,77 @@ ;; 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) +(ert-deftest floatfns-tests-cos () + (should (= (cos 0) 1.0)) + (should (= (cos float-pi) -1.0))) + +(ert-deftest floatfns-tests-sin () + (should (= (sin 0) 0.0))) + +(ert-deftest floatfns-tests-tan () + (should (= (tan 0) 0.0))) + +(ert-deftest floatfns-tests-isnan () + (should (isnan 0.0e+NaN)) + (should (isnan -0.0e+NaN)) + (should-error (isnan "foo") :type 'wrong-type-argument)) + +(ert-deftest floatfns-tests-exp () + (should (= (exp 0) 1.0))) + +(ert-deftest floatfns-tests-expt () + (should (= (expt 2 8) 256))) + +(ert-deftest floatfns-tests-log () + (should (= (log 1000 10) 3.0))) + +(ert-deftest floatfns-tests-sqrt () + (should (= (sqrt 25) 5))) + +(ert-deftest floatfns-tests-abs () + (should (= (abs 10) 10)) + (should (= (abs -10) 10))) + +(ert-deftest floatfns-tests-logb () + (should (= (logb 10000) 13))) + +(ert-deftest floatfns-tests-ceiling () + (should (= (ceiling 0.5) 1))) + +(ert-deftest floatfns-tests-floor () + (should (= (floor 1.5) 1))) + +(ert-deftest floatfns-tests-round () + (should (= (round 1.49999999999) 1)) + (should (= (round 1.50000000000) 2)) + (should (= (round 1.50000000001) 2))) + +(ert-deftest floatfns-tests-truncate () + (should (= (truncate float-pi) 3))) + +(ert-deftest floatfns-tests-fceiling () + (should (= (fceiling 0.5) 1.0))) + +(ert-deftest floatfns-tests-ffloor () + (should (= (ffloor 1.5) 1.0))) + +(ert-deftest floatfns-tests-fround () + (should (= (fround 1.49999999999) 1.0)) + (should (= (fround 1.50000000000) 2.0)) + (should (= (fround 1.50000000001) 2.0))) + +(ert-deftest floatfns-tests-ftruncate () + (should (= (ftruncate float-pi) 3.0))) + (ert-deftest divide-extreme-sign () - (should-error (ceiling most-negative-fixnum -1.0)) - (should-error (floor most-negative-fixnum -1.0)) - (should-error (round most-negative-fixnum -1.0)) - (should-error (truncate most-negative-fixnum -1.0))) + (should (= (ceiling most-negative-fixnum -1.0) (- most-negative-fixnum))) + (should (= (floor most-negative-fixnum -1.0) (- most-negative-fixnum))) + (should (= (round most-negative-fixnum -1.0) (- most-negative-fixnum))) + (should (= (truncate most-negative-fixnum -1.0) (- most-negative-fixnum)))) (ert-deftest logb-extreme-fixnum () (should (= (logb most-negative-fixnum) (1+ (logb most-positive-fixnum))))) @@ -34,4 +98,96 @@ (should-error (ftruncate 0) :type 'wrong-type-argument) (should-error (fround 0) :type 'wrong-type-argument)) +(ert-deftest bignum-to-float () + ;; 122 because we want to go as big as possible to provoke a rounding error, + ;; but not too big: 2**122 < 10**37 < 2**123, and the C standard says + ;; 10**37 <= DBL_MAX so 2**122 cannot overflow as a double. + (let ((a (1- (ash 1 122)))) + (should (or (eql a (1- (floor (float a)))) + (eql a (floor (float a)))))) + (should (eql (float (+ most-positive-fixnum 1)) + (+ (float most-positive-fixnum) 1)))) + +(ert-deftest bignum-abs () + (should (= most-positive-fixnum + (- (abs most-negative-fixnum) 1)))) + +(ert-deftest bignum-expt () + (dolist (n (list most-positive-fixnum (1+ most-positive-fixnum) + most-negative-fixnum (1- most-negative-fixnum) + (* 5 most-negative-fixnum) + (* 5 (1+ most-positive-fixnum)) + -2 -1 0 1 2)) + (should (or (<= n 0) (= (expt 0 n) 0))) + (should (= (expt 1 n) 1)) + (should (or (< n 0) (= (expt -1 n) (if (zerop (logand n 1)) 1 -1)))) + (should (= (expt n 0) 1)) + (should (= (expt n 1) n)) + (should (= (expt n 2) (* n n))) + (should (= (expt n 3) (* n n n))))) + +(ert-deftest bignum-logb () + (should (= (+ (logb most-positive-fixnum) 1) + (logb (+ most-positive-fixnum 1))))) + +(ert-deftest bignum-mod () + (should (= 0 (mod (1+ most-positive-fixnum) 2.0)))) + +(ert-deftest bignum-round () + (let ((ns (list (* most-positive-fixnum most-negative-fixnum) + (1- most-negative-fixnum) most-negative-fixnum + (1+ most-negative-fixnum) -2 1 1 2 + (1- most-positive-fixnum) most-positive-fixnum + (1+ most-positive-fixnum) + (* most-positive-fixnum most-positive-fixnum)))) + (dolist (n ns) + (should (= n (ceiling n))) + (should (= n (floor n))) + (should (= n (round n))) + (should (= n (truncate n))) + (let ((-n (- n)) + (f (float n)) + (-f (- (float n)))) + (should (= 1 (round n f) (round -n -f) (round f n) (round -f -n))) + (should (= -1 (round -n f) (round n -f) (round f -n) (round -f n)))) + (dolist (d ns) + (let ((q (/ n d)) + (r (% n d)) + (same-sign (eq (< n 0) (< d 0)))) + (should (= (ceiling n d) + (+ q (if (and same-sign (not (zerop r))) 1 0)))) + (should (= (floor n d) + (- q (if (and (not same-sign) (not (zerop r))) 1 0)))) + (should (= (truncate n d) q)) + (let ((cdelta (abs (- n (* d (ceiling n d))))) + (fdelta (abs (- n (* d (floor n d))))) + (rdelta (abs (- n (* d (round n d)))))) + (should (<= rdelta cdelta)) + (should (<= rdelta fdelta)) + (should (if (zerop r) + (= 0 cdelta fdelta rdelta) + (or (/= cdelta fdelta) + (zerop (% (round n d) 2))))))))))) + +(ert-deftest special-round () + (dolist (f '(ceiling floor round truncate)) + (let ((ns '(-1e+INF 1e+INF -1 -0.0 0.0 0 1 -1e+NaN 1e+NaN))) + (dolist (n ns) + (if (not (<= (abs n) 1)) + (should-error (funcall f n)) + (should (= n (funcall f n))) + (dolist (d '(-1e+INF 1e+INF)) + (should (eq 0 (funcall f n d))))) + (dolist (d ns) + (when (or (zerop d) (= (abs n) 1e+INF) (not (= n n)) (not (= d d))) + (should-error (funcall f n d)))))))) + +(ert-deftest big-round () + (should (= (floor 54043195528445955 3) + (floor 54043195528445955 3.0))) + (should (= (floor 1.7976931348623157e+308 5e-324) + (ash (1- (ash 1 53)) 2045)))) + (provide 'floatfns-tests) + +;;; floatfns-tests.el ends here diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index d751acb7478..fe8df7097a7 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -1,21 +1,21 @@ -;;; fns-tests.el --- tests for src/fns.c +;;; fns-tests.el --- tests for src/fns.c -*- lexical-binding:t -*- -;; Copyright (C) 2014-2017 Free Software Foundation, Inc. +;; Copyright (C) 2014-2022 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. -;; +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -23,6 +23,67 @@ (require 'cl-lib) +(ert-deftest fns-tests-identity () + (let ((num 12345)) (should (eq (identity num) num))) + (let ((str "foo")) (should (eq (identity str) str))) + (let ((lst '(11))) (should (eq (identity lst) lst)))) + +(ert-deftest fns-tests-random () + (should (integerp (random))) + (should (>= (random 10) 0)) + (should (< (random 10) 10))) + +(ert-deftest fns-tests-length () + (should (= (length nil) 0)) + (should (= (length '(1 2 3)) 3)) + (should (= (length '[1 2 3]) 3)) + (should (= (length "foo") 3)) + (should-error (length t))) + +(ert-deftest fns-tests-safe-length () + (should (= (safe-length '(1 2 3)) 3))) + +(ert-deftest fns-tests-string-bytes () + (should (= (string-bytes "abc") 3))) + +;; Test that equality predicates work correctly on NaNs when combined +;; with hash tables based on those predicates. This was not the case +;; for eql in Emacs 26. +(ert-deftest fns-tests-equality-nan () + (dolist (test (list #'eq #'eql #'equal)) + (let* ((h (make-hash-table :test test)) + (nan 0.0e+NaN) + (-nan (- nan))) + (puthash nan t h) + (should (eq (funcall test nan -nan) (gethash -nan h)))))) + +(ert-deftest fns-tests-equal-including-properties () + (should (equal-including-properties "" "")) + (should (equal-including-properties "foo" "foo")) + (should (equal-including-properties #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should (equal-including-properties #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should (equal-including-properties #("a" 0 1 (k v)) + #("a" 0 1 (k v)))) + (should-not (equal-including-properties #("a" 0 1 (k v)) + #("a" 0 1 (k x)))) + (should-not (equal-including-properties #("a" 0 1 (k v)) + #("b" 0 1 (k v)))) + (should-not (equal-including-properties #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd)))) + +(ert-deftest fns-tests-equal-including-properties/string-prop-vals () + "Handle string property values. (Bug#6581)" + (should (equal-including-properties #("a" 0 1 (k "v")) + #("a" 0 1 (k "v")))) + (should (equal-including-properties #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + (should-not (equal-including-properties #("a" 0 1 (k "v")) + #("a" 0 1 (k "x")))) + (should-not (equal-including-properties #("a" 0 1 (k "v")) + #("b" 0 1 (k "v"))))) + (ert-deftest fns-tests-reverse () (should-error (reverse)) (should-error (reverse 1)) @@ -38,21 +99,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)))) @@ -69,6 +130,49 @@ (should (equal [nil nil nil nil nil t t t t t] (vconcat A))) (should (equal [t t t t t nil nil nil nil nil] (vconcat (nreverse A)))))) +(defconst fns-tests--string-lessp-cases + '((a 97 error) + (97 "a" error) + ("abc" "abd" t) + ("abd" "abc" nil) + (abc "abd" t) + ("abd" abc nil) + (abc abd t) + (abd abc nil) + ("" "" nil) + ("" " " t) + (" " "" nil) + ("abc" "abcd" t) + ("abcd" "abc" nil) + ("abc" "abc" nil) + (abc abc nil) + ("\0" "" nil) + ("" "\0" t) + ("~" "\x80" t) + ("\x80" "\x80" nil) + ("\xfe" "\xff" t) + ("Munchen" "München" t) + ("München" "Munchen" nil) + ("München" "München" nil) + ("Ré" "Réunion" t))) + + +(ert-deftest fns-tests-string-lessp () + ;; Exercise both `string-lessp' and its alias `string<', both directly + ;; and in a function (exercising its bytecode). + (dolist (lessp (list #'string-lessp #'string< + (lambda (a b) (string-lessp a b)) + (lambda (a b) (string< a b)))) + (ert-info ((prin1-to-string lessp) :prefix "function: ") + (dolist (case fns-tests--string-lessp-cases) + (ert-info ((prin1-to-string case) :prefix "case: ") + (pcase case + (`(,x ,y error) + (should-error (funcall lessp x y))) + (`(,x ,y ,expected) + (should (equal (funcall lessp x y) expected))))))))) + + (ert-deftest fns-tests-compare-strings () (should-error (compare-strings)) (should-error (compare-strings "xyzzy" "xyzzy")) @@ -119,10 +223,9 @@ ;; In POSIX or C locales, collation order is lexicographic. (should (string-collate-lessp "XYZZY" "xyzzy" "POSIX")) - ;; In a language specific locale, collation order is different. - (should (string-collate-lessp - "xyzzy" "XYZZY" - (if (eq system-type 'windows-nt) "enu_USA" "en_US.UTF-8"))) + ;; In a language specific locale on MS-Windows, collation order is different. + (when (eq system-type 'windows-nt) + (should (string-collate-lessp "xyzzy" "XYZZY" "enu_USA"))) ;; Ignore case. (should (string-collate-equalp "xyzzy" "XYZZY" nil t)) @@ -136,14 +239,84 @@ ;; 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])) + ;; Sort a reversed list and vector. + (should (equal + (sort (reverse (number-sequence 1 1000)) (lambda (x y) (< x y))) + (number-sequence 1 1000))) + (should (equal + (sort (reverse (vconcat (number-sequence 1 1000))) + (lambda (x y) (< x y))) + (vconcat (number-sequence 1 1000)))) + ;; Sort a constant list and vector. + (should (equal + (sort (make-vector 100 1) (lambda (x y) (> x y))) + (make-vector 100 1))) + (should (equal + (sort (append (make-vector 100 1) nil) (lambda (x y) (> x y))) + (append (make-vector 100 1) nil))) + ;; Sort a long list and vector with every pair reversed. + (let ((vec (make-vector 100000 nil)) + (logxor-vec (make-vector 100000 nil))) + (dotimes (i 100000) + (aset logxor-vec i (logxor i 1)) + (aset vec i i)) + (should (equal + (sort logxor-vec (lambda (x y) (< x y))) + vec)) + (should (equal + (sort (append logxor-vec nil) (lambda (x y) (< x y))) + (append vec nil)))) + ;; Sort a list and vector with seven swaps. + (let ((vec (make-vector 100 nil)) + (swap-vec (make-vector 100 nil))) + (dotimes (i 100) + (aset vec i (- i 50)) + (aset swap-vec i (- i 50))) + (mapc (lambda (p) + (let ((tmp (elt swap-vec (car p)))) + (aset swap-vec (car p) (elt swap-vec (cdr p))) + (aset swap-vec (cdr p) tmp))) + '((48 . 94) (75 . 77) (33 . 41) (92 . 52) + (10 . 96) (1 . 14) (43 . 81))) + (should (equal + (sort (copy-sequence swap-vec) (lambda (x y) (< x y))) + vec)) + (should (equal + (sort (append swap-vec nil) (lambda (x y) (< x y))) + (append vec nil)))) + ;; Check for possible corruption after GC. + (let* ((size 3000) + (complex-vec (make-vector size nil)) + (vec (make-vector size nil)) + (counter 0) + (my-counter (lambda () + (if (< counter 500) + (cl-incf counter) + (setq counter 0) + (garbage-collect)))) + (rand 1) + (generate-random + (lambda () (setq rand + (logand (+ (* rand 1103515245) 12345) 2147483647))))) + ;; Make a complex vector and its sorted version. + (dotimes (i size) + (let ((r (funcall generate-random))) + (aset complex-vec i (cons r "a")) + (aset vec i (cons r "a")))) + ;; Sort it. + (should (equal + (sort complex-vec + (lambda (x y) (funcall my-counter) (< (car x) (car y)))) + (sort vec 'car-less-than-car)))) + ;; Check for sorting stability. (should (equal (sort (vector @@ -151,45 +324,51 @@ '(9 . "ppp") '(8 . "ttt") '(8 . "eee") '(9 . "fff")) (lambda (x y) (< (car x) (car y)))) [(8 . "xxx") (8 . "bbb") (8 . "ttt") (8 . "eee") - (9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")]))) + (9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")])) + ;; Bug#34104 + (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 () - ;; See https://lists.gnu.org/archive/html/emacs-devel/2015-10/msg02505.html. - :expected-result (if (eq system-type 'cygwin) :failed :passed) (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 - ;; for collation in other locales. - (should - (equal - (sort '("11" "12" "1 1" "1 2" "1.1" "1.2") - (lambda (a b) - (let ((w32-collate-ignore-punctuation t)) - (string-collate-lessp - a b (if (eq system-type 'windows-nt) "enu_USA" "en_US.UTF-8"))))) - '("11" "1 1" "1.1" "12" "1 2" "1.2"))) + ;; for collation in other locales, on MS-Windows systems. + (when (eq system-type 'windows-nt) + (should + (equal + (sort (list "11" "12" "1 1" "1 2" "1.1" "1.2") + (lambda (a b) + (let ((w32-collate-ignore-punctuation t)) + (string-collate-lessp + a b "enu_USA")))) + '("11" "1 1" "1.1" "12" "1 2" "1.2")))) ;; 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. - (should - (equal - (sort '("Ævar" "Agustín" "Adrian" "Eli") - (lambda (a b) - (let ((w32-collate-ignore-punctuation t)) - (string-collate-lessp - a b (if (eq system-type 'windows-nt) "enu_USA" "en_US.UTF-8"))))) - '("Adrian" "Ævar" "Agustín" "Eli")))) + ;; Diacritics are sorted between similar letters for other locales, + ;; on MS-Windows systems. + (when (eq system-type 'windows-nt) + (should + (equal + (sort (list "Ævar" "Agustín" "Adrian" "Eli") + (lambda (a b) + (let ((w32-collate-ignore-punctuation t)) + (string-collate-lessp + a b "enu_USA")))) + '("Adrian" "Ævar" "Agustín" "Eli"))))) (ert-deftest fns-tests-string-version-lessp () (should (string-version-lessp "foo2.png" "foo12.png")) @@ -198,7 +377,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")) @@ -214,11 +393,200 @@ (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) + (apply 'concat (make-list o s))) + +(defmacro fns-tests--with-region (funcname string &rest args) + "Apply FUNCNAME in a temp buffer on the region produced by STRING." + (declare (indent 1)) + `(with-temp-buffer + (insert ,string) + (,funcname (point-min) (point-max) ,@args) + (buffer-string))) + +(ert-deftest fns-tests-base64-encode-region () + ;; standard variant RFC2045 + (should (equal (fns-tests--with-region base64-encode-region "") "")) + (should (equal (fns-tests--with-region base64-encode-region "f") "Zg==")) + (should (equal (fns-tests--with-region base64-encode-region "fo") "Zm8=")) + (should (equal (fns-tests--with-region base64-encode-region "foo") "Zm9v")) + (should (equal (fns-tests--with-region base64-encode-region "foob") "Zm9vYg==")) + (should (equal (fns-tests--with-region base64-encode-region "fooba") "Zm9vYmE=")) + (should (equal (fns-tests--with-region base64-encode-region "foobar") "Zm9vYmFy")) + (should (equal (fns-tests--with-region base64-encode-region "\x14\xfb\x9c\x03\xd9\x7e") "FPucA9l+")) + (should (equal (fns-tests--with-region base64-encode-region "\x14\xfb\x9c\x03\xd9\x7f") "FPucA9l/"))) + +(ert-deftest fns-tests-base64-encode-string () + ;; standard variant RFC2045 + (should (equal (base64-encode-string "") "")) + (should (equal (base64-encode-string "f") "Zg==")) + (should (equal (base64-encode-string "fo") "Zm8=")) + (should (equal (base64-encode-string "foo") "Zm9v")) + (should (equal (base64-encode-string "foob") "Zm9vYg==")) + (should (equal (base64-encode-string "fooba") "Zm9vYmE=")) + (should (equal (base64-encode-string "foobar") "Zm9vYmFy")) + (should (equal (base64-encode-string "\x14\xfb\x9c\x03\xd9\x7e") "FPucA9l+")) + (should (equal (base64-encode-string "\x14\xfb\x9c\x03\xd9\x7f") "FPucA9l/")) + + (should-error (base64-encode-string "ƒ")) + (should-error (base64-encode-string "ü"))) + +(ert-deftest fns-test-base64url-encode-region () + ;; url variant with padding + (should (equal (fns-tests--with-region base64url-encode-region "") "")) + (should (equal (fns-tests--with-region base64url-encode-region "f") "Zg==")) + (should (equal (fns-tests--with-region base64url-encode-region "fo") "Zm8=")) + (should (equal (fns-tests--with-region base64url-encode-region "foo") "Zm9v")) + (should (equal (fns-tests--with-region base64url-encode-region "foob") "Zm9vYg==")) + (should (equal (fns-tests--with-region base64url-encode-region "fooba") "Zm9vYmE=")) + (should (equal (fns-tests--with-region base64url-encode-region "foobar") "Zm9vYmFy")) + (should (equal (fns-tests--with-region base64url-encode-region "\x14\xfb\x9c\x03\xd9\x7e") "FPucA9l-")) + (should (equal (fns-tests--with-region base64url-encode-region "\x14\xfb\x9c\x03\xd9\x7f") "FPucA9l_")) + + ;; url variant no padding + (should (equal (fns-tests--with-region base64url-encode-region "" t) "")) + (should (equal (fns-tests--with-region base64url-encode-region "f" t) "Zg")) + (should (equal (fns-tests--with-region base64url-encode-region "fo" t) "Zm8")) + (should (equal (fns-tests--with-region base64url-encode-region "foo" t) "Zm9v")) + (should (equal (fns-tests--with-region base64url-encode-region "foob" t) "Zm9vYg")) + (should (equal (fns-tests--with-region base64url-encode-region "fooba" t) "Zm9vYmE")) + (should (equal (fns-tests--with-region base64url-encode-region "foobar" t) "Zm9vYmFy")) + (should (equal (fns-tests--with-region base64url-encode-region "\x14\xfb\x9c\x03\xd9\x7e" t) "FPucA9l-")) + (should (equal (fns-tests--with-region base64url-encode-region "\x14\xfb\x9c\x03\xd9\x7f" t) "FPucA9l_")) + + + ;; url variant no line break no padding + (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "f" 100) t) + (concat (fns-tests--string-repeat "Zm" 66) "Zg"))) + (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "fo" 50) t) + (concat (fns-tests--string-repeat "Zm9mb2Zv" 16) "Zm9mbw"))) + (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "foo" 25) t) + (fns-tests--string-repeat "Zm9v" 25))) + (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "foob" 15) t) + (fns-tests--string-repeat "Zm9vYmZvb2Jmb29i" 5))) + (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "fooba" 15) t) + (fns-tests--string-repeat "Zm9vYmFmb29iYWZvb2Jh" 5))) + (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "foobar" 15) t) + (concat (fns-tests--string-repeat "Zm9vYmFyZm9vYmFy" 7) "Zm9vYmFy"))) + (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7e" 10) t) + (fns-tests--string-repeat "FPucA9l-" 10))) + (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7f" 10) t) + (fns-tests--string-repeat "FPucA9l_" 10))) + + (should-error (fns-tests--with-region base64url-encode-region "ƒ")) + (should-error (fns-tests--with-region base64url-encode-region "ü"))) + + +(ert-deftest fns-test-base64url-encode-string () + ;; url variant with padding + (should (equal (base64url-encode-string "") "")) + (should (equal (base64url-encode-string "f") "Zg==")) + (should (equal (base64url-encode-string "fo") "Zm8=")) + (should (equal (base64url-encode-string "foo") "Zm9v")) + (should (equal (base64url-encode-string "foob") "Zm9vYg==")) + (should (equal (base64url-encode-string "fooba") "Zm9vYmE=")) + (should (equal (base64url-encode-string "foobar") "Zm9vYmFy")) + (should (equal (base64url-encode-string "\x14\xfb\x9c\x03\xd9\x7e") "FPucA9l-")) + (should (equal (base64url-encode-string "\x14\xfb\x9c\x03\xd9\x7f") "FPucA9l_")) + + ;; url variant no padding + (should (equal (base64url-encode-string "" t) "")) + (should (equal (base64url-encode-string "f" t) "Zg")) + (should (equal (base64url-encode-string "fo" t) "Zm8")) + (should (equal (base64url-encode-string "foo" t) "Zm9v")) + (should (equal (base64url-encode-string "foob" t) "Zm9vYg")) + (should (equal (base64url-encode-string "fooba" t) "Zm9vYmE")) + (should (equal (base64url-encode-string "foobar" t) "Zm9vYmFy")) + (should (equal (base64url-encode-string "\x14\xfb\x9c\x03\xd9\x7e" t) "FPucA9l-")) + (should (equal (base64url-encode-string "\x14\xfb\x9c\x03\xd9\x7f" t) "FPucA9l_")) + + + ;; url variant no line break no padding + (should (equal (base64url-encode-string (fns-tests--string-repeat "f" 100) t) (concat (fns-tests--string-repeat "Zm" 66) "Zg"))) + (should (equal (base64url-encode-string (fns-tests--string-repeat "fo" 50) t) (concat (fns-tests--string-repeat "Zm9mb2Zv" 16) "Zm9mbw"))) + (should (equal (base64url-encode-string (fns-tests--string-repeat "foo" 25) t) (fns-tests--string-repeat "Zm9v" 25))) + (should (equal (base64url-encode-string (fns-tests--string-repeat "foob" 15) t) (fns-tests--string-repeat "Zm9vYmZvb2Jmb29i" 5))) + (should (equal (base64url-encode-string (fns-tests--string-repeat "fooba" 15) t) (fns-tests--string-repeat "Zm9vYmFmb29iYWZvb2Jh" 5))) + (should (equal (base64url-encode-string (fns-tests--string-repeat "foobar" 15) t) (concat (fns-tests--string-repeat "Zm9vYmFyZm9vYmFy" 7) "Zm9vYmFy"))) + (should (equal (base64url-encode-string (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7e" 10) t) (fns-tests--string-repeat "FPucA9l-" 10))) + (should (equal (base64url-encode-string (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7f" 10) t) (fns-tests--string-repeat "FPucA9l_" 10))) + + (should-error (base64url-encode-string "ƒ")) + (should-error (base64url-encode-string "ü"))) + +(ert-deftest fns-tests-base64-decode-string () + ;; standard variant RFC2045 + (should (equal (base64-decode-string "") "")) + (should (equal (base64-decode-string "Zg==") "f")) + (should (equal (base64-decode-string "Zm8=") "fo")) + (should (equal (base64-decode-string "Zm9v") "foo")) + (should (equal (base64-decode-string "Zm9vYg==") "foob")) + (should (equal (base64-decode-string "Zm9vYmE=") "fooba")) + (should (equal (base64-decode-string "Zm9vYmFy") "foobar")) + (should (equal (base64-decode-string "FPucA9l+") "\x14\xfb\x9c\x03\xd9\x7e")) + (should (equal (base64-decode-string "FPucA9l/") "\x14\xfb\x9c\x03\xd9\x7f")) + + ;; no padding + (should (equal (base64-decode-string "" t) "")) + (should (equal (base64-decode-string "Zg" t) "f")) + (should (equal (base64-decode-string "Zm8" t) "fo")) + (should (equal (base64-decode-string "Zm9v" t) "foo")) + (should (equal (base64-decode-string "Zm9vYg" t) "foob")) + (should (equal (base64-decode-string "Zm9vYmE" t) "fooba")) + (should (equal (base64-decode-string "Zm9vYmFy" t) "foobar")) + + ;; url variant with padding + (should (equal (base64-decode-string "") "")) + (should (equal (base64-decode-string "Zg==" t) "f") ) + (should (equal (base64-decode-string "Zm8=" t) "fo")) + (should (equal (base64-decode-string "Zm9v" t) "foo")) + (should (equal (base64-decode-string "Zm9vYg==" t) "foob")) + (should (equal (base64-decode-string "Zm9vYmE=" t) "fooba")) + (should (equal (base64-decode-string "Zm9vYmFy" t) "foobar")) + (should (equal (base64-decode-string "FPucA9l-" t) "\x14\xfb\x9c\x03\xd9\x7e")) + (should (equal (base64-decode-string "FPucA9l_" t) "\x14\xfb\x9c\x03\xd9\x7f")) + + ;; url variant no padding + (should (equal (base64-decode-string "") "")) + (should (equal (base64-decode-string "Zg" t) "f")) + (should (equal (base64-decode-string "Zm8" t) "fo")) + (should (equal (base64-decode-string "Zm9v" t) "foo")) + (should (equal (base64-decode-string "Zm9vYg" t) "foob")) + (should (equal (base64-decode-string "Zm9vYmE" t) "fooba")) + (should (equal (base64-decode-string "Zm9vYmFy" t) "foobar")) + (should (equal (base64-decode-string "FPucA9l-" t) "\x14\xfb\x9c\x03\xd9\x7e")) + (should (equal (base64-decode-string "FPucA9l_" t) "\x14\xfb\x9c\x03\xd9\x7f")) + + + ;; url variant no line break no padding + (should (equal (base64-decode-string (concat (fns-tests--string-repeat "Zm" 66) "Zg") t) + (fns-tests--string-repeat "f" 100))) + (should (equal (base64-decode-string (concat (fns-tests--string-repeat "Zm9mb2Zv" 16) "Zm9mbw") t) + (fns-tests--string-repeat "fo" 50))) + (should (equal (base64-decode-string (fns-tests--string-repeat "Zm9v" 25) t) + (fns-tests--string-repeat "foo" 25))) + (should (equal (base64-decode-string (fns-tests--string-repeat "Zm9vYmZvb2Jmb29i" 5) t) + (fns-tests--string-repeat "foob" 15))) + (should (equal (base64-decode-string (fns-tests--string-repeat "Zm9vYmFmb29iYWZvb2Jh" 5) t) + (fns-tests--string-repeat "fooba" 15))) + (should (equal (base64-decode-string (concat (fns-tests--string-repeat "Zm9vYmFyZm9vYmFy" 7) "Zm9vYmFy") t) + (fns-tests--string-repeat "foobar" 15))) + (should (equal (base64-decode-string (fns-tests--string-repeat "FPucA9l-" 10) t) + (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7e" 10))) + (should (equal (base64-decode-string (fns-tests--string-repeat "FPucA9l_" 10) t) + (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7f" 10))) + + ;; errors check + (should (eq :got-error (condition-case () (base64-decode-string "Zg=") (error :got-error)))) + (should (eq :got-error (condition-case () (base64-decode-string "Zm9vYmE") (error :got-error)))) + (should (eq :got-error (condition-case () (base64-decode-string "Zm9vYmFy=") (error :got-error)))) + (should (eq :got-error (condition-case () (base64-decode-string "Zg=Zg=") (error :got-error))))) + (ert-deftest fns-tests-hash-buffer () (should (equal (sha1 "foo") "0beec7b5ea3f0fdbc95d0dd47f3c5bc275da8a33")) (should (equal (with-temp-buffer @@ -235,13 +603,30 @@ (buffer-hash)) (sha1 "foo")))) +(ert-deftest fns-tests-mapconcat () + (should (string= (mapconcat #'identity '()) "")) + (should (string= (mapconcat #'identity '("a" "b")) "ab")) + (should (string= (mapconcat #'identity '() "_") "")) + (should (string= (mapconcat #'identity '("A") "_") "A")) + (should (string= (mapconcat #'identity '("A" "B") "_") "A_B")) + (should (string= (mapconcat #'identity '("A" "B" "C") "_") "A_B_C")) + ;; non-ASCII strings + (should (string= (mapconcat #'identity '("Ä" "ø" "☭" "தமிழ்") "_漢字_") + "Ä_漢字_ø_漢字_☭_漢字_தமிழ்")) + ;; vector + (should (string= (mapconcat #'identity ["a" "b"]) "ab")) + ;; bool-vector + (should (string= (mapconcat #'identity [nil nil]) "")) + (should-error (mapconcat #'identity [nil nil t]) + :type 'wrong-type-argument)) + (ert-deftest fns-tests-mapcan () (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)))))) @@ -467,24 +852,6 @@ (should-not (plist-get d1 3)) (should-not (plist-get d2 3)))) -(ert-deftest test-cycle-lax-plist-get () - (let ((c1 (cyc1 1)) - (c2 (cyc2 1 2)) - (d1 (dot1 1)) - (d2 (dot2 1 2))) - (should (lax-plist-get c1 1)) - (should (lax-plist-get c2 1)) - (should (lax-plist-get d1 1)) - (should (lax-plist-get d2 1)) - (should-error (lax-plist-get c1 2) :type 'circular-list) - (should (lax-plist-get c2 2)) - (should-error (lax-plist-get d1 2) :type 'wrong-type-argument) - (should (lax-plist-get d2 2)) - (should-error (lax-plist-get c1 3) :type 'circular-list) - (should-error (lax-plist-get c2 3) :type 'circular-list) - (should-error (lax-plist-get d1 3) :type 'wrong-type-argument) - (should-error (lax-plist-get d2 3) :type 'wrong-type-argument))) - (ert-deftest test-cycle-plist-member () (let ((c1 (cyc1 1)) (c2 (cyc2 1 2)) @@ -521,24 +888,6 @@ (should-error (plist-put d1 3 3) :type 'wrong-type-argument) (should-error (plist-put d2 3 3) :type 'wrong-type-argument))) -(ert-deftest test-cycle-lax-plist-put () - (let ((c1 (cyc1 1)) - (c2 (cyc2 1 2)) - (d1 (dot1 1)) - (d2 (dot2 1 2))) - (should (lax-plist-put c1 1 1)) - (should (lax-plist-put c2 1 1)) - (should (lax-plist-put d1 1 1)) - (should (lax-plist-put d2 1 1)) - (should-error (lax-plist-put c1 2 2) :type 'circular-list) - (should (lax-plist-put c2 2 2)) - (should-error (lax-plist-put d1 2 2) :type 'wrong-type-argument) - (should (lax-plist-put d2 2 2)) - (should-error (lax-plist-put c1 3 3) :type 'circular-list) - (should-error (lax-plist-put c2 3 3) :type 'circular-list) - (should-error (lax-plist-put d1 3 3) :type 'wrong-type-argument) - (should-error (lax-plist-put d2 3 3) :type 'wrong-type-argument))) - (ert-deftest test-cycle-equal () (should-error (equal (cyc1 1) (cyc1 1))) (should-error (equal (cyc2 1 2) (cyc2 1 2)))) @@ -548,31 +897,529 @@ (should-error (nconc (cyc2 1 2) 'tail) :type 'circular-list)) (ert-deftest plist-get/odd-number-of-elements () - "Test that ‘plist-get’ doesn’t signal an error on degenerate plists." + "Test that `plist-get' doesn't signal an error on degenerate plists." (should-not (plist-get '(:foo 1 :bar) :bar))) -(ert-deftest lax-plist-get/odd-number-of-elements () - "Check for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27726." - (should (equal (should-error (lax-plist-get '(:foo 1 :bar) :bar) - :type 'wrong-type-argument) - '(wrong-type-argument plistp (:foo 1 :bar))))) - (ert-deftest plist-put/odd-number-of-elements () "Check for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27726." (should (equal (should-error (plist-put '(:foo 1 :bar) :zot 2) :type 'wrong-type-argument) '(wrong-type-argument plistp (:foo 1 :bar))))) -(ert-deftest lax-plist-put/odd-number-of-elements () - "Check for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27726." - (should (equal (should-error (lax-plist-put '(:foo 1 :bar) :zot 2) - :type 'wrong-type-argument) - '(wrong-type-argument plistp (:foo 1 :bar))))) - (ert-deftest plist-member/improper-list () "Check for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27726." (should (equal (should-error (plist-member '(:foo 1 . :bar) :qux) :type 'wrong-type-argument) '(wrong-type-argument plistp (:foo 1 . :bar))))) -(provide 'fns-tests) +(ert-deftest test-string-distance () + "Test `string-distance' behavior." + ;; ASCII characters are always fine + (should (equal 1 (string-distance "heelo" "hello"))) + (should (equal 2 (string-distance "aeelo" "hello"))) + (should (equal 0 (string-distance "ab" "ab" t))) + (should (equal 1 (string-distance "ab" "abc" t))) + + ;; string containing hanzi character, compare by byte + (should (equal 6 (string-distance "ab" "ab我她" t))) + (should (equal 3 (string-distance "ab" "a我b" t))) + (should (equal 3 (string-distance "我" "她" t))) + + ;; string containing hanzi character, compare by character + (should (equal 2 (string-distance "ab" "ab我她"))) + (should (equal 1 (string-distance "ab" "a我b"))) + (should (equal 1 (string-distance "我" "她"))) + + ;; correct behavior with empty strings + (should (equal 0 (string-distance "" ""))) + (should (equal 0 (string-distance "" "" t))) + (should (equal 1 (string-distance "x" ""))) + (should (equal 1 (string-distance "x" "" t))) + (should (equal 1 (string-distance "" "x"))) + (should (equal 1 (string-distance "" "x" t)))) + +(ert-deftest test-bignum-eql () + "Test that `eql' works for bignums." + (let ((x (+ most-positive-fixnum 1)) + (y (+ most-positive-fixnum 1))) + (should (eq x x)) + (should (eql x y)) + (should (equal x y)) + (should-not (eql x 0.0e+NaN)) + (should (memql x (list y))))) + +(ert-deftest test-bignum-hash () + "Test that hash tables work for bignums." + ;; Make two bignums that are eql but not eq. + (let ((b1 (1+ most-positive-fixnum)) + (b2 (1+ most-positive-fixnum))) + (dolist (test '(eq eql equal)) + (let ((hash (make-hash-table :test test))) + (puthash b1 t hash) + (should (eq (gethash b2 hash) + (funcall test b1 b2))))))) + +(ert-deftest test-nthcdr-simple () + (should (eq (nthcdr 0 'x) 'x)) + (should (eq (nthcdr 1 '(x . y)) 'y)) + (should (eq (nthcdr 2 '(x y . z)) 'z))) + +(ert-deftest test-nthcdr-circular () + (dolist (len '(1 2 5 37 120 997 1024)) + (let ((cycle (make-list len nil))) + (setcdr (last cycle) cycle) + (dolist (n (list (1- most-negative-fixnum) most-negative-fixnum + -1 0 1 + (1- len) len (1+ len) + most-positive-fixnum (1+ most-positive-fixnum) + (* 2 most-positive-fixnum) + (* most-positive-fixnum most-positive-fixnum) + (ash 1 12345))) + (let ((a (nthcdr n cycle)) + (b (if (<= n 0) cycle (nthcdr (mod n len) cycle)))) + (should (equal (list (eq a b) n len) + (list t n len)))))))) + +(ert-deftest test-proper-list-p () + "Test `proper-list-p' behavior." + (dotimes (length 4) + ;; Proper and dotted lists. + (let ((list (make-list length 0))) + (should (= (proper-list-p list) length)) + (should (not (proper-list-p (nconc list 0))))) + ;; Circular lists. + (dotimes (n (1+ length)) + (let ((circle (make-list (1+ length) 0))) + (should (not (proper-list-p (nconc circle (nthcdr n circle)))))))) + ;; Atoms. + (should (not (proper-list-p 0))) + (should (not (proper-list-p ""))) + (should (not (proper-list-p []))) + (should (not (proper-list-p (make-bool-vector 0 nil)))) + (should (not (proper-list-p (make-symbol "a"))))) + +(ert-deftest test-hash-function-that-mutates-hash-table () + (define-hash-table-test 'badeq 'eq 'bad-hash) + (let ((h (make-hash-table :test 'badeq :size 1 :rehash-size 1))) + (defun bad-hash (k) + (if (eq k 100) + (clrhash h)) + (sxhash-eq k)) + (should-error + (dotimes (k 200) + (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")) + (should (equal (secure-hash 'sha1 "foobar") + "8843d7f92416211de9ebb963ff4ce28125932878")) + (should (equal (secure-hash 'sha224 "foobar") + "de76c3e567fca9d246f5f8d3b2e704a38c3c5e258988ab525f941db8")) + (should (equal (secure-hash 'sha256 "foobar") + (concat "c3ab8ff13720e8ad9047dd39466b3c89" + "74e592c2fa383d4a3960714caef0c4f2"))) + (should (equal (secure-hash 'sha384 "foobar") + (concat "3c9c30d9f665e74d515c842960d4a451c83a0125fd3de739" + "2d7b37231af10c72ea58aedfcdf89a5765bf902af93ecf06"))) + (should (equal (secure-hash 'sha512 "foobar") + (concat "0a50261ebd1a390fed2bf326f2673c145582a6342d5" + "23204973d0219337f81616a8069b012587cf5635f69" + "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))) + + (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)))) + +(defun approx-equal (list1 list2) + (and (equal (length list1) (length list2)) + (cl-loop for v1 in list1 + for v2 in list2 + when (not (or (= v1 v2) + (< (abs (- v1 v2)) 0.1))) + return nil + finally return t))) + +(ert-deftest test-buffer-line-stats-nogap () + (with-temp-buffer + (insert "") + (should (approx-equal (buffer-line-statistics) '(0 0 0)))) + (with-temp-buffer + (insert "123\n") + (should (approx-equal (buffer-line-statistics) '(1 3 3)))) + (with-temp-buffer + (insert "123\n12345\n123\n") + (should (approx-equal (buffer-line-statistics) '(3 5 3.66)))) + (with-temp-buffer + (insert "123\n12345\n123") + (should (approx-equal (buffer-line-statistics) '(3 5 3.66)))) + (with-temp-buffer + (insert "123\n12345") + (should (approx-equal (buffer-line-statistics) '(2 5 4)))) + + (with-temp-buffer + (insert "123\n12é45\n123\n") + (should (approx-equal (buffer-line-statistics) '(3 6 4)))) + + (with-temp-buffer + (insert "\n\n\n") + (should (approx-equal (buffer-line-statistics) '(3 0 0))))) + +(ert-deftest test-buffer-line-stats-gap () + (with-temp-buffer + (dotimes (_ 1000) + (insert "12345678901234567890123456789012345678901234567890\n")) + (goto-char (point-min)) + ;; This should make a gap appear. + (insert "123\n") + (delete-region (point-min) (point)) + (should (approx-equal (buffer-line-statistics) '(1000 50 50.0)))) + (with-temp-buffer + (dotimes (_ 1000) + (insert "12345678901234567890123456789012345678901234567890\n")) + (goto-char (point-min)) + (insert "123\n") + (should (approx-equal (buffer-line-statistics) '(1001 50 49.9)))) + (with-temp-buffer + (dotimes (_ 1000) + (insert "12345678901234567890123456789012345678901234567890\n")) + (goto-char (point-min)) + (insert "123\n") + (goto-char (point-max)) + (insert "fóo") + (should (approx-equal (buffer-line-statistics) '(1002 50 49.9))))) + +(ert-deftest test-line-number-at-position () + (with-temp-buffer + (insert (make-string 10 ?\n)) + (should (= (line-number-at-pos (point)) 11)) + (should (= (line-number-at-pos nil) 11)) + (should-error (line-number-at-pos -1)) + (should-error (line-number-at-pos 100)))) + +(defun fns-tests-concat (&rest args) + ;; Dodge the byte-compiler's partial evaluation of `concat' with + ;; constant arguments. + (apply #'concat args)) + +(ert-deftest fns-concat () + (should (equal (fns-tests-concat) "")) + (should (equal (fns-tests-concat "") "")) + (should (equal (fns-tests-concat nil) "")) + (should (equal (fns-tests-concat []) "")) + (should (equal (fns-tests-concat [97 98]) "ab")) + (should (equal (fns-tests-concat '(97 98)) "ab")) + (should (equal (fns-tests-concat "ab" '(99 100) nil [101 102] "gh") + "abcdefgh")) + (should (equal (fns-tests-concat "Ab" "\200" "cd") "Ab\200cd")) + (should (equal (fns-tests-concat "aB" "\200" "çd") "aB\200çd")) + (should (equal (fns-tests-concat "AB" (string-to-multibyte "\200") "cd") + (string-to-multibyte "AB\200cd"))) + (should (equal (fns-tests-concat "ab" '(#xe5) [255] "cd") "abåÿcd")) + (should (equal (fns-tests-concat '(#x3fffff) [#x3fff80] "xy") "\377\200xy")) + (should (equal (fns-tests-concat '(#x3fffff) [#x3fff80] "xy§") "\377\200xy§")) + (should (equal-including-properties + (fns-tests-concat #("abc" 0 3 (a 1)) #("de" 0 2 (a 1))) + #("abcde" 0 5 (a 1)))) + (should (equal-including-properties + (fns-tests-concat #("abc" 0 3 (a 1)) "§ü" #("çå" 0 2 (b 2))) + #("abc§üçå" 0 3 (a 1) 5 7 (b 2)))) + (should-error (fns-tests-concat "a" '(98 . 99)) + :type 'wrong-type-argument) + (let ((loop (list 66 67))) + (setcdr (cdr loop) loop) + (should-error (fns-tests-concat "A" loop) + :type 'circular-list))) + +(ert-deftest fns-vconcat () + (should (equal (vconcat) [])) + (should (equal (vconcat nil) [])) + (should (equal (vconcat "") [])) + (should (equal (vconcat [1 2 3]) [1 2 3])) + (should (equal (vconcat '(1 2 3)) [1 2 3])) + (should (equal (vconcat "ABC") [65 66 67])) + (should (equal (vconcat "ü§") [252 167])) + (should (equal (vconcat [1 2 3] nil '(4 5) "AB" "å" + "\377" (string-to-multibyte "\377") + (bool-vector t nil nil t nil)) + [1 2 3 4 5 65 66 #xe5 255 #x3fffff t nil nil t nil])) + (should-error (vconcat [1] '(2 . 3)) + :type 'wrong-type-argument) + (let ((loop (list 1 2))) + (setcdr (cdr loop) loop) + (should-error (vconcat [1] loop) + :type 'circular-list))) + +(ert-deftest fns-append () + (should (equal (append) nil)) + (should (equal (append 'tail) 'tail)) + (should (equal (append [1 2 3] nil '(4 5) "AB" "å" + "\377" (string-to-multibyte "\377") + (bool-vector t nil nil t nil) + '(9 10)) + '(1 2 3 4 5 65 66 #xe5 255 #x3fffff t nil nil t nil 9 10))) + (should (equal (append '(1 2) '(3 4) 'tail) + '(1 2 3 4 . tail))) + (should-error (append '(1 . 2) '(3)) + :type 'wrong-type-argument) + (let ((loop (list 1 2))) + (setcdr (cdr loop) loop) + (should-error (append loop '(end)) + :type 'circular-list))) + +(ert-deftest test-plist () + (let ((plist '(:a "b"))) + (setq plist (plist-put plist :b "c")) + (should (equal (plist-get plist :b) "c")) + (should (equal (plist-member plist :b) '(:b "c")))) + + (let ((plist '("1" "2" "a" "b"))) + (setq plist (plist-put plist (copy-sequence "a") "c")) + (should-not (equal (plist-get plist (copy-sequence "a")) "c")) + (should-not (equal (plist-member plist (copy-sequence "a")) '("a" "c")))) + + (let ((plist '("1" "2" "a" "b"))) + (setq plist (plist-put plist (copy-sequence "a") "c" #'equal)) + (should (equal (plist-get plist (copy-sequence "a") #'equal) "c")) + (should (equal (plist-member plist (copy-sequence "a") #'equal) + '("a" "c"))))) + +(ert-deftest fns--string-to-unibyte-multibyte () + (dolist (str (list "" "a" "abc" "a\x00\x7fz" "a\xaa\xbbz" "\x80\xdd\xff" + (apply #'unibyte-string (number-sequence 0 255)))) + (ert-info ((prin1-to-string str) :prefix "str: ") + (should-not (multibyte-string-p str)) + (let* ((u (string-to-unibyte str)) ; should be identity + (m (string-to-multibyte u)) ; lossless conversion + (mm (string-to-multibyte m)) ; should be identity + (uu (string-to-unibyte m)) ; also lossless + (ml (mapcar (lambda (c) (if (<= c #x7f) c (+ c #x3fff00))) u))) + (should-not (multibyte-string-p u)) + (should (multibyte-string-p m)) + (should (multibyte-string-p mm)) + (should-not (multibyte-string-p uu)) + (should (equal str u)) + (should (equal m mm)) + (should (equal str uu)) + (should (equal (append m nil) ml))))) + (should-error (string-to-unibyte "å")) + (should-error (string-to-unibyte "ABC∀BC"))) + +(defun fns-tests--take-ref (n list) + "Reference implementation of `take'." + (named-let loop ((m n) (tail list) (ac nil)) + (if (and (> m 0) tail) + (loop (1- m) (cdr tail) (cons (car tail) ac)) + (nreverse ac)))) + +(ert-deftest fns--take-ntake () + "Test `take' and `ntake'." + ;; Check errors and edge cases. + (should-error (take 'x '(a))) + (should-error (ntake 'x '(a))) + (should-error (take 1 'a)) + (should-error (ntake 1 'a)) + (should-error (take 2 '(a . b))) + (should-error (ntake 2 '(a . b))) + ;; Tolerate non-lists for a count of zero. + (should (equal (take 0 'a) nil)) + (should (equal (ntake 0 'a) nil)) + ;; But not non-numbers for empty lists. + (should-error (take 'x nil)) + (should-error (ntake 'x nil)) + + (dolist (list '(nil (a) (a b) (a b c) (a b c d) (a . b) (a b . c))) + (ert-info ((prin1-to-string list) :prefix "list: ") + (let ((max (if (proper-list-p list) + (+ 2 (length list)) + (safe-length list)))) + (dolist (n (number-sequence -1 max)) + (ert-info ((prin1-to-string n) :prefix "n: ") + (let* ((l (copy-tree list)) + (ref (fns-tests--take-ref n l))) + (should (equal (take n l) ref)) + (should (equal l list)) + (should (equal (ntake n l) ref)))))))) + + ;; Circular list. + (let ((list (list 'a 'b 'c))) + (setcdr (nthcdr 2 list) (cdr list)) ; list now (a b c b c b c ...) + (should (equal (take 0 list) nil)) + (should (equal (take 1 list) '(a))) + (should (equal (take 2 list) '(a b))) + (should (equal (take 3 list) '(a b c))) + (should (equal (take 4 list) '(a b c b))) + (should (equal (take 5 list) '(a b c b c))) + (should (equal (take 10 list) '(a b c b c b c b c b))) + + (should (equal (ntake 10 list) '(a b)))) + + ;; Bignum N argument. + (let ((list (list 'a 'b 'c))) + (should (equal (take (+ most-positive-fixnum 1) list) '(a b c))) + (should (equal (take (- most-negative-fixnum 1) list) nil)) + (should (equal (ntake (+ most-positive-fixnum 1) list) '(a b c))) + (should (equal (ntake (- most-negative-fixnum 1) list) nil)) + (should (equal list '(a b c))))) + +;;; fns-tests.el ends here diff --git a/test/src/font-tests.el b/test/src/font-tests.el index d86139b0f19..7e9669c6513 100644 --- a/test/src/font-tests.el +++ b/test/src/font-tests.el @@ -1,6 +1,6 @@ -;;; font-tests.el --- Test suite for font-related functions. +;;; font-tests.el --- Test suite for font-related functions. -*- lexical-binding: t -*- -;; Copyright (C) 2011-2017 Free Software Foundation, Inc. +;; Copyright (C) 2011-2022 Free Software Foundation, Inc. ;; Author: Chong Yidong <cyd@stupidchicken.com> ;; Keywords: internal @@ -96,8 +96,7 @@ expected font properties from parsing NAME.") (put 'font-parse-check 'ert-explainer 'font-parse-explain) (defun font-parse-explain (name prop expected) - (let ((result (font-get (font-spec :name name) prop)) - (propname (symbol-name prop))) + (let ((propname (symbol-name prop))) (format "Parsing `%s': expected %s `%s', got `%s'." name (substring propname 1) expected (font-get (font-spec :name name) prop)))) @@ -159,9 +158,30 @@ expected font properties from parsing NAME.") (insert "\n")))) (goto-char (point-min))) -;; Local Variables: -;; no-byte-compile: t -;; End: +(ert-deftest font-parse-xlfd-test () + ;; Normal number of segments. + (should (equal (font-get + (font-spec :name "-GNU -FreeSans-semibold-italic-normal-*-*-*-*-*-*-0-iso10646-1") + :family) + 'FreeSans)) + (should (equal (font-get + (font-spec :name "-GNU -FreeSans-semibold-italic-normal-*-*-*-*-*-*-0-iso10646-1") + :foundry) + 'GNU\ )) + ;; Dash in the family name. + (should (equal (font-get + (font-spec :name "-Take-mikachan-PS-normal-normal-normal-*-*-*-*-*-*-0-iso10646-1") + :family) + 'mikachan-PS)) + (should (equal (font-get + (font-spec :name "-Take-mikachan-PS-normal-normal-normal-*-*-*-*-*-*-0-iso10646-1") + :weight) + 'normal)) + ;; Synthetic test. + (should (equal (font-get + (font-spec :name "-foundry-name-with-lots-of-dashes-normal-normal-normal-*-*-*-*-*-*-0-iso10646-1") + :family) + 'name-with-lots-of-dashes))) (provide 'font-tests) ;;; font-tests.el ends here. diff --git a/test/src/image-tests.el b/test/src/image-tests.el new file mode 100644 index 00000000000..d1a4dad37b9 --- /dev/null +++ b/test/src/image-tests.el @@ -0,0 +1,69 @@ +;;; image-tests.el --- Tests for image.c -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; 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) + +(declare-function image-size "image.c" (spec &optional pixels frame)) +(declare-function image-mask-p "image.c" (spec &optional frame)) +(declare-function image-metadata "image.c" (spec &optional frame)) + +(defconst image-tests--images + `((gif . ,(expand-file-name "test/data/image/black.gif" + source-directory)) + (jpeg . ,(expand-file-name "test/data/image/black.jpg" + source-directory)) + (pbm . ,(find-image '((:file "splash.svg" :type svg)))) + (png . ,(find-image '((:file "splash.png" :type png)))) + (svg . ,(find-image '((:file "splash.pbm" :type pbm)))) + (tiff . ,(expand-file-name + "nextstep/GNUstep/Emacs.base/Resources/emacs.tiff" + source-directory)) + (webp . ,(expand-file-name "test/data/image/black.webp" + source-directory)) + (xbm . ,(find-image '((:file "gnus/gnus.xbm" :type xbm)))) + (xpm . ,(find-image '((:file "splash.xpm" :type xpm)))))) + +(ert-deftest image-tests-image-size/error-on-nongraphical-display () + (skip-unless (not (display-images-p))) + (should-error (image-size 'invalid-spec))) + +(ert-deftest image-tests-image-mask-p/error-on-nongraphical-display () + (skip-unless (not (display-images-p))) + (should-error (image-mask-p (cdr (assq 'xpm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/error-on-nongraphical-display () + (skip-unless (not (display-images-p))) + (should-error (image-metadata (cdr (assq 'xpm image-tests--images))))) + +(ert-deftest image-tests-imagemagick-types () + (skip-unless (fboundp 'imagemagick-types)) + (when (fboundp 'imagemagick-types) + (should (listp (imagemagick-types))))) + +(ert-deftest image-tests-init-image-library () + (skip-unless (fboundp 'init-image-library)) + (declare-function init-image-library "image.c" (type)) + (should (init-image-library 'pbm)) ; built-in + (should-not (init-image-library 'invalid-image-type))) + +;;; image-tests.el ends here diff --git a/test/src/indent-tests.el b/test/src/indent-tests.el new file mode 100644 index 00000000000..e6b1fde6e18 --- /dev/null +++ b/test/src/indent-tests.el @@ -0,0 +1,61 @@ +;;; indent-tests.el --- tests for src/indent.c -*- lexical-binding:t -*- + +;; Copyright (C) 2020-2022 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/>. + +;;; 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"))) + +;;; indent-tests.el ends here diff --git a/test/src/inotify-tests.el b/test/src/inotify-tests.el index 9f8abb0ffdb..295b184be0e 100644 --- a/test/src/inotify-tests.el +++ b/test/src/inotify-tests.el @@ -1,6 +1,6 @@ ;;; inotify-tests.el --- Test suite for inotify. -*- lexical-binding: t -*- -;; Copyright (C) 2012-2017 Free Software Foundation, Inc. +;; Copyright (C) 2012-2022 Free Software Foundation, Inc. ;; Author: Rüdiger Sonderfeld <ruediger@c-plusplus.de> ;; Keywords: internal @@ -24,9 +24,11 @@ ;;; Code: (require 'ert) +(require 'ert-x) (declare-function inotify-add-watch "inotify.c" (file-name aspect callback)) (declare-function inotify-rm-watch "inotify.c" (watch-descriptor)) +(declare-function inotify-valid-p "inotify.c" (watch-descriptor)) (ert-deftest inotify-valid-p-simple () "Simple tests for `inotify-valid-p'." @@ -37,8 +39,7 @@ ;; (ert-deftest filewatch-file-watch-aspects-check () ;; "Test whether `file-watch' properly checks the aspects." -;; (let ((temp-file (make-temp-file "filewatch-aspects"))) -;; (should (stringp temp-file)) +;; (ert-with-temp-file temp-file ;; (should-error (file-watch temp-file 'wrong nil) ;; :type 'error) ;; (should-error (file-watch temp-file '(modify t) nil) @@ -50,24 +51,22 @@ (ert-deftest inotify-file-watch-simple () "Test if watching a normal file works." - (skip-unless (featurep 'inotify)) - (let ((temp-file (make-temp-file "inotify-simple")) - (events 0)) - (let ((wd - (inotify-add-watch temp-file t (lambda (_ev) - (setq events (1+ events)))))) - (unwind-protect - (progn - (with-temp-file temp-file - (insert "Foo\n")) - (read-event nil nil 5) - (should (> events 0))) - (should (inotify-valid-p wd)) - (inotify-rm-watch wd) - (should-not (inotify-valid-p wd)) - (delete-file temp-file))))) + (ert-with-temp-file temp-file + (let ((events 0)) + (let ((wd + (inotify-add-watch temp-file t (lambda (_ev) + (setq events (1+ events)))))) + (unwind-protect + (progn + (with-temp-file temp-file + (insert "Foo\n")) + (read-event nil nil 5) + (should (> events 0))) + (should (inotify-valid-p wd)) + (inotify-rm-watch wd) + (should-not (inotify-valid-p wd))))))) (provide 'inotify-tests) -;;; inotify-tests.el ends here. +;;; inotify-tests.el ends here diff --git a/test/src/json-tests.el b/test/src/json-tests.el new file mode 100644 index 00000000000..3560e1abc96 --- /dev/null +++ b/test/src/json-tests.el @@ -0,0 +1,343 @@ +;;; json-tests.el --- unit tests for json.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2022 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/>. + +;;; Commentary: + +;; Unit tests for src/json.c. + +;;; Code: + +(require 'cl-lib) +(require 'map) + +(declare-function json-serialize "json.c" (object &rest args)) +(declare-function json-insert "json.c" (object &rest args)) +(declare-function json-parse-string "json.c" (string &rest args)) +(declare-function json-parse-buffer "json.c" (&rest args)) + +(define-error 'json-tests--error "JSON test error") + +(ert-deftest json-serialize/roundtrip () + (skip-unless (fboundp 'json-serialize)) + ;; The noncharacter U+FFFF should be passed through, + ;; cf. https://www.unicode.org/faq/private_use.html#noncharacters. + (let ((lisp [:null :false t 0 123 -456 3.75 "abc\uFFFFαβγ𝔸𝐁𝖢\"\\"]) + (json "[null,false,true,0,123,-456,3.75,\"abc\uFFFFαβγ𝔸𝐁𝖢\\\"\\\\\"]")) + (should (equal (json-serialize lisp) json)) + (with-temp-buffer + (json-insert lisp) + (should (equal (buffer-string) json)) + (should (eobp))) + (should (equal (json-parse-string json) lisp)) + (with-temp-buffer + (insert json) + (goto-char 1) + (should (equal (json-parse-buffer) lisp)) + (should (eobp))))) + +(ert-deftest json-serialize/roundtrip-scalars () + "Check that Bug#42994 is fixed." + (skip-unless (fboundp 'json-serialize)) + (dolist (case '((:null "null") + (:false "false") + (t "true") + (0 "0") + (123 "123") + (-456 "-456") + (3.75 "3.75") + ;; The noncharacter U+FFFF should be passed through, + ;; cf. https://www.unicode.org/faq/private_use.html#noncharacters. + ("abc\uFFFFαβγ𝔸𝐁𝖢\"\\" + "\"abc\uFFFFαβγ𝔸𝐁𝖢\\\"\\\\\""))) + (cl-destructuring-bind (lisp json) case + (ert-info ((format "%S ↔ %S" lisp json)) + (should (equal (json-serialize lisp) json)) + (with-temp-buffer + (json-insert lisp) + (should (equal (buffer-string) json)) + (should (eobp))) + (should (equal (json-parse-string json) lisp)) + (with-temp-buffer + (insert json) + (goto-char 1) + (should (equal (json-parse-buffer) lisp)) + (should (eobp))))))) + +(ert-deftest json-serialize/object () + (skip-unless (fboundp 'json-serialize)) + (let ((table (make-hash-table :test #'equal))) + (puthash "abc" [1 2 t] table) + (puthash "def" :null table) + (should (equal (json-serialize table) + "{\"abc\":[1,2,true],\"def\":null}"))) + (should (equal (json-serialize '((abc . [1 2 t]) (def . :null))) + "{\"abc\":[1,2,true],\"def\":null}")) + (should (equal (json-serialize nil) "{}")) + (should (equal (json-serialize '((abc))) "{\"abc\":{}}")) + (should (equal (json-serialize '((a . 1) (b . 2) (a . 3))) + "{\"a\":1,\"b\":2}")) + (should-error (json-serialize '(abc)) :type 'wrong-type-argument) + (should-error (json-serialize '((a 1))) :type 'wrong-type-argument) + (should-error (json-serialize '((1 . 2))) :type 'wrong-type-argument) + (should-error (json-serialize '((a . 1) . b)) :type 'wrong-type-argument) + (should-error (json-serialize '#1=((a . 1) . #1#)) :type 'circular-list) + (should-error (json-serialize '(#1=(a #1#)))) + + (should (equal (json-serialize '(:abc [1 2 t] :def :null)) + "{\"abc\":[1,2,true],\"def\":null}")) + (should (equal (json-serialize '(abc [1 2 t] :def :null)) + "{\"abc\":[1,2,true],\"def\":null}")) + (should-error (json-serialize '#1=(:a 1 . #1#)) :type 'circular-list) + (should-error (json-serialize '#1=(:a 1 :b . #1#)) + :type '(circular-list wrong-type-argument)) + (should-error (json-serialize '(:foo "bar" (unexpected-alist-key . 1))) + :type 'wrong-type-argument) + (should-error (json-serialize '((abc . "abc") :unexpected-plist-key "key")) + :type 'wrong-type-argument) + (should-error (json-serialize '(:foo bar :odd-numbered)) + :type 'wrong-type-argument) + (should (equal + (json-serialize + (list :detect-hash-table #s(hash-table test equal data ("bla" "ble")) + :detect-alist '((bla . "ble")) + :detect-plist '(:bla "ble"))) + "\ +{\ +\"detect-hash-table\":{\"bla\":\"ble\"},\ +\"detect-alist\":{\"bla\":\"ble\"},\ +\"detect-plist\":{\"bla\":\"ble\"}\ +}"))) + +(ert-deftest json-serialize/object-with-duplicate-keys () + (skip-unless (fboundp 'json-serialize)) + (let ((table (make-hash-table :test #'eq))) + (puthash (copy-sequence "abc") [1 2 t] table) + (puthash (copy-sequence "abc") :null table) + (should (equal (hash-table-count table) 2)) + (should-error (json-serialize table) :type 'wrong-type-argument))) + +(ert-deftest json-parse-string/object () + (skip-unless (fboundp 'json-parse-string)) + (let ((input + "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n")) + (let ((actual (json-parse-string input))) + (should (hash-table-p actual)) + (should (equal (hash-table-count actual) 2)) + (should (equal (cl-sort (map-pairs actual) #'string< :key #'car) + '(("abc" . [9 :false]) ("def" . :null))))) + (should (equal (json-parse-string input :object-type 'alist) + '((abc . [9 :false]) (def . :null)))) + (should (equal (json-parse-string input :object-type 'plist) + '(:abc [9 :false] :def :null))))) + +(ert-deftest json-parse-string/array () + (skip-unless (fboundp 'json-parse-string)) + (let ((input "[\"a\", 1, [\"b\", 2]]")) + (should (equal (json-parse-string input) + ["a" 1 ["b" 2]])) + (should (equal (json-parse-string input :array-type 'list) + '("a" 1 ("b" 2)))))) + +(ert-deftest json-parse-string/string () + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string "[\"formfeed\f\"]") :type 'json-parse-error) + (should (equal (json-parse-string "[\"foo \\\"bar\\\"\"]") ["foo \"bar\""])) + (should (equal (json-parse-string "[\"abcαβγ\"]") ["abcαβγ"])) + (should (equal (json-parse-string "[\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"]") + ["\nasdфывfgh\t"])) + (should (equal (json-parse-string "[\"\\uD834\\uDD1E\"]") ["\U0001D11E"])) + (should-error (json-parse-string "foo") :type 'json-parse-error) + ;; FIXME: Is this the right behavior? + (should (equal (json-parse-string "[\"\u00C4\xC3\x84\"]") ["\u00C4\u00C4"]))) + +(ert-deftest json-serialize/string () + (skip-unless (fboundp 'json-serialize)) + (should (equal (json-serialize ["foo"]) "[\"foo\"]")) + (should (equal (json-serialize ["a\n\fb"]) "[\"a\\n\\fb\"]")) + (should (equal (json-serialize ["\nasdфыв\u001f\u007ffgh\t"]) + "[\"\\nasdфыв\\u001F\u007ffgh\\t\"]")) + (should (equal (json-serialize ["a\0b"]) "[\"a\\u0000b\"]")) + ;; FIXME: Is this the right behavior? + (should (equal (json-serialize ["\u00C4\xC3\x84"]) "[\"\u00C4\u00C4\"]"))) + +(ert-deftest json-serialize/invalid-unicode () + (skip-unless (fboundp 'json-serialize)) + (should-error (json-serialize ["a\uDBBBb"]) :type 'wrong-type-argument) + (should-error (json-serialize ["u\x110000v"]) :type 'wrong-type-argument) + (should-error (json-serialize ["u\x3FFFFFv"]) :type 'wrong-type-argument) + (should-error (json-serialize ["u\xCCv"]) :type 'wrong-type-argument) + (should-error (json-serialize ["u\u00C4\xCCv"]) :type 'wrong-type-argument)) + +(ert-deftest json-parse-string/null () + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string "\x00") :type 'wrong-type-argument) + (should (json-parse-string "[\"a\\u0000b\"]")) + (let* ((string "{\"foo\":\"this is a string including a literal \\u0000\"}") + (data (json-parse-string string))) + (should (hash-table-p data)) + (should (equal string (json-serialize data))))) + +(ert-deftest json-parse-string/invalid-unicode () + "Some examples from +https://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt. +Test with both unibyte and multibyte strings." + (skip-unless (fboundp 'json-parse-string)) + ;; Invalid UTF-8 code unit sequences. + (should-error (json-parse-string "[\"\x80\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\x80\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\xBF\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xBF\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\xFE\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xFE\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\xC0\xAF\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xC0\xAF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xC0\x80\"]") + :type 'json-parse-error) + ;; Surrogates. + (should-error (json-parse-string "[\"\uDB7F\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\xED\xAD\xBF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xED\xAD\xBF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\uDB7F\uDFFF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\xED\xAD\xBF\xED\xBF\xBF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xED\xAD\xBF\xED\xBF\xBF\"]") + :type 'json-parse-error)) + +(ert-deftest json-parse-string/incomplete () + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string "[123") :type 'json-end-of-file)) + +(ert-deftest json-parse-string/trailing () + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string "[123] [456]") :type 'json-trailing-content)) + +(ert-deftest json-parse-buffer/incomplete () + (skip-unless (fboundp 'json-parse-buffer)) + (with-temp-buffer + (insert "[123") + (goto-char 1) + (should-error (json-parse-buffer) :type 'json-end-of-file) + (should (bobp)))) + +(ert-deftest json-parse-buffer/trailing () + (skip-unless (fboundp 'json-parse-buffer)) + (with-temp-buffer + (insert "[123] [456]") + (goto-char 1) + (should (equal (json-parse-buffer) [123])) + (should-not (bobp)) + (should (looking-at-p (rx " [456]" eos))))) + +(ert-deftest json-parse-with-custom-null-and-false-objects () + (skip-unless (and (fboundp 'json-serialize) + (fboundp 'json-parse-string))) + (let* ((input + "{ \"abc\" : [9, false] , \"def\" : null }") + (output + (string-replace " " "" input))) + (should (equal (json-parse-string input + :object-type 'plist + :null-object :json-null + :false-object :json-false) + '(:abc [9 :json-false] :def :json-null))) + (should (equal (json-parse-string input + :object-type 'plist + :false-object :json-false) + '(:abc [9 :json-false] :def :null))) + (should (equal (json-parse-string input + :object-type 'alist + :null-object :zilch) + '((abc . [9 :false]) (def . :zilch)))) + (should (equal (json-parse-string input + :object-type 'alist + :false-object nil + :null-object nil) + '((abc . [9 nil]) (def)))) + (let* ((thingy '(1 2 3)) + (retval (json-parse-string input + :object-type 'alist + :false-object thingy + :null-object nil))) + (should (equal retval `((abc . [9 ,thingy]) (def)))) + (should (eq (elt (cdr (car retval)) 1) thingy))) + (should (equal output + (json-serialize '((abc . [9 :myfalse]) (def . :mynull)) + :false-object :myfalse + :null-object :mynull))) + ;; :object-type is not allowed in json-serialize + (should-error (json-serialize '() :object-type 'alist)))) + +(ert-deftest json-insert/signal () + (skip-unless (fboundp 'json-insert)) + (with-temp-buffer + (let ((calls 0)) + (add-hook 'after-change-functions + (lambda (_begin _end _length) + (cl-incf calls) + (signal 'json-tests--error + '("Error in `after-change-functions'"))) + :local) + (should-error + (json-insert '((a . "b") (c . 123) (d . [1 2 t :false]))) + :type 'json-tests--error) + (should (equal calls 1))))) + +(ert-deftest json-insert/throw () + (skip-unless (fboundp 'json-insert)) + (with-temp-buffer + (let ((calls 0)) + (add-hook 'after-change-functions + (lambda (_begin _end _length) + (cl-incf calls) + (throw 'test-tag 'throw-value)) + :local) + (should + (equal + (catch 'test-tag + (json-insert '((a . "b") (c . 123) (d . [1 2 t :false])))) + 'throw-value)) + (should (equal calls 1))))) + +(ert-deftest json-serialize/bignum () + (skip-unless (fboundp 'json-serialize)) + (should (equal (json-serialize (vector (1+ most-positive-fixnum) + (1- most-negative-fixnum))) + (format "[%d,%d]" + (1+ most-positive-fixnum) + (1- most-negative-fixnum))))) + +(ert-deftest json-parse-string/wrong-type () + "Check that Bug#42113 is fixed." + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string 1) :type 'wrong-type-argument)) + +(ert-deftest json-serialize/wrong-hash-key-type () + "Check that Bug#42113 is fixed." + (skip-unless (fboundp 'json-serialize)) + (let ((table (make-hash-table :test #'eq))) + (puthash 1 2 table) + (should-error (json-serialize table) :type 'wrong-type-argument))) + +(provide 'json-tests) +;;; json-tests.el ends here diff --git a/test/src/keyboard-tests.el b/test/src/keyboard-tests.el new file mode 100644 index 00000000000..d17c9d96a63 --- /dev/null +++ b/test/src/keyboard-tests.el @@ -0,0 +1,74 @@ +;;; keyboard-tests.el --- Tests for keyboard.c -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2022 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) + +(ert-deftest keyboard-unread-command-events () + "Test `unread-command-events'." + (let ((unread-command-events nil)) + (should (equal (progn (push ?\C-a unread-command-events) + (read-event nil nil 1)) + ?\C-a)) + (should (equal (progn (run-with-timer + 1 nil + (lambda () (push '(t . ?\C-b) unread-command-events))) + (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))))) + +;; FIXME: This test doesn't currently work :-( +;; (ert-deftest keyboard-tests--echo-keystrokes-bug15332 () +;; (let ((msgs '()) +;; (unread-command-events nil) +;; (redisplay--interactive t) +;; (echo-keystrokes 2)) +;; (setq unread-command-events '(?\C-u)) +;; (let* ((timer1 +;; (run-with-timer 3 1 +;; (lambda () +;; (setq unread-command-events '(?5))))) +;; (timer2 +;; (run-with-timer 2.5 1 +;; (lambda () +;; (push (current-message) msgs))))) +;; (run-with-timer 5 nil +;; (lambda () +;; (cancel-timer timer1) +;; (cancel-timer timer2) +;; (throw 'exit msgs))) +;; (recursive-edit) +;; (should (equal msgs '("C-u 55-" "C-u 5-" "C-u-")))))) + +(provide 'keyboard-tests) +;;; keyboard-tests.el ends here diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el index bc2b424a639..ce96be6869e 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-2017 Free Software Foundation, Inc. +;; Copyright (C) 2015-2022 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,188 @@ (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-define-key/undefined () + ;; nil (means key is undefined in this keymap), + (let ((map (make-keymap))) + (define-key map [?a] nil) + (should-not (lookup-key map [?a])))) + +(ert-deftest keymap-define-key/keyboard-macro () + ;; a string (treated as a keyboard macro), + (let ((map (make-keymap))) + (define-key map [?a] "abc") + (should (equal (lookup-key map [?a]) "abc")))) + +(ert-deftest keymap-define-key/lambda () + (let ((map (make-keymap))) + (define-key map [?a] (lambda () (interactive) nil)) + (should (functionp (lookup-key map [?a]))))) + +(ert-deftest keymap-define-key/keymap () + ;; a keymap (to define a prefix key), + (let ((map (make-keymap)) + (map2 (make-keymap))) + (define-key map [?a] map2) + (define-key map2 [?b] 'foo) + (should (eq (lookup-key map [?a ?b]) 'foo)))) + +(ert-deftest keymap-define-key/menu-item () + ;; or an extended menu item definition. + ;; (See info node ‘(elisp)Extended Menu Items’.) + (let ((map (make-sparse-keymap)) + (menu (make-sparse-keymap))) + (define-key menu [new-file] + '(menu-item "Visit New File..." find-file + :enable (menu-bar-non-minibuffer-window-p) + :help "Specify a new file's name, to edit the file")) + (define-key map [menu-bar file] (cons "File" menu)) + (should (eq (lookup-key map [menu-bar file new-file]) 'find-file)))) + +(ert-deftest keymap-lookup-key () + (let ((map (make-keymap))) + (define-key map [?a] 'foo) + (should (eq (lookup-key map [?a]) 'foo)) + (should-not (lookup-key map [?b])))) + +(ert-deftest keymap-lookup-key/list-of-keymaps () + (let ((map1 (make-keymap)) + (map2 (make-keymap))) + (define-key map1 [?a] 'foo) + (define-key map2 [?b] 'bar) + (should (eq (lookup-key (list map1 map2) [?a]) 'foo)) + (should (eq (lookup-key (list map1 map2) [?b]) 'bar)) + (should-not (lookup-key (list map1 map2) [?c])))) + +(ert-deftest keymap-lookup-key/too-long () + (let ((map (make-keymap))) + (define-key map (kbd "C-c f") 'foo) + (should (= (lookup-key map (kbd "C-c f x")) 2)))) + +;; TODO: Write test for the ACCEPT-DEFAULT argument. +;; (ert-deftest keymap-lookup-key/accept-default () +;; ...) + +(ert-deftest keymap-lookup-key/mixed-case () + "Backwards compatibility behavior (Bug#50752)." + (let ((map (make-keymap))) + (define-key map [menu-bar foo bar] 'foo) + (should (eq (lookup-key map [menu-bar foo bar]) 'foo)) + (should (eq (lookup-key map [menu-bar Foo Bar]) 'foo))) + (let ((map (make-keymap))) + (define-key map [menu-bar i-bar] 'foo) + (should (eq (lookup-key map [menu-bar I-bar]) 'foo)))) + +(ert-deftest keymap-lookup-key/mixed-case-multibyte () + "Backwards compatibility behavior (Bug#50752)." + (let ((map (make-keymap))) + ;; (downcase "Åäö") => "åäö" + (define-key map [menu-bar åäö bar] 'foo) + (should (eq (lookup-key map [menu-bar åäö bar]) 'foo)) + (should (eq (lookup-key map [menu-bar Åäö Bar]) 'foo)) + ;; (downcase "Γ") => "γ" + (define-key map [menu-bar γ bar] 'baz) + (should (eq (lookup-key map [menu-bar γ bar]) 'baz)) + (should (eq (lookup-key map [menu-bar Γ Bar]) 'baz)))) + +(ert-deftest keymap-lookup-key/menu-non-symbol () + "Test for Bug#51527." + (let ((map (make-keymap))) + (define-key map [menu-bar buffer 1] 'foo) + (should (eq (lookup-key map [menu-bar buffer 1]) 'foo)))) + +(ert-deftest keymap-lookup-keymap/with-spaces () + "Backwards compatibility behavior (Bug#50752)." + (let ((map (make-keymap))) + (define-key map [menu-bar foo-bar] 'foo) + (should (eq (lookup-key map [menu-bar Foo\ Bar]) 'foo)))) + +(ert-deftest keymap-lookup-keymap/with-spaces-multibyte () + "Backwards compatibility behavior (Bug#50752)." + (let ((map (make-keymap))) + (define-key map [menu-bar åäö-bar] 'foo) + (should (eq (lookup-key map [menu-bar Åäö\ Bar]) 'foo)))) + +(ert-deftest keymap-lookup-keymap/with-spaces-multibyte-lang-env () + "Backwards compatibility behavior (Bug#50752)." + (let ((lang-env current-language-environment)) + (set-language-environment "Turkish") + (let ((map (make-keymap))) + (define-key map [menu-bar i-bar] 'foo) + (should (eq (lookup-key map [menu-bar I-bar]) 'foo))) + (set-language-environment lang-env))) + +(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 +221,227 @@ 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 keymap-tests-minor-mode-map + "x" 'keymap-tests--command-2) + +(defvar-keymap keymap-tests-major-mode-map + "x" 'keymap-tests--command-1) + +(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) + (describe-bindings-check-shadowing-in-ranges 'ignore-self-insert)) + (with-temp-buffer + (help--describe-vector (cadr orig-map) nil #'help--describe-command + t shadow-map orig-map t) + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + (string-replace "\t" "" " +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-substring-no-properties (point-min) (point-max)) + (string-replace "\t" "" " +0 .. 3 foo +")))))) + +(ert-deftest keymap--key-description () + (should (equal (key-description [right] [?\C-x]) + "C-x <right>")) + (should (equal (key-description [M-H-right] [?\C-x]) + "C-x M-H-<right>")) + (should (equal (single-key-description 'home) + "<home>")) + (should (equal (single-key-description 'home t) + "home")) + (should (equal (single-key-description 'C-s-home) + "C-s-<home>"))) + +(ert-deftest keymap-test-lookups () + (should (eq (lookup-key (current-global-map) "\C-x\C-f") 'find-file)) + (should (eq (lookup-key (current-global-map) [(control x) (control f)]) + 'find-file)) + (should (eq (lookup-key (current-global-map) ["C-x C-f"]) 'find-file)) + (should (eq (lookup-key (current-global-map) [?\C-x ?\C-f]) 'find-file))) + +(ert-deftest keymap-removal () + ;; Set to nil. + (let ((map (define-keymap "a" 'foo))) + (should (equal map '(keymap (97 . foo)))) + (define-key map "a" nil) + (should (equal map '(keymap (97))))) + ;; Remove. + (let ((map (define-keymap "a" 'foo))) + (should (equal map '(keymap (97 . foo)))) + (define-key map "a" nil t) + (should (equal map '(keymap))))) + +(ert-deftest keymap-removal-inherit () + ;; Set to nil. + (let ((parent (make-sparse-keymap)) + (child (make-keymap))) + (set-keymap-parent child parent) + (define-key parent [?a] 'foo) + (define-key child [?a] 'bar) + + (should (eq (lookup-key child [?a]) 'bar)) + (define-key child [?a] nil) + (should (eq (lookup-key child [?a]) nil))) + ;; Remove. + (let ((parent (make-sparse-keymap)) + (child (make-keymap))) + (set-keymap-parent child parent) + (define-key parent [?a] 'foo) + (define-key child [?a] 'bar) + + (should (eq (lookup-key child [?a]) 'bar)) + (define-key child [?a] nil t) + (should (eq (lookup-key child [?a]) 'foo)))) + +(ert-deftest keymap-text-char-description () + (should (equal (text-char-description ?a) "a")) + (should (equal (text-char-description ?\s) " ")) + (should (equal (text-char-description ?\t) "^I")) + (should (equal (text-char-description ?\^C) "^C")) + (should (equal (text-char-description ?\^?) "^?")) + (should (equal (text-char-description #x80) "")) + (should (equal (text-char-description ?å) "å")) + (should (equal (text-char-description ?Ş) "Ş")) + (should (equal (text-char-description ?Ā) "Ā")) + (should-error (text-char-description "c")) + (should-error (text-char-description [?\C-x ?l])) + (should-error (text-char-description ?\M-c)) + (should-error (text-char-description ?\s-c))) + +(ert-deftest test-non-key-events () + ;; Dummy command. + (declare-function keymap-tests-command nil) + (should (null (where-is-internal 'keymap-tests-command))) + (keymap-set global-map "C-c g" #'keymap-tests-command) + (should (equal (where-is-internal 'keymap-tests-command) '([3 103]))) + (keymap-set global-map "<keymap-tests-event>" #'keymap-tests-command) + (should (equal (where-is-internal 'keymap-tests-command) + '([keymap-tests-event] [3 103]))) + (make-non-key-event 'keymap-tests-event) + (should (equal (where-is-internal 'keymap-tests-command) '([3 103])))) + +(ert-deftest keymap-test-duplicate-definitions () + "Check that defvar-keymap rejects duplicate key definitions." + (should-error + (defvar-keymap + ert-keymap-duplicate + "a" #'next-line + "a" #'previous-line)) + (should-error + (define-keymap + "a" #'next-line + "a" #'previous-line))) + (provide 'keymap-tests) ;;; keymap-tests.el ends here diff --git a/test/src/lcms-tests.el b/test/src/lcms-tests.el index cc324af68ba..1829a7ea1f1 100644 --- a/test/src/lcms-tests.el +++ b/test/src/lcms-tests.el @@ -1,6 +1,6 @@ ;;; lcms-tests.el --- tests for Little CMS interface -*- lexical-binding: t -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org @@ -35,6 +35,13 @@ (require 'ert) (require 'color) +(declare-function lcms-jab->jch "lcms.c") +(declare-function lcms-jch->jab "lcms.c") +(declare-function lcms-xyz->jch "lcms.c") +(declare-function lcms-jch->xyz "lcms.c") +(declare-function lcms-temp->white-point "lcms.c") +(declare-function lcms-cam02-ucs "lcms.c") + (defconst lcms-colorspacious-d65 '(0.95047 1.0 1.08883) "D65 white point from colorspacious.") @@ -95,7 +102,7 @@ B is considered the exact value." '(0.29902 0.31485 1.0)))) (ert-deftest lcms-roundtrip () - "Test accuracy of converting to and from different color spaces" + "Test accuracy of converting to and from different color spaces." (skip-unless (featurep 'lcms2)) (should (let ((color '(.5 .3 .7))) @@ -109,7 +116,7 @@ B is considered the exact value." 0.0001)))) (ert-deftest lcms-ciecam02-gold () - "Test CIE CAM02 JCh gold values" + "Test CIE CAM02 JCh gold values." (skip-unless (featurep 'lcms2)) (should (lcms-triple-approx-p diff --git a/test/src/lread-resources/lazydoc.el b/test/src/lread-resources/lazydoc.el Binary files differnew file mode 100644 index 00000000000..cb434c239b5 --- /dev/null +++ b/test/src/lread-resources/lazydoc.el 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 ac730b4f005..57143dd81e5 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -1,23 +1,23 @@ ;;; lread-tests.el --- tests for lread.c -*- lexical-binding: t; -*- -;; Copyright (C) 2016-2017 Free Software Foundation, Inc. +;; Copyright (C) 2016-2022 Free Software Foundation, Inc. ;; Author: Philipp Stephani <phst@google.com> ;; 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))) @@ -112,59 +115,37 @@ (should-error (read "#24r") :type 'invalid-read-syntax) (should-error (read "#") :type 'invalid-read-syntax)) +(ert-deftest lread-char-modifiers () + (should (eq ?\C-\M-é (+ (- ?\M-a ?a) ?\C-é))) + (should (eq (- ?\C-ŗ ?ŗ) (- ?\C-é ?é)))) + (ert-deftest lread-record-1 () (should (equal '(#s(foo) #s(foo)) (read "(#1=#s(foo) #1#)")))) -(defmacro lread-tests--with-temp-file (file-name-var &rest body) - (declare (indent 1)) - (cl-check-type file-name-var symbol) - `(let ((,file-name-var (make-temp-file "emacs"))) - (unwind-protect - (progn ,@body) - (delete-file ,file-name-var)))) - (defun lread-tests--last-message () (with-current-buffer "*Messages*" (save-excursion (goto-char (point-max)) (skip-chars-backward "\n") - (buffer-substring (line-beginning-position) (point))))) + (buffer-substring (pos-bol) (point))))) (ert-deftest lread-tests--unescaped-char-literals () "Check that loading warns about unescaped character literals (Bug#20852)." - (lread-tests--with-temp-file file-name + (ert-with-temp-file file-name (write-region "?) ?( ?; ?\" ?[ ?]" nil file-name) (should (equal (load file-name nil :nomessage :nosuffix) t)) (should (equal (lread-tests--last-message) (concat (format-message "Loading `%s': " file-name) "unescaped character literals " - "`?\"', `?(', `?)', `?;', `?[', `?]' detected!"))))) - -(ert-deftest lread-tests--funny-quote-symbols () - "Check that 'smart quotes' or similar trigger errors in symbol names." - (dolist (quote-char - '(#x2018 ;; LEFT SINGLE QUOTATION MARK - #x2019 ;; RIGHT SINGLE QUOTATION MARK - #x201B ;; SINGLE HIGH-REVERSED-9 QUOTATION MARK - #x201C ;; LEFT DOUBLE QUOTATION MARK - #x201D ;; RIGHT DOUBLE QUOTATION MARK - #x201F ;; DOUBLE HIGH-REVERSED-9 QUOTATION MARK - #x301E ;; DOUBLE PRIME QUOTATION MARK - #xFF02 ;; FULLWIDTH QUOTATION MARK - #xFF07 ;; FULLWIDTH APOSTROPHE - )) - (let ((str (format "%cfoo" quote-char))) - (should-error (read str) :type 'invalid-read-syntax) - (should (eq (read (concat "\\" str)) (intern str)))))) + "`?\"', `?(', `?)', `?;', `?[', `?]' detected, " + "`?\\\"', `?\\(', `?\\)', `?\\;', `?\\[', `?\\]' " + "expected!"))))) (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) @@ -172,19 +153,190 @@ 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 warns about old-style backquotes." - (lread-tests--with-temp-file file-name - (write-region "(` (a b))" nil file-name) - (should (equal (load file-name nil :nomessage :nosuffix) t)) - (should (equal (lread-tests--last-message) - (concat (format-message "Loading `%s': " file-name) - "old-style backquotes detected!"))))) - (ert-deftest lread-lread--substitute-object-in-subtree () (let ((x (cons 0 1))) (setcar x x) (lread--substitute-object-in-subtree x 1 t) (should (eq x (cdr x))))) +(ert-deftest lread-long-hex-integer () + (should (bignump (read "#xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff")))) + +(ert-deftest lread-test-bug-31186 () + (with-temp-buffer + (insert ";; -*- -:*-") + (should-not + ;; This used to crash in lisp_file_lexically_bound_p before the + ;; bug was fixed. + (eval-buffer)))) + +(ert-deftest lread-invalid-bytecodes () + (should-error + (let ((load-force-doc-strings t)) (read "#[0 \"\"]")))) + +(ert-deftest lread-string-to-number-trailing-dot () + (dolist (n (list (* most-negative-fixnum most-negative-fixnum) + (1- most-negative-fixnum) most-negative-fixnum + (1+ most-negative-fixnum) -1 0 1 + (1- most-positive-fixnum) most-positive-fixnum + (1+ most-positive-fixnum) + (* most-positive-fixnum most-positive-fixnum))) + (should (= n (string-to-number (format "%d." n)))))) + +(ert-deftest lread-circular-hash () + (should-error (read "#s(hash-table data #0=(#0# . #0#))"))) + +(ert-deftest test-inhibit-interaction () + (let ((inhibit-interaction t)) + (should-error (read-char "foo: ")) + (should-error (read-event "foo: ")) + (should-error (read-char-exclusive "foo: ")))) + +(ert-deftest lread-float () + (should (equal (read "13") 13)) + (should (equal (read "+13") 13)) + (should (equal (read "-13") -13)) + (should (equal (read "13.") 13)) + (should (equal (read "+13.") 13)) + (should (equal (read "-13.") -13)) + (should (equal (read "13.25") 13.25)) + (should (equal (read "+13.25") 13.25)) + (should (equal (read "-13.25") -13.25)) + (should (equal (read ".25") 0.25)) + (should (equal (read "+.25") 0.25)) + (should (equal (read "-.25") -0.25)) + (should (equal (read "13e4") 130000.0)) + (should (equal (read "+13e4") 130000.0)) + (should (equal (read "-13e4") -130000.0)) + (should (equal (read "13e+4") 130000.0)) + (should (equal (read "+13e+4") 130000.0)) + (should (equal (read "-13e+4") -130000.0)) + (should (equal (read "625e-4") 0.0625)) + (should (equal (read "+625e-4") 0.0625)) + (should (equal (read "-625e-4") -0.0625)) + (should (equal (read "1.25e2") 125.0)) + (should (equal (read "+1.25e2") 125.0)) + (should (equal (read "-1.25e2") -125.0)) + (should (equal (read "1.25e+2") 125.0)) + (should (equal (read "+1.25e+2") 125.0)) + (should (equal (read "-1.25e+2") -125.0)) + (should (equal (read "1.25e-1") 0.125)) + (should (equal (read "+1.25e-1") 0.125)) + (should (equal (read "-1.25e-1") -0.125)) + (should (equal (read "4.e3") 4000.0)) + (should (equal (read "+4.e3") 4000.0)) + (should (equal (read "-4.e3") -4000.0)) + (should (equal (read "4.e+3") 4000.0)) + (should (equal (read "+4.e+3") 4000.0)) + (should (equal (read "-4.e+3") -4000.0)) + (should (equal (read "5.e-1") 0.5)) + (should (equal (read "+5.e-1") 0.5)) + (should (equal (read "-5.e-1") -0.5)) + (should (equal (read "0") 0)) + (should (equal (read "+0") 0)) + (should (equal (read "-0") 0)) + (should (equal (read "0.") 0)) + (should (equal (read "+0.") 0)) + (should (equal (read "-0.") 0)) + (should (equal (read "0.0") 0.0)) + (should (equal (read "+0.0") 0.0)) + (should (equal (read "-0.0") -0.0)) + (should (equal (read "0e5") 0.0)) + (should (equal (read "+0e5") 0.0)) + (should (equal (read "-0e5") -0.0)) + (should (equal (read "0e-5") 0.0)) + (should (equal (read "+0e-5") 0.0)) + (should (equal (read "-0e-5") -0.0)) + (should (equal (read ".0e-5") 0.0)) + (should (equal (read "+.0e-5") 0.0)) + (should (equal (read "-.0e-5") -0.0)) + (should (equal (read "0.0e-5") 0.0)) + (should (equal (read "+0.0e-5") 0.0)) + (should (equal (read "-0.0e-5") -0.0)) + (should (equal (read "0.e-5") 0.0)) + (should (equal (read "+0.e-5") 0.0)) + (should (equal (read "-0.e-5") -0.0)) + ) + +(defun lread-test-read-and-print (str) + (let* ((read-circle t) + (print-circle t) + (val (read-from-string str))) + (if (consp val) + (prin1-to-string (car val)) + (error "reading %S failed: %S" str val)))) + +(defconst lread-test-circle-cases + '("#1=(#1# . #1#)" + "#1=[#1# a #1#]" + "#1=(#2=[#1# #2#] . #1#)" + "#1=(#2=[#1# #2#] . #2#)" + "#1=[#2=(#1# . #2#)]" + "#1=(#2=[#3=(#1# . #2#) #4=(#3# . #4#)])" + )) + +(ert-deftest lread-circle () + (dolist (str lread-test-circle-cases) + (ert-info (str :prefix "input: ") + (should (equal (lread-test-read-and-print str) str)))) + (should-error (read-from-string "#1=#1#") :type 'invalid-read-syntax)) + +(ert-deftest lread-deeply-nested () + ;; Check that we can read a deeply nested data structure correctly. + (let ((levels 10000) + (prefix nil) + (suffix nil)) + (dotimes (_ levels) + (push "([#s(r " prefix) + (push ")])" suffix)) + (let ((str (concat (apply #'concat prefix) + "a" + (apply #'concat suffix)))) + (let* ((read-circle t) + (result (read-from-string str))) + (should (equal (cdr result) (length str))) + ;; Check the result. (We can't build a reference value and compare + ;; using `equal' because that function is currently depth-limited.) + (named-let check ((x (car result)) (level 0)) + (if (equal level levels) + (should (equal x 'a)) + (should (and (consp x) (null (cdr x)))) + (let ((x2 (car x))) + (should (and (vectorp x2) (equal (length x2) 1))) + (let ((x3 (aref x2 0))) + (should (and (recordp x3) (equal (length x3) 2) + (equal (aref x3 0) 'r))) + (check (aref x3 1) (1+ level)))))))))) + +(ert-deftest lread-misc () + ;; Regression tests for issues found and fixed in bug#55676: + ;; Non-breaking space after a dot makes it a dot token. + (should (equal (read-from-string "(a .\u00A0b)") + '((a . b) . 7))) + ;; #_ without symbol following is the interned empty symbol. + (should (equal (read-from-string "#_") + '(## . 2)))) + +(ert-deftest lread-escaped-lf () + ;; ?\LF should signal an error; \LF is ignored inside string literals. + (should-error (read-from-string "?\\\n x")) + (should (equal (read-from-string "\"a\\\nb\"") '("ab" . 6)))) + +(ert-deftest lread-force-load-doc-strings () + ;; Verify that lazy doc strings are loaded lazily by default, + ;; but eagerly with `force-load-doc-strings' set. + (let ((file (expand-file-name "lazydoc.el" (ert-resource-directory)))) + (fmakunbound 'lazydoc-fun) + (load file) + (let ((f (symbol-function 'lazydoc-fun))) + (should (byte-code-function-p f)) + (should (equal (aref f 4) (cons file 87)))) + + (fmakunbound 'lazydoc-fun) + (let ((load-force-doc-strings t)) + (load file) + (let ((f (symbol-function 'lazydoc-fun))) + (should (byte-code-function-p f)) + (should (equal (aref f 4) "My little\ndoc string\nhere")))))) + ;;; lread-tests.el ends here diff --git a/test/src/marker-tests.el b/test/src/marker-tests.el index 2540f157e76..32e4804fe7d 100644 --- a/test/src/marker-tests.el +++ b/test/src/marker-tests.el @@ -1,6 +1,6 @@ ;;; marker-tests.el --- tests for marker.c functions -*- lexical-binding: t -*- -;; Copyright (C) 2016-2017 Free Software Foundation, Inc. +;; Copyright (C) 2016-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -57,4 +57,4 @@ (set-marker marker-2 marker-1) (should (goto-char marker-2)))) -;;; marker-tests.el ends here. +;;; marker-tests.el ends here diff --git a/test/src/minibuf-tests.el b/test/src/minibuf-tests.el index aba5ca51707..68800729502 100644 --- a/test/src/minibuf-tests.el +++ b/test/src/minibuf-tests.el @@ -1,6 +1,6 @@ ;;; minibuf-tests.el --- tests for minibuf.c functions -*- lexical-binding: t -*- -;; Copyright (C) 2016-2017 Free Software Foundation, Inc. +;; Copyright (C) 2016-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -399,5 +399,31 @@ (minibuf-tests--test-completion-regexp #'minibuf-tests--strings-to-symbol-hashtable)) +(ert-deftest test-try-completion-ignore-case () + (let ((completion-ignore-case t)) + (should (equal (try-completion "bar" '("bAr" "barfoo")) "bAr")) + (should (equal (try-completion "bar" '("bArfoo" "barbaz")) "bar")) + (should (equal (try-completion "bar" '("bArfoo" "barbaz")) + (try-completion "bar" '("barbaz" "bArfoo")))) + ;; bug#11339 + (should (equal (try-completion "baz" '("baz" "bAz")) "baz")) ;And not t! + (should (equal (try-completion "baz" '("bAz" "baz")) + (try-completion "baz" '("baz" "bAz")))))) + +(ert-deftest test-inhibit-interaction () + (let ((inhibit-interaction t)) + (should-error (read-from-minibuffer "foo: ") :type 'inhibited-interaction) + + (should-error (y-or-n-p "Foo?") :type 'inhibited-interaction) + (should-error (yes-or-no-p "Foo?") :type 'inhibited-interaction) + (should-error (read-no-blanks-input "foo: ") :type 'inhibited-interaction) + + ;; See that we get the expected error. + (should (eq (condition-case nil + (read-from-minibuffer "foo: ") + (inhibited-interaction 'inhibit) + (error nil)) + 'inhibit)))) + ;;; minibuf-tests.el ends here diff --git a/test/src/print-tests.el b/test/src/print-tests.el index b8f6c797dab..faab196f22f 100644 --- a/test/src/print-tests.el +++ b/test/src/print-tests.el @@ -1,32 +1,112 @@ ;;; print-tests.el --- tests for src/print.c -*- lexical-binding: t; -*- -;; Copyright (C) 2014-2017 Free Software Foundation, Inc. +;; Copyright (C) 2014-2022 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) -(ert-deftest print-hex-backslash () +;; Support sharing test code with cl-print-tests. + +(defalias 'print-tests--prin1-to-string #'identity + "The function to print to a string which is under test.") + +(defmacro print-tests--deftest (name arg &rest docstring-keys-and-body) + "Test both print.c and cl-print.el at once." + (declare (debug ert-deftest) + (doc-string 3) + (indent 2)) + (let ((clname (intern (concat (symbol-name name) "-cl-print"))) + (doc (when (stringp (car-safe docstring-keys-and-body)) + (list (pop docstring-keys-and-body)))) + (keys-and-values nil)) + (while (keywordp (car-safe docstring-keys-and-body)) + (let ((key (pop docstring-keys-and-body)) + (val (pop docstring-keys-and-body))) + (push val keys-and-values) + (push key keys-and-values))) + `(progn + ;; Set print-tests--prin1-to-string at both declaration and + ;; runtime, so that it can be used by the :expected-result + ;; keyword. + (cl-letf (((symbol-function #'print-tests--prin1-to-string) + #'prin1-to-string)) + (ert-deftest ,name ,arg + ,@doc + ,@keys-and-values + (cl-letf (((symbol-function #'print-tests--prin1-to-string) + #'prin1-to-string)) + ,@docstring-keys-and-body))) + (cl-letf (((symbol-function #'print-tests--prin1-to-string) + #'cl-prin1-to-string)) + (ert-deftest ,clname ,arg + ,@doc + ,@keys-and-values + (cl-letf (((symbol-function #'print-tests--prin1-to-string) + #'cl-prin1-to-string)) + ,@docstring-keys-and-body)))))) + +(print-tests--deftest print-hex-backslash () (should (string= (let ((print-escape-multibyte t) (print-escape-newlines t)) - (prin1-to-string "\u00A2\ff")) + (print-tests--prin1-to-string "\u00A2\ff")) "\"\\x00a2\\ff\""))) +(defun print-tests--prints-with-charset-p (ch odd-charset) + "Return t if print function being tested prints CH with the `charset' property. +CH is propertized with a `charset' value according to +ODD-CHARSET: if nil, then use the one returned by `char-charset', +otherwise, use a different charset." + (integerp + (string-match + "charset" + (print-tests--prin1-to-string + (propertize (string ch) + 'charset + (if odd-charset + (cl-find (char-charset ch) charset-list :test-not #'eq) + (char-charset ch))))))) + +(print-tests--deftest print-charset-text-property-nil () + :expected-result (if (eq (symbol-function #'print-tests--prin1-to-string) + #'cl-prin1-to-string) :failed :passed) + (let ((print-charset-text-property nil)) + (should-not (print-tests--prints-with-charset-p ?\xf6 t)) ; Bug#31376. + (should-not (print-tests--prints-with-charset-p ?a t)) + (should-not (print-tests--prints-with-charset-p ?\xf6 nil)) + (should-not (print-tests--prints-with-charset-p ?a nil)))) + +(print-tests--deftest print-charset-text-property-default () + :expected-result (if (eq (symbol-function #'print-tests--prin1-to-string) + #'cl-prin1-to-string) :failed :passed) + (let ((print-charset-text-property 'default)) + (should (print-tests--prints-with-charset-p ?\xf6 t)) + (should-not (print-tests--prints-with-charset-p ?a t)) + (should-not (print-tests--prints-with-charset-p ?\xf6 nil)) + (should-not (print-tests--prints-with-charset-p ?a nil)))) + +(print-tests--deftest print-charset-text-property-t () + (let ((print-charset-text-property t)) + (should (print-tests--prints-with-charset-p ?\xf6 t)) + (should (print-tests--prints-with-charset-p ?a t)) + (should (print-tests--prints-with-charset-p ?\xf6 nil)) + (should (print-tests--prints-with-charset-p ?a nil)))) + (ert-deftest terpri () (should (string= (with-output-to-string (princ 'abc) @@ -58,5 +138,411 @@ (buffer-string)) "--------\n")))) +(print-tests--deftest print-read-roundtrip () + (let ((syms (list '## '& '* '+ '- '/ '0E '0e '< '= '> 'E 'E0 'NaN '\" + '\# '\#x0 '\' '\'\' '\( '\) '\+00 '\, '\-0 '\. '\.0 + '\0 '\0.0 '\0E0 '\0e0 '\1E+ '\1E+NaN '\1e+ '\1e+NaN + '\; '\? '\[ '\\ '\] '\` '_ 'a 'e 'e0 'x + '{ '| '} '~ : '\’ '\’bar + (intern "\t") (intern "\n") (intern " ") + (intern "\N{NO-BREAK SPACE}") + (intern "\N{ZERO WIDTH SPACE}") + (intern "\0")))) + (dolist (sym syms) + (should (eq (read (print-tests--prin1-to-string sym)) sym)) + (dolist (sym1 syms) + (let ((sym2 (intern (concat (symbol-name sym) (symbol-name sym1))))) + (should (eq (read (print-tests--prin1-to-string sym2)) sym2))))))) + +(print-tests--deftest print-bignum () + (let* ((str "999999999999999999999999999999999") + (val (read str))) + (should (> val most-positive-fixnum)) + (should (equal (print-tests--prin1-to-string val) str)))) + +(print-tests--deftest print-tests-print-gensym () + "Printing observes `print-gensym'." + (let* ((sym1 (gensym)) + (syms (list sym1 (gensym "x") (make-symbol "y") sym1))) + (let* ((print-circle nil) + (printed-with (let ((print-gensym t)) + (print-tests--prin1-to-string syms))) + (printed-without (let ((print-gensym nil)) + (print-tests--prin1-to-string syms)))) + (should (string-match + "(#:\\(g[[:digit:]]+\\) #:x[[:digit:]]+ #:y #:\\(g[[:digit:]]+\\))$" + printed-with)) + (should (string= (match-string 1 printed-with) + (match-string 2 printed-with))) + (should (string-match "(g[[:digit:]]+ x[[:digit:]]+ y g[[:digit:]]+)$" + printed-without))) + (let* ((print-circle t) + (printed-with (let ((print-gensym t)) + (print-tests--prin1-to-string syms))) + (printed-without (let ((print-gensym nil)) + (print-tests--prin1-to-string syms)))) + (should (string-match "(#1=#:g[[:digit:]]+ #:x[[:digit:]]+ #:y #1#)$" + printed-with)) + (should (string-match "(g[[:digit:]]+ x[[:digit:]]+ y g[[:digit:]]+)$" + printed-without))))) + +(print-tests--deftest print-tests-continuous-numbering () + "Printing observes `print-continuous-numbering'." + ;; cl-print does not support print-continuous-numbering. + :expected-result (if (eq (symbol-function #'print-tests--prin1-to-string) + #'cl-prin1-to-string) + :failed :passed) + (let* ((x (list 1)) + (y "hello") + (g (gensym)) + (g2 (gensym)) + (print-circle t) + (print-gensym t)) + (let ((print-continuous-numbering t) + (print-number-table nil)) + (should (string-match + "(#1=(1) #1# #2=\"hello\" #2#)(#3=#:g[[:digit:]]+ #3#)(#1# #2# #3#)#2#$" + (mapconcat #'print-tests--prin1-to-string + `((,x ,x ,y ,y) (,g ,g) (,x ,y ,g) ,y))))) + + ;; This is the special case for byte-compile-output-docform + ;; mentioned in a comment in print_preprocess. When + ;; print-continuous-numbering and print-circle and print-gensym + ;; are all non-nil, print all gensyms with numbers even if they + ;; only occur once. + (let ((print-continuous-numbering t) + (print-number-table nil)) + (should (string-match + "(#1=#:g[[:digit:]]+ #2=#:g[[:digit:]]+)$" + (print-tests--prin1-to-string (list g g2))))))) + +(cl-defstruct print--test a b) + +(print-tests--deftest print-tests-1 () + "Test print code." + (let ((x (make-print--test :a 1 :b 2)) + (rec (cond + ((eq (symbol-function #'print-tests--prin1-to-string) 'prin1-to-string) + "#s(print--test 1 2)") + ((eq (symbol-function #'print-tests--prin1-to-string) 'cl-prin1-to-string) + "#s(print--test :a 1 :b 2)") + (t (cl-assert nil))))) + + (let ((print-circle nil)) + (should (equal (print-tests--prin1-to-string `((x . ,x) (y . ,x))) + (format "((x . %s) (y . %s))" rec rec)))) + (let ((print-circle t)) + (should (equal (print-tests--prin1-to-string `((x . ,x) (y . ,x))) + (format "((x . #1=%s) (y . #1#))" rec)))))) + +(print-tests--deftest print-tests-2 () + (let ((x (record 'foo 1 2 3))) + (should (equal + x + (car (read-from-string (with-output-to-string (prin1 x)))))) + (let ((print-circle t)) + (should (string-match + "\\`(#1=#s(foo 1 2 3) #1#)\\'" + (print-tests--prin1-to-string (list x x))))))) + +(cl-defstruct (print-tests-struct + (:constructor print-tests-con)) + a b c d e) + +(print-tests--deftest print-tests-3 () + "Printing observes `print-length'." + (let ((long-list (make-list 5 'a)) + (long-vec (make-vector 5 'b)) + ;; (long-struct (print-tests-con)) + ;; (long-string (make-string 5 ?a)) + (print-length 4)) + (should (equal "(a a a a ...)" (print-tests--prin1-to-string long-list))) + (should (equal "[b b b b ...]" (print-tests--prin1-to-string long-vec))) + ;; This one only prints 3 nils. Should it print 4? + ;; (should (equal "#s(print-tests-struct nil nil nil nil ...)" + ;; (print-tests--prin1-to-string long-struct))) + ;; This one is only supported by cl-print + ;; (should (equal "\"aaaa...\"" (cl-print-tests--prin1-to-string long-string))) + )) + +(print-tests--deftest print-tests-4 () + "Printing observes `print-level'." + (let* ((deep-list '(a (b (c (d (e)))))) + (buried-vector '(a (b (c (d [e]))))) + (deep-struct (print-tests-con)) + (buried-struct `(a (b (c (d ,deep-struct))))) + (buried-string '(a (b (c (d #("hello" 0 5 (print-test t))))))) + (buried-simple-string '(a (b (c (d "hello"))))) + (print-level 4)) + (setf (print-tests-struct-a deep-struct) deep-list) + (should (equal "(a (b (c (d ...))))" (print-tests--prin1-to-string deep-list))) + (should (equal "(a (b (c (d \"hello\"))))" + (print-tests--prin1-to-string buried-simple-string))) + (cond + ((eq (symbol-function #'print-tests--prin1-to-string) #'prin1-to-string) + (should (equal "(a (b (c (d [e]))))" (print-tests--prin1-to-string buried-vector))) + (should (equal "(a (b (c (d #s(print-tests-struct ... nil nil nil nil)))))" + (print-tests--prin1-to-string buried-struct))) + (should (equal "(a (b (c (d #(\"hello\" 0 5 ...)))))" + (print-tests--prin1-to-string buried-string))) + (should (equal "#s(print-tests-struct (a (b (c ...))) nil nil nil nil)" + (print-tests--prin1-to-string deep-struct)))) + + ((eq (symbol-function #'print-tests--prin1-to-string) #'cl-prin1-to-string) + (should (equal "(a (b (c (d ...))))" (print-tests--prin1-to-string buried-vector))) + (should (equal "(a (b (c (d ...))))" (print-tests--prin1-to-string buried-struct))) + (should (equal "(a (b (c (d ...))))" (print-tests--prin1-to-string buried-string))) + (should (equal "#s(print-tests-struct :a (a (b (c ...))) :b nil :c nil :d nil :e nil)" + (print-tests--prin1-to-string deep-struct)))) + (t (cl-assert nil))))) + +(print-tests--deftest print-tests-5 () + "Printing observes `print-quoted'." + (let ((quoted-stuff '('a #'b `(,c ,@d)))) + (let ((print-quoted t)) + (should (equal "('a #'b `(,c ,@d))" + (print-tests--prin1-to-string quoted-stuff)))) + (let ((print-quoted nil)) + (should (equal "((quote a) (function b) (\\` ((\\, c) (\\,@ d))))" + (print-tests--prin1-to-string quoted-stuff)))))) + +(print-tests--deftest print-tests-strings () + "Can print strings and propertized strings." + (let* ((str1 "abcdefghij") + (str2 #("abcdefghij" 3 6 (bold t) 7 9 (italic t))) + (str3 #("abcdefghij" 0 10 (test t))) + (obj '(a b)) + ;; Since the byte compiler reuses string literals, + ;; and the put-text-property call is destructive, use + ;; copy-sequence to make a new string. + (str4 (copy-sequence "abcdefghij"))) + (put-text-property 0 5 'test obj str4) + (put-text-property 7 10 'test obj str4) + + (should (equal "\"abcdefghij\"" (print-tests--prin1-to-string str1))) + (should (equal "#(\"abcdefghij\" 3 6 (bold t) 7 9 (italic t))" + (print-tests--prin1-to-string str2))) + (should (equal "#(\"abcdefghij\" 0 10 (test t))" + (print-tests--prin1-to-string str3))) + (let ((print-circle nil)) + (should + (equal + "#(\"abcdefghij\" 0 5 (test (a b)) 7 10 (test (a b)))" + (print-tests--prin1-to-string str4)))) + (let ((print-circle t)) + (should + (equal + "#(\"abcdefghij\" 0 5 (test #1=(a b)) 7 10 (test #1#))" + (print-tests--prin1-to-string str4)))))) + +(print-tests--deftest print-circle () + (let ((x '(#1=(a . #1#) #1#))) + (let ((print-circle nil)) + (should (string-match "\\`((a . #[0-9]) (a . #[0-9]))\\'" + (print-tests--prin1-to-string x)))) + (let ((print-circle t)) + (should (equal "(#1=(a . #1#) #1#)" (print-tests--prin1-to-string x)))))) + +(print-tests--deftest print-circle-2 () + ;; Bug#31146. + (let ((x '(0 . #1=(0 . #1#)))) + (let ((print-circle nil)) + (should (string-match "\\`(0\\( 0\\)* . #[0-9]+)\\'" + (print-tests--prin1-to-string x)))) + (let ((print-circle t)) + (should (equal "(0 . #1=(0 . #1#))" (print-tests--prin1-to-string x)))))) + +(print-tests--deftest error-message-string-circular () + (let ((err (list 'error))) + (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)")))) + +(ert-deftest test-unreadable () + (should (equal (prin1-to-string (make-marker)) "#<marker in no buffer>")) + (let ((print-unreadable-function + (lambda (_object _escape) + "hello"))) + (should (equal (prin1-to-string (make-marker)) "hello"))) + (let ((print-unreadable-function + (lambda (_object _escape) + t))) + (should (equal (prin1-to-string (make-marker)) "")))) + +(ert-deftest test-dots () + (should (equal (prin1-to-string 'foo.bar) "foo.bar")) + (should (equal (prin1-to-string '.foo) "\\.foo")) + (should (equal (prin1-to-string '.foo.) "\\.foo.")) + (should (equal (prin1-to-string 'bar?bar) "bar?bar")) + (should (equal (prin1-to-string '\?bar) "\\?bar")) + (should (equal (prin1-to-string '\?bar?) "\\?bar?"))) + +(ert-deftest test-prin1-overrides () + (with-temp-buffer + (let ((print-length 10)) + (prin1 (make-list 20 t) (current-buffer) t) + (should (= print-length 10))) + (goto-char (point-min)) + (should (= (length (read (current-buffer))) 20))) + + (with-temp-buffer + (let ((print-length 10)) + (prin1 (make-list 20 t) (current-buffer) '((length . 5))) + (should (= print-length 10))) + (goto-char (point-min)) + (should (= (length (read (current-buffer))) 6))) + + (with-temp-buffer + (let ((print-length 10)) + (prin1 (make-list 20 t) (current-buffer) '(t (length . 5))) + (should (= print-length 10))) + (goto-char (point-min)) + (should (= (length (read (current-buffer))) 6)))) + +(ert-deftest test-prin1-to-string-overrides () + (let ((print-length 10)) + (should + (= (length (car (read-from-string + (prin1-to-string (make-list 20 t) nil t)))) + 20))) + + (let ((print-length 10)) + (should + (= (length (car (read-from-string + (prin1-to-string (make-list 20 t) nil + '((length . 5)))))) + 6))) + + (should-error (prin1-to-string 'foo nil 'a)) + (should-error (prin1-to-string 'foo nil '(a))) + (should-error (prin1-to-string 'foo nil '(t . b))) + (should-error (prin1-to-string 'foo nil '(t b))) + (should-error (prin1-to-string 'foo nil '((a . b) b))) + (should-error (prin1-to-string 'foo nil '((length . 10) . b)))) + +(ert-deftest print-deeply-nested () + ;; Check that we can print a deeply nested data structure correctly. + (let ((print-circle t)) + (let ((levels 10000) + (x 'a) + (prefix nil) + (suffix nil)) + (dotimes (_ levels) + (setq x (list (vector (record 'r x)))) + (push "([#s(r " prefix) + (push ")])" suffix)) + (let ((expected (concat (apply #'concat prefix) + "a" + (apply #'concat suffix)))) + (should (equal (prin1-to-string x) expected)))))) + +(defun print-test-rho (lead loop) + "A circular iota list with LEAD elements followed by LOOP in circle." + (let ((l (number-sequence 1 (+ lead loop)))) + (setcdr (nthcdr (+ lead loop -1) l) (nthcdr lead l)) + l)) + +(ert-deftest print-circular () + ;; Check printing of rho-shaped circular lists such as (1 2 3 4 5 4 5 4 . #6) + ;; when `print-circle' is nil. The exact output may differ since the number + ;; of elements printed of the looping part can vary depending on when the + ;; circularity was detected. + (dotimes (lead 7) + (ert-info ((prin1-to-string lead) :prefix "lead: ") + (dolist (loop (number-sequence 1 7)) + (ert-info ((prin1-to-string loop) :prefix "loop: ") + (let* ((rho (print-test-rho lead loop)) + (print-circle nil) + (str (prin1-to-string rho))) + (should (string-match (rx "(" + (group (+ (+ digit) " ")) + ". #" (group (+ digit)) ")") + str)) + (let* ((g1 (match-string 1 str)) + (g2 (match-string 2 str)) + (numbers (mapcar #'string-to-number (split-string g1))) + (loopback-index (string-to-number g2))) + ;; Split the numbers in the lead and loop part. + (should (< lead (length numbers))) + (should (<= lead loopback-index)) + (should (< loopback-index (length numbers))) + (let ((lead-part (take lead numbers)) + (loop-part (nthcdr lead numbers))) + ;; The lead part must match exactly. + (should (equal lead-part (number-sequence 1 lead))) + ;; The loop part is at least LOOP long: make sure it matches. + (should (>= (length loop-part) loop)) + (let ((expected-loop-part + (mapcar (lambda (x) (+ lead 1 (% x loop))) + (number-sequence 0 (1- (length loop-part)))))) + (should (equal loop-part expected-loop-part)) + ;; The loopback index must match the length of the + ;; loop part. + (should (equal (% (- (length numbers) loopback-index) loop) + 0))))))))))) + +(ert-deftest test-print-unreadable-function-buffer () + (let* ((buffer nil) + (callback-buffer nil) + (str (with-temp-buffer + (setq buffer (current-buffer)) + (let ((print-unreadable-function + (lambda (_object _escape) + (setq callback-buffer (current-buffer)) + "tata"))) + (prin1-to-string (make-marker)))))) + (should (eq callback-buffer buffer)) + (should (equal str "tata")))) + (provide 'print-tests) ;;; print-tests.el ends here diff --git a/test/src/process-tests.el b/test/src/process-tests.el index b26f9391909..7d3d9eb72b8 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-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 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,61 +23,74 @@ ;;; Code: +(require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-directory +(require 'puny) +(require 'subr-x) +(require 'dns) +(require 'url-http) + +(declare-function thread-last-error "thread.c") +(declare-function thread-join "thread.c") +(declare-function make-thread "thread.c") ;; Timeout in seconds; the test fails if the timeout is reached. (defvar process-test-sentinel-wait-timeout 2.0) -;; Start a process that exits immediately. Call WAIT-FUNCTION, -;; possibly multiple times, to wait for the process to complete. -(defun process-test-sentinel-wait-function-working-p (wait-function) - (let ((proc (start-process "test" nil "bash" "-c" "exit 20")) +(defun process-test-wait-for-sentinel (proc exit-status &optional wait-function) + "Set a sentinel on PROC and wait for it to be called with EXIT-STATUS. +Call WAIT-FUNCTION, possibly multiple times, to wait for the +process to complete." + (let ((wait-function (or wait-function #'accept-process-output)) (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) process-test-sentinel-wait-timeout))) (funcall wait-function)) - (cl-assert (eq (process-status proc) 'exit)) - (cl-assert (= (process-exit-status proc) 20)) - sentinel-called)) + (should sentinel-called) + (should (eq (process-status proc) 'exit)) + (should (= (process-exit-status proc) exit-status)))) (ert-deftest process-test-sentinel-accept-process-output () (skip-unless (executable-find "bash")) - (should (process-test-sentinel-wait-function-working-p - #'accept-process-output))) + (with-timeout (60 (ert-fail "Test timed out")) + (let ((proc (start-process "test" nil "bash" "-c" "exit 20"))) + (should (process-test-wait-for-sentinel proc 20))))) (ert-deftest process-test-sentinel-sit-for () (skip-unless (executable-find "bash")) - (should - (process-test-sentinel-wait-function-working-p (lambda () (sit-for 0.01 t))))) + (with-timeout (60 (ert-fail "Test timed out")) + (let ((proc (start-process "test" nil "bash" "-c" "exit 20"))) + (should (process-test-wait-for-sentinel + proc 20 (lambda () (sit-for 0.01 t))))))) (when (eq system-type 'windows-nt) (ert-deftest process-test-quoted-batfile () "Check that Emacs hides CreateProcess deficiency (bug#18745)." - (let (batfile) - (unwind-protect - (progn - ;; CreateProcess will fail when both the bat file and 1st - ;; argument are quoted, so include spaces in both of those - ;; to force quoting. - (setq batfile (make-temp-file "echo args" nil ".bat")) - (with-temp-file batfile - (insert "@echo arg1=%1, arg2=%2\n")) - (with-temp-buffer - (call-process batfile nil '(t t) t "x &y") - (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))) - (with-temp-buffer - (call-process-shell-command - (mapconcat #'shell-quote-argument (list batfile "x &y") " ") - nil '(t t) t) - (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))) - (when batfile (delete-file batfile)))))) + (ert-with-temp-file batfile + ;; CreateProcess will fail when both the bat file and 1st + ;; argument are quoted, so include spaces in both of those + ;; to force quoting. + :prefix "echo args" + :suffix ".bat" + (with-temp-file batfile + (insert "@echo arg1=%1, arg2=%2\n")) + (with-temp-buffer + (call-process batfile nil '(t t) t "x &y") + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))) + (with-temp-buffer + (call-process-shell-command + (mapconcat #'shell-quote-argument (list batfile "x &y") " ") + nil '(t t) t) + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))))) (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" @@ -84,28 +99,19 @@ "echo hello stderr! >&2; " "exit 20")) :buffer stdout-buffer - :stderr stderr-buffer)) - (sentinel-called nil) - (start-time (float-time))) - (set-process-sentinel proc (lambda (proc msg) - (setq sentinel-called t))) - (while (not (or sentinel-called - (> (- (float-time) start-time) - process-test-sentinel-wait-timeout))) - (accept-process-output)) - (cl-assert (eq (process-status proc) 'exit)) - (cl-assert (= (process-exit-status proc) 20)) + :stderr stderr-buffer))) + (process-test-wait-for-sentinel proc 20) (should (with-current-buffer stdout-buffer (goto-char (point-min)) (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")) - (let* ((sentinel-called nil) - (stderr-sentinel-called nil) + (with-timeout (60 (ert-fail "Test timed out")) + (let* ((stderr-sentinel-called nil) (stdout-output nil) (stderr-output nil) (stdout-buffer (generate-new-buffer "*stdout*")) @@ -117,36 +123,62 @@ (concat "echo hello stdout!; " "echo hello stderr! >&2; " "exit 20")) - :stderr stderr-proc)) - (start-time (float-time))) - (set-process-filter proc (lambda (proc input) + :stderr stderr-proc))) + (set-process-filter proc (lambda (_proc input) (push input stdout-output))) - (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) - process-test-sentinel-wait-timeout))) - (accept-process-output)) - (cl-assert (eq (process-status proc) 'exit)) - (cl-assert (= (process-exit-status proc) 20)) - (should sentinel-called) + (process-test-wait-for-sentinel proc 20) (should (equal 1 (with-current-buffer stdout-buffer (point-max)))) (should (equal "hello stdout!\n" - (mapconcat #'identity (nreverse stdout-output) ""))) + (mapconcat #'identity (nreverse stdout-output)))) (should stderr-sentinel-called) (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) + (proc (start-process + "test proc" (current-buffer) + (concat invocation-directory invocation-name) + "-Q" "--batch" "--eval" + (prin1-to-string + '(let ((s nil) (count 0)) + (while (setq s (read-from-minibuffer + (format "%d> " count))) + (princ s) + (princ "\n") + (setq count (1+ count)))))))) + (set-process-query-on-exit-flag proc nil) + (send-string proc "one\n") + (while (not (equal (buffer-substring (pos-bol) (point-max)) + "1> ")) + (accept-process-output proc)) ; Read "one". + (should (equal (buffer-string) "0> one\n1> ")) + (set-process-filter proc t) ; Stop reading from proc. + (send-string proc "two\n") + (should-not + (accept-process-output proc 1)) ; Can't read "two" yet. + (should (equal (buffer-string) "0> one\n1> ")) + (set-process-filter proc nil) ; Resume reading from proc. + (while (not (equal (buffer-substring (pos-bol) (point-max)) + "2> ")) + (accept-process-output proc)) ; Read "Two". + (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. @@ -160,7 +192,832 @@ (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" + :command '("sleep" "1h") + :noquery t + :connection-type 'pipe + :stderr (current-buffer)))) + (unwind-protect + (let ((new-processes (cl-set-difference (process-list) + previous-processes + :test #'eq))) + (should new-processes) + (dolist (process new-processes) + (should-not (process-query-on-exit-flag process)))) + (kill-process process)))))) + +;; Return t if OUTPUT could have been generated by merging the INPUTS somehow. +(defun process-tests--mixable (output &rest inputs) + (while (and output (let ((ins inputs)) + (while (and ins (not (eq (car (car ins)) (car output)))) + (setq ins (cdr ins))) + (if ins + (setcar ins (cdr (car ins)))) + ins)) + (setq output (cdr output))) + (not (apply #'append output inputs))) + +(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"))) + (with-temp-buffer + (let ((process (make-process + :name "mix-stderr" + :command (list "bash" "-c" + "echo stdout && echo stderr >&2") + :buffer (current-buffer) + :sentinel #'ignore + :noquery t + :connection-type 'pipe))) + (while (or (accept-process-output process) + (process-live-p process))) + (should (eq (process-status process) 'exit)) + (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"))))))) + +(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 _) + (setq have-called-debugger t) + ;; Allow entering the debugger later in the same + ;; test run, before going back to the command + ;; loop. + (setq internal-when-entered-debugger -1)))) + (should (eq :got-error ;; NOTE: `should-error' would inhibit debugger. + (condition-case-unless-debug () + ;; Emacs doesn't search for absolute filenames, so + ;; the error will be hit in the w32 process spawn + ;; code. + (make-process :name "test" :command '("c:/No-Such-Command")) + (error :got-error)))) + (should have-called-debugger)))) + +(defun make-process/test-connection-type (ttys &rest args) + "Make a process and check whether its standard streams match TTYS. +This calls `make-process', passing ARGS to adjust how the process +is created. TTYS should be a list of 3 boolean values, +indicating whether the subprocess's stdin, stdout, and stderr +should be a TTY, respectively." + (declare (indent 1)) + (let* (;; MS-Windows doesn't support communicating via pty. + (ttys (if (eq system-type 'windows-nt) '(nil nil nil) ttys)) + (expected-output (concat (and (nth 0 ttys) "stdin\n") + (and (nth 1 ttys) "stdout\n") + (and (nth 2 ttys) "stderr\n"))) + (stdout-buffer (generate-new-buffer "*stdout*")) + (proc (apply + #'make-process + :name "test" + :command (list "sh" "-c" + (concat "if [ -t 0 ]; then echo stdin; fi; " + "if [ -t 1 ]; then echo stdout; fi; " + "if [ -t 2 ]; then echo stderr; fi")) + :buffer stdout-buffer + args))) + (should (eq (and (process-tty-name proc 'stdin) t) (nth 0 ttys))) + (should (eq (and (process-tty-name proc 'stdout) t) (nth 1 ttys))) + (should (eq (and (process-tty-name proc 'stderr) t) (nth 2 ttys))) + (process-test-wait-for-sentinel proc 0) + (should (equal (with-current-buffer stdout-buffer (buffer-string)) + expected-output)))) + +(ert-deftest make-process/connection-type/pty () + (skip-unless (executable-find "sh")) + (make-process/test-connection-type '(t t t) + :connection-type 'pty)) + +(ert-deftest make-process/connection-type/pty-2 () + (skip-unless (executable-find "sh")) + (make-process/test-connection-type '(t t t) + :connection-type '(pty . pty))) + +(ert-deftest make-process/connection-type/pipe () + (skip-unless (executable-find "sh")) + (make-process/test-connection-type '(nil nil nil) + :connection-type 'pipe)) + +(ert-deftest make-process/connection-type/pipe-2 () + (skip-unless (executable-find "sh")) + (make-process/test-connection-type '(nil nil nil) + :connection-type '(pipe . pipe))) + +(ert-deftest make-process/connection-type/in-pty () + (skip-unless (executable-find "sh")) + (make-process/test-connection-type '(t nil nil) + :connection-type '(pty . pipe))) + +(ert-deftest make-process/connection-type/out-pty () + (skip-unless (executable-find "sh")) + (make-process/test-connection-type '(nil t t) + :connection-type '(pipe . pty))) + +(ert-deftest make-process/connection-type/pty-with-stderr-buffer () + (skip-unless (executable-find "sh")) + (let ((stderr-buffer (generate-new-buffer "*stderr*"))) + (make-process/test-connection-type '(t t nil) + :connection-type 'pty :stderr stderr-buffer))) + +(ert-deftest make-process/connection-type/out-pty-with-stderr-buffer () + (skip-unless (executable-find "sh")) + (let ((stderr-buffer (generate-new-buffer "*stderr*"))) + (make-process/test-connection-type '(nil t nil) + :connection-type '(pipe . pty) :stderr stderr-buffer))) + +(ert-deftest make-process/file-handler/found () + "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) + (should (equal default-directory "test-handler:/dir/")) + (should (equal args '(make-process :name "name" + :command ("/some/binary") + :file-handler t))) + (cl-incf file-handler-calls) + 'fake-process)) + (let ((file-name-handler-alist (list (cons (rx bos "test-handler:") + #'file-handler))) + (default-directory "test-handler:/dir/")) + (should (eq (make-process :name "name" + :command '("/some/binary") + :file-handler t) + 'fake-process)) + (should (= file-handler-calls 1))))))) + +(ert-deftest make-process/file-handler/not-found () + "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)))))) + +(ert-deftest make-process/file-handler/disable () + "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"))))))) + +(defun process-tests--file-handler (operation &rest _args) + (cl-ecase operation + (unhandled-file-name-directory "/") + (make-process (ert-fail "file name handler called unexpectedly")))) + +(put #'process-tests--file-handler 'operations + '(unhandled-file-name-directory make-process)) + +(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)))) + +;; The following tests require working DNS + +;; This will need updating when IANA assign more IPv6 global ranges. +(defun ipv6-is-available () + (and (featurep 'make-network-process '(:family ipv6)) + (cl-rassoc-if + (lambda (elt) + (and (eq 9 (length elt)) + (= (logand (aref elt 0) #xe000) #x2000))) + (network-interface-list)))) + +;; Check if the Internet seems to be working. Mainly to pacify +;; Debian's CI system. +(defvar internet-is-working + (progn + (require 'dns) + (dns-query "google.com"))) + +(ert-deftest lookup-family-specification () + "`network-lookup-address-info' should only accept valid family symbols." + (skip-unless internet-is-working) + (with-timeout (60 (ert-fail "Test timed out")) + (should-error (network-lookup-address-info "localhost" 'both)) + (should (network-lookup-address-info "localhost" 'ipv4)) + (when (ipv6-is-available) + (should (network-lookup-address-info "localhost" 'ipv6))))) + +(ert-deftest lookup-hints-specification () + "`network-lookup-address-info' should only accept valid hints arg." + (should-error (network-lookup-address-info "1.1.1.1" nil t)) + (should-error (network-lookup-address-info "1.1.1.1" 'ipv4 t)) + (should (network-lookup-address-info "1.1.1.1" nil 'numeric)) + (should (network-lookup-address-info "1.1.1.1" 'ipv4 'numeric)) + (when (ipv6-is-available) + (should-error (network-lookup-address-info "::1" nil t)) + (should-error (network-lookup-address-info "::1" 'ipv6 't)) + (should (network-lookup-address-info "::1" nil 'numeric)) + (should (network-lookup-address-info "::1" 'ipv6 'numeric)))) + +(ert-deftest lookup-hints-values () + "`network-lookup-address-info' should succeed/fail in looking up various numeric IP addresses." + (let ((ipv4-invalid-addrs + '("localhost" "343.1.2.3" "1.2.3.4.5")) + ;; These are valid for IPv4 but invalid for IPv6 + (ipv4-addrs + '("127.0.0.1" "127.0.1" "127.1" "127" "1" "0" + "0xe3010203" "0xe3.1.2.3" "227.0x1.2.3" + "034300201003" "0343.1.2.3" "227.001.2.3")) + (ipv6-only-invalid-addrs + '("fe80:1" "e301:203:1" "e301::203::1" + "1:2:3:4:5:6:7:8:9" "0xe301:203::1" + "343:10001:2::3" + ;; "00343:1:2::3" is invalid on GNU/Linux and FreeBSD, but + ;; valid on macOS. macOS is wrong here, but such is life. + )) + ;; These are valid for IPv6 but invalid for IPv4 + (ipv6-addrs + '("fe80::1" "e301::203:1" "e301:203::1" + "e301:0203::1" "::1" "::0" + "0343:1:2::3" "343:001:2::3"))) + (dolist (a ipv4-invalid-addrs) + (should-not (network-lookup-address-info a nil 'numeric)) + (should-not (network-lookup-address-info a 'ipv4 'numeric))) + (dolist (a ipv6-addrs) + (should-not (network-lookup-address-info a 'ipv4 'numeric))) + (dolist (a ipv4-addrs) + (should (network-lookup-address-info a nil 'numeric)) + (should (network-lookup-address-info a 'ipv4 'numeric))) + (when (ipv6-is-available) + (dolist (a ipv4-addrs) + (should-not (network-lookup-address-info a 'ipv6 'numeric))) + (dolist (a ipv6-only-invalid-addrs) + (should-not (network-lookup-address-info a 'ipv6 'numeric))) + (dolist (a ipv6-addrs) + (should (network-lookup-address-info a nil 'numeric)) + (should (network-lookup-address-info a 'ipv6 'numeric)) + (should (network-lookup-address-info (upcase a) nil 'numeric)) + (should (network-lookup-address-info (upcase a) 'ipv6 'numeric)))))) + +(ert-deftest lookup-unicode-domains () + "Unicode domains should fail." + (skip-unless internet-is-working) + (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"))))) + +(ert-deftest unibyte-domain-name () + "Unibyte domain names should work." + (skip-unless internet-is-working) + (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." + (skip-unless internet-is-working) + (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 (and (ipv6-is-available) + (dns-query "google.com" 'AAAA)) + (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 internet-is-working) + (with-timeout (60 (ert-fail "Test timed out")) + (should (eq nil (network-lookup-address-info "emacs.invalid"))))) + +;; End of tests requiring DNS + +(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))))) + +;; 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 ((cat (executable-find "cat"))) + (skip-unless cat) + (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 cat) + :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) + ;; The process now should either be running, or have + ;; already failed before `exec'. + (should (memq (process-status process) '(run exit))) + (when (process-live-p process) + (process-send-eof process)) + (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))) + ;; Avoid hang due to connect/accept handshake on Cygwin (bug#49496). + (skip-unless (not (eq system-type 'cygwin))) + (with-timeout (60 (ert-fail "Test timed out")) + (ert-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)." + ;; This test cannot be run if PTYs aren't supported. + (skip-unless (not (eq system-type 'windows-nt))) + (with-timeout (60 (ert-fail "Test timed out")) + (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 ((sleep (executable-find "sleep")) + (tty-names ())) + (skip-unless sleep) + (dotimes (i 10) + (let* ((host (make-process :name (format "tty host %d" i) + :command (list sleep "60") + :buffer nil + :coding 'utf-8-unix + :connection-type 'pty + :noquery t)) + (tty-name (process-tty-name host))) + (should (processp host)) + (push host processes) + ;; FIXME: The assumption below that using :connection 'pty + ;; in make-process necessarily produces a process with PTY + ;; connection is unreliable and non-portable. + ;; make-process can legitimately and silently fall back on + ;; pipes if allocating a PTY fails (and on MS-Windows it + ;; always fails). The following code also assumes that + ;; process-tty-name produces a file name that can be + ;; passed to 'stat' and to make-serial-process, which is + ;; also non-portable. + (should tty-name) + (should (file-exists-p tty-name)) + (should-not (member tty-name tty-names)) + (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) + +(ert-deftest process-tests/sentinel-called () + "Check that sentinels are called after processes finish." + (let ((command (process-tests--emacs-command))) + (skip-unless command) + (dolist (conn-type '(pipe pty)) + (ert-info ((format "Connection type: %s" conn-type)) + (process-tests--with-processes processes + (let* ((calls ()) + (process (make-process + :name "echo" + :command (process-tests--eval + command '(print "first")) + :noquery t + :connection-type conn-type + :coding 'utf-8-unix + :sentinel (lambda (process message) + (push (list process message) + calls))))) + (push process processes) + (while (accept-process-output process)) + (should (equal calls + (list (list process "finished\n")))))))))) + +(ert-deftest process-tests/sentinel-with-multiple-processes () + "Check that sentinels are called in time even when other processes +have written output." + (let ((command (process-tests--emacs-command))) + (skip-unless command) + (dolist (conn-type '(pipe pty)) + (ert-info ((format "Connection type: %s" conn-type)) + (process-tests--with-processes processes + (let* ((calls ()) + (process (make-process + :name "echo" + :command (process-tests--eval + command '(print "first")) + :noquery t + :connection-type conn-type + :coding 'utf-8-unix + :sentinel (lambda (process message) + (push (list process message) + calls))))) + (push process processes) + (push (make-process + :name "bash" + :command (process-tests--eval + command + '(progn (sleep-for 10) (print "second"))) + :noquery t + :connection-type conn-type) + processes) + (while (accept-process-output process)) + (should (equal calls + (list (list process "finished\n")))))))))) + +(ert-deftest process-tests/multiple-threads-waiting () + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) + (skip-unless (fboundp 'make-thread)) + (with-timeout (60 (ert-fail "Test timed out")) + (process-tests--with-processes processes + (let ((threads ()) + (cat (executable-find "cat"))) + (skip-unless cat) + (dotimes (i 10) + (let* ((name (format "test %d" i)) + (process (make-process :name name + :command (list cat) + :coding 'no-conversion + :noquery t + :connection-type 'pipe))) + (push process processes) + (set-process-thread process nil) + (push (make-thread + (lambda () + (while (accept-process-output process))) + name) + threads))) + (mapc #'process-send-eof processes) + (cl-loop for process in processes + and thread in threads + do + (should-not (thread-join thread)) + (should-not (thread-last-error)) + (should (eq (process-status process) 'exit)) + (should (eql (process-exit-status process) 0))))))) + +(defun process-tests--eval (command form) + "Return a command that evaluates FORM in an Emacs subprocess. +COMMAND must be a list returned by +`process-tests--emacs-command'." + (let ((print-gensym t) + (print-circle t) + (print-length nil) + (print-level nil) + (print-escape-control-characters t) + (print-escape-newlines t) + (print-escape-multibyte t) + (print-escape-nonascii t)) + `(,@command "--quick" "--batch" ,(format "--eval=%S" form)))) + +(defun process-tests--emacs-command () + "Return a command to reinvoke the current Emacs instance. +Return nil if that doesn't appear to be possible." + (when-let ((binary (process-tests--emacs-binary)) + (dump (process-tests--dump-file))) + (cons binary + (unless (eq dump :not-needed) + (list (concat "--dump-file=" + (file-name-unquote dump))))))) + +(defun process-tests--emacs-binary () + "Return the filename of the currently running Emacs binary. +Return nil if that can't be determined." + (and (stringp invocation-name) + (not (file-remote-p invocation-name)) + (not (file-name-absolute-p invocation-name)) + (stringp invocation-directory) + (not (file-remote-p invocation-directory)) + (file-name-absolute-p invocation-directory) + (when-let ((file (process-tests--usable-file-for-reinvoke + (expand-file-name invocation-name + invocation-directory)))) + (and (file-executable-p file) file)))) + +(defun process-tests--dump-file () + "Return the filename of the dump file used to start Emacs. +Return nil if that can't be determined. Return `:not-needed' if +Emacs wasn't started with a dump file." + (if-let ((stats (and (fboundp 'pdumper-stats) (pdumper-stats)))) + (when-let ((file (process-tests--usable-file-for-reinvoke + (cdr (assq 'dump-file-name stats))))) + (and (file-readable-p file) file)) + :not-needed)) + +(defun process-tests--usable-file-for-reinvoke (filename) + "Return a version of FILENAME that can be used to reinvoke Emacs. +Return nil if FILENAME doesn't exist." + (when (and (stringp filename) + (not (file-remote-p filename))) + (cl-callf file-truename filename) + (and (stringp filename) + (not (file-remote-p filename)) + (file-name-absolute-p filename) + (file-regular-p filename) + filename))) + +;; Bug#46284 +(ert-deftest process-sentinel-interrupt-event () + "Test that interrupting a process on Windows sends \"interrupt\" to sentinel." + (skip-unless (eq system-type 'windows-nt)) + (with-temp-buffer + (let* ((proc-buf (current-buffer)) + ;; Start a new emacs process to wait idly until interrupted. + (cmd "emacs -batch --eval=\"(sit-for 50000)\"") + (proc (start-file-process-shell-command + "test/process-sentinel-signal-event" proc-buf cmd)) + (events '())) + + ;; Capture any incoming events. + (set-process-sentinel proc + (lambda (_prc event) + (push event events))) + ;; Wait for the process to start. + (sleep-for 2) + (should (equal 'run (process-status proc))) + ;; Interrupt the sub-process and wait for it to die. + (interrupt-process proc) + (sleep-for 2) + ;; Should have received SIGINT... + (should (equal 'signal (process-status proc))) + (should (equal 2 (process-exit-status proc))) + ;; ...and the change description should be "interrupt". + (should (equal '("interrupt\n") events))))) + +(ert-deftest process-num-processors () + "Sanity checks for num-processors." + (should (equal (num-processors) (num-processors))) + (should (integerp (num-processors))) + (should (< 0 (num-processors)))) (provide 'process-tests) -;; process-tests.el ends here. +;;; process-tests.el ends here diff --git a/test/src/regex-tests.el b/test/src/regex-emacs-tests.el index b1f1ea71cef..ff0d6be3f5d 100644 --- a/test/src/regex-tests.el +++ b/test/src/regex-emacs-tests.el @@ -1,6 +1,6 @@ -;;; regex-tests.el --- tests for regex.c functions -*- lexical-binding: t -*- +;;; regex-emacs-tests.el --- tests for regex-emacs.c -*- lexical-binding: t -*- -;; Copyright (C) 2015-2017 Free Software Foundation, Inc. +;; Copyright (C) 2015-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -24,16 +24,16 @@ (defvar regex-tests--resources-dir (concat (concat (file-name-directory (or load-file-name buffer-file-name)) "/regex-resources/")) - "Path to regex-resources directory next to the \"regex-tests.el\" file.") + "Path to regex-resources directory next to the \"regex-emacs-tests.el\" file.") (ert-deftest regex-word-cc-fallback-test () - "Test that ‘[[:cc:]]*x’ matches ‘x’ (bug#24020). + "Test that \"[[:cc:]]*x\" matches \"x\" (bug#24020). Test that a regex of the form \"[[:cc:]]*x\" where CC is a character class which matches a multibyte character X, matches string \"x\". -For example, ‘[[:word:]]*\u2620’ regex (note: \u2620 is a word +For example, \"[[:word:]]*\u2620\" regex (note: \u2620 is a word character) must match a string \"\u2420\"." (dolist (class '("[[:word:]]" "\\sw")) (dolist (repeat '("*" "+")) @@ -157,18 +157,18 @@ are known failures, and are skipped." (defun regex-tests-compare (string what-failed bounds-ref &optional substring-ref) "I just ran a search, looking at STRING. WHAT-FAILED describes -what failed, if anything; valid values are 'search-failed, -'compilation-failed and nil. I compare the beginning/end of each +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. If the search was supposed to fail then start-ref0/substring-ref0 -is 'search-failed. If the search wasn't even supposed to compile +is `search-failed'. If the search wasn't even supposed to compile successfully, then start-ref0/substring-ref0 is -'compilation-failed. If I only care about a match succeeding, +`compilation-failed'. If I only care about a match succeeding, this can be set to t. This function returns a string that describes the failure, or nil @@ -259,8 +259,8 @@ BOUNDS-REF is a sequence [start-ref0 end-ref0 start-ref1 end-ref1 ....]. If the search was supposed to fail then start-ref0 is -'search-failed. If the search wasn't even supposed to compile -successfully, then start-ref0 is 'compilation-failed. +`search-failed'. If the search wasn't even supposed to compile +successfully, then start-ref0 is `compilation-failed'. This function returns a string that describes the failure, or nil on success" @@ -278,12 +278,12 @@ on success" (defconst regex-tests-re-even-escapes - "\\(?:^\\|[^\\\\]\\)\\(?:\\\\\\\\\\)*" - "Regex that matches an even number of \\ characters") + "\\(?:^\\|[^\\]\\)\\(?:\\\\\\\\\\)*" + "Regex that matches an even number of \\ characters.") (defconst regex-tests-re-odd-escapes (concat regex-tests-re-even-escapes "\\\\") - "Regex that matches an odd number of \\ characters") + "Regex that matches an odd number of \\ characters.") (defun regex-tests-unextend (pattern) @@ -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) @@ -396,9 +396,9 @@ pattern)" ;; emacs matches non-greedy regex ab.*? non-greedily 639 677 712 ] - "Line numbers in the boost test that should be skipped. These -are false-positive test failures that represent known/benign -differences in behavior.") + "Line numbers in the boost test that should be skipped. +These are false-positive test failures that represent +known/benign differences in behavior.") ;; - Format ;; - Comments are lines starting with ; @@ -480,9 +480,9 @@ differences in behavior.") ;; ambiguous groupings are ambiguous 610 611 1154 1157 1160 1168 1171 1176 1179 1182 1185 1188 1193 1196 1203 ] - "Line numbers in the PCRE test that should be skipped. These -are false-positive test failures that represent known/benign -differences in behavior.") + "Line numbers in the PCRE test that should be skipped. +These are false-positive test failures that represent +known/benign differences in behavior.") ;; - Format ;; @@ -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)))) @@ -555,16 +555,16 @@ differences in behavior.") (defconst regex-tests-PTESTS-whitelist [ - ;; emacs doesn't barf on weird ranges such as [b-a], but simply - ;; fails to match + ;; emacs doesn't see DEL (0x7f) as a [:cntrl:] character 138 - ;; emacs doesn't see DEL (0x78) as a [:cntrl:] character + ;; emacs doesn't barf on weird ranges such as [b-a], but simply + ;; fails to match 168 ] - "Line numbers in the PTESTS test that should be skipped. These -are false-positive test failures that represent known/benign -differences in behavior.") + "Line numbers in the PTESTS test that should be skipped. +These are false-positive test failures that represent +known/benign differences in behavior.") ;; - Format ;; - fields separated by ¦ (note: this is not a |) @@ -621,9 +621,9 @@ differences in behavior.") ;; emacs is more stringent with regexes involving unbalanced ) 67 ] - "Line numbers in the TESTS test that should be skipped. These -are false-positive test failures that represent known/benign -differences in behavior.") + "Line numbers in the TESTS test that should be skipped. +These are false-positive test failures that represent +known/benign differences in behavior.") ;; - Format ;; - fields separated by :. Watch for [\[:xxx:]] @@ -677,4 +677,194 @@ This evaluates the PTESTS test cases from glibc." This evaluates the TESTS test cases from glibc." (should-not (regex-tests-TESTS))) -;;; regex-tests.el ends here +(ert-deftest regex-repeat-limit () + "Test the #xFFFF repeat limit." + (should (string-match "\\`x\\{65535\\}" (make-string 65535 ?x))) + (should-not (string-match "\\`x\\{65535\\}" (make-string 65534 ?x))) + (should-error (string-match "\\`x\\{65536\\}" "X") :type 'invalid-regexp)) + +(ert-deftest regexp-unibyte-unibyte () + "Test matching a unibyte regexp against a unibyte string." + ;; Sanity check + (should-not (multibyte-string-p "ab")) + (should-not (multibyte-string-p "\xff")) + ;; ASCII + (should (string-match "a[b]" "ab")) + ;; Raw + (should (string-match "\xf1" "\xf1")) + (should-not (string-match "\xf1" "\xc1\xb1")) + ;; Raw, char alt + (should (string-match "[\xf1]" "\xf1")) + (should-not (string-match "[\xf1]" "\xc1\xb1")) + ;; Raw range + (should (string-match "[\x82-\xd3]" "\xbb")) + (should-not (string-match "[\x82-\xd3]" "a")) + (should-not (string-match "[\x82-\xd3]" "\x81")) + (should-not (string-match "[\x82-\xd3]" "\xd4")) + ;; ASCII-raw range + (should (string-match "[f-\xd3]" "q")) + (should (string-match "[f-\xd3]" "\xbb")) + (should-not (string-match "[f-\xd3]" "e")) + (should-not (string-match "[f-\xd3]" "\xd4"))) + +(ert-deftest regexp-multibyte-multibyte () + "Test matching a multibyte regexp against a multibyte string." + ;; Sanity check + (should (multibyte-string-p "åü")) + ;; ASCII + (should (string-match (string-to-multibyte "a[b]") + (string-to-multibyte "ab"))) + ;; Unicode + (should (string-match "å[ü]z" "åüz")) + (should-not (string-match "ü" (string-to-multibyte "\xc3\xbc"))) + ;; Raw + (should (string-match (string-to-multibyte "\xf1") + (string-to-multibyte "\xf1"))) + (should-not (string-match (string-to-multibyte "\xf1") + (string-to-multibyte "\xc1\xb1"))) + (should-not (string-match (string-to-multibyte "\xc1\xb1") + (string-to-multibyte "\xf1"))) + ;; Raw, char alt + (should (string-match (string-to-multibyte "[\xf1]") + (string-to-multibyte "\xf1"))) + ;; Raw range + (should (string-match (string-to-multibyte "[\x82-\xd3]") + (string-to-multibyte "\xbb"))) + (should-not (string-match (string-to-multibyte "[\x82-\xd3]") "a")) + (should-not (string-match (string-to-multibyte "[\x82-\xd3]") "Å")) + (should-not (string-match (string-to-multibyte "[\x82-\xd3]") "ü")) + (should-not (string-match (string-to-multibyte "[\x82-\xd3]") "\x81")) + (should-not (string-match (string-to-multibyte "[\x82-\xd3]") "\xd4")) + ;; ASCII-raw range: should exclude U+0100..U+10FFFF + (should (string-match (string-to-multibyte "[f-\xd3]") + (string-to-multibyte "q"))) + (should (string-match (string-to-multibyte "[f-\xd3]") + (string-to-multibyte "\xbb"))) + (should-not (string-match (string-to-multibyte "[f-\xd3]") "e")) + (should-not (string-match (string-to-multibyte "[f-\xd3]") "Å")) + (should-not (string-match (string-to-multibyte "[f-\xd3]") "ü")) + (should-not (string-match (string-to-multibyte "[f-\xd3]") "\xd4")) + ;; Unicode-raw range: should be empty + (should-not (string-match "[å-\xd3]" "å")) + (should-not (string-match "[å-\xd3]" (string-to-multibyte "\xd3"))) + (should-not (string-match "[å-\xd3]" (string-to-multibyte "\xbb"))) + (should-not (string-match "[å-\xd3]" "ü")) + ;; No equivalence between raw bytes and latin-1 + (should-not (string-match "å" (string-to-multibyte "\xe5"))) + (should-not (string-match "[å]" (string-to-multibyte "\xe5"))) + (should-not (string-match "\xe5" "å")) + (should-not (string-match "[\xe5]" "å"))) + +(ert-deftest regexp-unibyte-multibyte () + "Test matching a unibyte regexp against a multibyte string." + ;; ASCII + (should (string-match "a[b]" (string-to-multibyte "ab"))) + ;; Unicode + (should (string-match "a.[^b]c" (string-to-multibyte "aåüc"))) + ;; Raw + (should (string-match "\xf1" (string-to-multibyte "\xf1"))) + (should-not (string-match "\xc1\xb1" (string-to-multibyte "\xf1"))) + ;; Raw, char alt + (should (string-match "[\xf1]" (string-to-multibyte "\xf1"))) + (should-not (string-match "[\xc1][\xb1]" (string-to-multibyte "\xf1"))) + ;; ASCII-raw range: should exclude U+0100..U+10FFFF + (should (string-match "[f-\xd3]" (string-to-multibyte "q"))) + (should (string-match "[f-\xd3]" (string-to-multibyte "\xbb"))) + (should-not (string-match "[f-\xd3]" "e")) + (should-not (string-match "[f-\xd3]" "Å")) + (should-not (string-match "[f-\xd3]" "ü")) + (should-not (string-match "[f-\xd3]" "\xd4")) + ;; No equivalence between raw bytes and latin-1 + (should-not (string-match "\xe5" "å")) + (should-not (string-match "[\xe5]" "å"))) + +(ert-deftest regexp-multibyte-unibyte () + "Test matching a multibyte regexp against a unibyte string." + ;; ASCII + (should (string-match (string-to-multibyte "a[b]") "ab")) + ;; Unicode + (should (string-match "a[^ü]c" "abc")) + (should-not (string-match "ü" "\xc3\xbc")) + ;; Raw + (should (string-match (string-to-multibyte "\xf1") "\xf1")) + (should-not (string-match (string-to-multibyte "\xf1") "\xc1\xb1")) + ;; Raw, char alt + (should (string-match (string-to-multibyte "[\xf1]") "\xf1")) + (should-not (string-match (string-to-multibyte "[\xf1]") "\xc1\xb1")) + ;; ASCII-raw range: should exclude U+0100..U+10FFFF + (should (string-match (string-to-multibyte "[f-\xd3]") "q")) + (should (string-match (string-to-multibyte "[f-\xd3]") "\xbb")) + (should-not (string-match (string-to-multibyte "[f-\xd3]") "e")) + (should-not (string-match (string-to-multibyte "[f-\xd3]") "\xd4")) + ;; Unicode-raw range: should be empty + (should-not (string-match "[å-\xd3]" "\xd3")) + (should-not (string-match "[å-\xd3]" "\xbb")) + ;; No equivalence between raw bytes and latin-1 + (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/search-tests.el b/test/src/search-tests.el new file mode 100644 index 00000000000..2fa23842841 --- /dev/null +++ b/test/src/search-tests.el @@ -0,0 +1,42 @@ +;;; search-tests.el --- tests for search.c functions -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2016, 2018-2022 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) + +(ert-deftest test-replace-match-modification-hooks () + (let ((ov-set nil)) + (with-temp-buffer + (insert "1 abc") + (setq ov-set (make-overlay 3 5)) + (overlay-put + ov-set 'modification-hooks + (list (lambda (_o after &rest _args) + (when after + (let ((inhibit-modification-hooks t)) + (save-excursion + (goto-char 2) + (insert "234"))))))) + (goto-char 3) + (if (search-forward "bc") + (replace-match "bcd")) + (should (= (point) 10))))) + +;;; search-tests.el ends here diff --git a/test/src/sqlite-tests.el b/test/src/sqlite-tests.el new file mode 100644 index 00000000000..5af43923012 --- /dev/null +++ b/test/src/sqlite-tests.el @@ -0,0 +1,244 @@ +;;; sqlite-tests.el --- Tests for sqlite.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 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/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'ert-x) + +(declare-function sqlite-execute "sqlite.c") +(declare-function sqlite-close "sqlite.c") +(declare-function sqlitep "sqlite.c") +(declare-function sqlite-available-p "sqlite.c") +(declare-function sqlite-finalize "sqlite.c") +(declare-function sqlite-next "sqlite.c") +(declare-function sqlite-more-p "sqlite.c") +(declare-function sqlite-select "sqlite.c") +(declare-function sqlite-open "sqlite.c") +(declare-function sqlite-load-extension "sqlite.c") + +(ert-deftest sqlite-select () + (skip-unless (sqlite-available-p)) + (let ((db (sqlite-open))) + (should (eq (type-of db) 'sqlite)) + (should (sqlitep db)) + (should-not (sqlitep 'foo)) + + (should + (zerop + (sqlite-execute + db "create table if not exists test1 (col1 text, col2 integer, col3 float, col4 blob)"))) + + (should-error + (sqlite-execute + db "insert into test1 (col1, col2, col3, col4) values ('foo', 2, 9.45, 'bar', 'zot')")) + + (should + (= + (sqlite-execute + db "insert into test1 (col1, col2, col3, col4) values ('foo', 2, 9.45, 'bar')") + 1)) + + (should + (equal + (sqlite-select db "select * from test1" nil 'full) + '(("col1" "col2" "col3" "col4") ("foo" 2 9.45 "bar")))))) + +(ert-deftest sqlite-set () + (skip-unless (sqlite-available-p)) + (let ((db (sqlite-open)) + set) + (should + (zerop + (sqlite-execute + db "create table if not exists test1 (col1 text, col2 integer)"))) + + (should + (= + (sqlite-execute db "insert into test1 (col1, col2) values ('foo', 1)") + 1)) + (should + (= + (sqlite-execute db "insert into test1 (col1, col2) values ('bar', 2)") + 1)) + + (setq set (sqlite-select db "select * from test1" nil 'set)) + (should (sqlitep set)) + (should (sqlite-more-p set)) + (should (equal (sqlite-next set) + '("foo" 1))) + (should (equal (sqlite-next set) + '("bar" 2))) + (should-not (sqlite-next set)) + (should-not (sqlite-more-p set)) + (sqlite-finalize set) + (should-error (sqlite-next set)))) + +(ert-deftest sqlite-chars () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test2 (col1 text, col2 integer)") + (sqlite-execute + db "insert into test2 (col1, col2) values ('fóo', 3)") + (sqlite-execute + db "insert into test2 (col1, col2) values ('fóo', 3)") + (sqlite-execute + db "insert into test2 (col1, col2) values ('fo', 4)") + (should + (equal (sqlite-select db "select * from test2" nil 'full) + '(("col1" "col2") ("fóo" 3) ("fóo" 3) ("fo" 4)))))) + +(ert-deftest sqlite-numbers () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test3 (col1 integer)") + (let ((big (expt 2 50)) + (small (expt 2 10))) + (sqlite-execute db (format "insert into test3 values (%d)" small)) + (sqlite-execute db (format "insert into test3 values (%d)" big)) + (should + (equal + (sqlite-select db "select * from test3") + (list (list small) (list big))))))) + +(ert-deftest sqlite-param () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test4 (col1 text, col2 number)") + (sqlite-execute db "insert into test4 values (?, ?)" (list "foo" 1)) + (should + (equal + (sqlite-select db "select * from test4 where col2 = ?" '(1)) + '(("foo" 1)))) + (should + (equal + (sqlite-select db "select * from test4 where col2 = ?" [1]) + '(("foo" 1)))))) + +(ert-deftest sqlite-binary () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test5 (col1 text, col2 number)") + (let ((string (with-temp-buffer + (set-buffer-multibyte nil) + (insert 0 1 2) + (buffer-string)))) + (should-not (multibyte-string-p string)) + (sqlite-execute + db "insert into test5 values (?, ?)" (list string 2)) + (let ((out (caar + (sqlite-select db "select col1 from test5 where col2 = 2")))) + (should (equal out string)))))) + +(ert-deftest sqlite-different-dbs () + (skip-unless (sqlite-available-p)) + (let (db1 db2) + (setq db1 (sqlite-open)) + (setq db2 (sqlite-open)) + (sqlite-execute + db1 "create table if not exists test6 (col1 text, col2 number)") + (sqlite-execute + db2 "create table if not exists test6 (col1 text, col2 number)") + (sqlite-execute + db1 "insert into test6 values (?, ?)" '("foo" 2)) + (should (sqlite-select db1 "select * from test6")) + (should-not (sqlite-select db2 "select * from test6")))) + +(ert-deftest sqlite-close-dbs () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test6 (col1 text, col2 number)") + (sqlite-execute db "insert into test6 values (?, ?)" '("foo" 2)) + (should (sqlite-select db "select * from test6")) + (sqlite-close db) + (should-error (sqlite-select db "select * from test6")))) + +(ert-deftest sqlite-load-extension () + (skip-unless (sqlite-available-p)) + (skip-unless (fboundp 'sqlite-load-extension)) + (let (db) + (setq db (sqlite-open)) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3/notpcre.so")) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3/n")) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3/")) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3")) + (should + (memq + (sqlite-load-extension db "/usr/lib/sqlite3/pcre.so") + '(nil t))) + + (should-error + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_notcsvtable.so")) + (should-error + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtablen.so")) + (should-error + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtable")) + (should + (memq + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtable.so") + '(nil t))))) + +(ert-deftest sqlite-blob () + (skip-unless (sqlite-available-p)) + (let (db) + (progn + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test10 (col1 text, col2 blob, col3 numbre)") + (let ((string (with-temp-buffer + (set-buffer-multibyte nil) + (insert 0 1 2) + (buffer-string)))) + (should-not (multibyte-string-p string)) + (sqlite-execute + db "insert into test10 values (?, ?, 1)" + (list string + (propertize string + 'coding-system 'binary))) + (cl-destructuring-bind + (c1 c2 _) + (car (sqlite-select db "select * from test10 where col3 = 1")) + (should (equal c1 string)) + (should (equal c2 string)) + (should (multibyte-string-p c1)) + (should-not (multibyte-string-p c2))))))) + +;;; sqlite-tests.el ends here 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 67e7ec32517..751a900a23e 100644 --- a/test/src/syntax-tests.el +++ b/test/src/syntax-tests.el @@ -1,6 +1,6 @@ ;;; syntax-tests.el --- tests for syntax.c functions -*- lexical-binding: t -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -20,6 +20,8 @@ ;;; Code: (require 'ert) +(require 'ert-x) +(require 'cl-lib) (ert-deftest parse-partial-sexp-continue-over-comment-marker () "Continue a parse that stopped in the middle of a comment marker." @@ -55,6 +57,16 @@ (should (equal (parse-partial-sexp aftC pointX nil nil pps-aftC) ppsX))))) +(ert-deftest syntax-class-character-test () + (cl-loop for char across " .w_()'\"$\\/<>@!|" + for i from 0 + do (should (= char (syntax-class-to-char i))) + when (string-to-syntax (string char)) + do (should (= char (syntax-class-to-char + (car (string-to-syntax (string char))))))) + (should-error (syntax-class-to-char -1)) + (should-error (syntax-class-to-char 200))) + (ert-deftest parse-partial-sexp-paren-comments () "Test syntax parsing with paren comment markers. Specifically, where the first character of the comment marker is @@ -82,4 +94,431 @@ 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) + +(ert-deftest test-from-to-parse-partial-sexp () + (with-temp-buffer + (insert "foo") + (should (parse-partial-sexp 1 1)) + (should-error (parse-partial-sexp 2 1)))) + +(ert-deftest syntax-char-syntax () + ;; Verify that char-syntax behaves identically in interpreted and + ;; byte-compiled code (bug#53260). + (let ((cs (byte-compile (lambda (x) (char-syntax x))))) + ;; Use a unibyte buffer with a syntax table using symbol syntax + ;; for raw byte 128. + (with-temp-buffer + (set-buffer-multibyte nil) + (let ((st (make-syntax-table))) + (modify-syntax-entry (unibyte-char-to-multibyte 128) "_" st) + (set-syntax-table st) + (should (equal (eval '(char-syntax 128) t) ?_)) + (should (equal (funcall cs 128) ?_)))) + (list (char-syntax 128) (funcall cs 128)))) + ;;; syntax-tests.el ends here diff --git a/test/src/textprop-tests.el b/test/src/textprop-tests.el index 1dcfa8ea29d..d6cee6b6cbe 100644 --- a/test/src/textprop-tests.el +++ b/test/src/textprop-tests.el @@ -1,6 +1,6 @@ -;;; textprop-tests.el --- Test suite for text properties. +;;; textprop-tests.el --- Test suite for text properties. -*- lexical-binding: t -*- -;; Copyright (C) 2015-2017 Free Software Foundation, Inc. +;; Copyright (C) 2015-2022 Free Software Foundation, Inc. ;; Author: Wolfgang Jenkner <wjenkner@inode.at> ;; Keywords: internal @@ -69,4 +69,4 @@ (null stack))))) (provide 'textprop-tests) -;; textprop-tests.el ends here. +;;; textprop-tests.el ends here diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el index 10b2f0761df..75d67140a90 100644 --- a/test/src/thread-tests.el +++ b/test/src/thread-tests.el @@ -1,6 +1,6 @@ -;;; threads.el --- tests for threads. +;;; thread-tests.el --- tests for threads. -*- lexical-binding: t -*- -;; Copyright (C) 2012-2017 Free Software Foundation, Inc. +;; Copyright (C) 2012-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -19,39 +19,74 @@ ;;; Code: +(require 'thread) + +;; Declare the functions in case Emacs has been configured --without-threads. +(declare-function all-threads "thread.c" ()) +(declare-function condition-mutex "thread.c" (cond)) +(declare-function condition-name "thread.c" (cond)) +(declare-function condition-notify "thread.c" (cond &optional all)) +(declare-function condition-wait "thread.c" (cond)) +(declare-function current-thread "thread.c" ()) +(declare-function make-condition-variable "thread.c" (mutex &optional name)) +(declare-function make-mutex "thread.c" (&optional name)) +(declare-function make-thread "thread.c" (function &optional name)) +(declare-function mutex-lock "thread.c" (mutex)) +(declare-function mutex-unlock "thread.c" (mutex)) +(declare-function thread--blocker "thread.c" (thread)) +(declare-function thread-live-p "thread.c" (thread)) +(declare-function thread-join "thread.c" (thread)) +(declare-function thread-last-error "thread.c" (&optional cleanup)) +(declare-function thread-name "thread.c" (thread)) +(declare-function thread-signal "thread.c" (thread error-symbol data)) +(declare-function thread-yield "thread.c" ()) +(defvar main-thread) + (ert-deftest threads-is-one () - "test for existence of a thread" + "Test for existence of a thread." + (skip-unless (featurep 'threads)) (should (current-thread))) (ert-deftest threads-threadp () - "test of threadp" + "Test of threadp." + (skip-unless (featurep 'threads)) (should (threadp (current-thread)))) (ert-deftest threads-type () - "test of thread type" + "Test of thread type." + (skip-unless (featurep 'threads)) (should (eq (type-of (current-thread)) 'thread))) (ert-deftest threads-name () - "test for name of a thread" + "Test for name of a thread." + (skip-unless (featurep 'threads)) (should (string= "hi bob" (thread-name (make-thread #'ignore "hi bob"))))) -(ert-deftest threads-alive () - "test for thread liveness" +(ert-deftest threads-live () + "Test for thread liveness." + (skip-unless (featurep 'threads)) (should - (thread-alive-p (make-thread #'ignore)))) + (thread-live-p (make-thread #'ignore)))) (ert-deftest threads-all-threads () - "simple test for all-threads" + "Simple test for `all-threads'." + (skip-unless (featurep 'threads)) (should (listp (all-threads)))) +(ert-deftest threads-main-thread () + "Simple test for `all-threads'." + (skip-unless (featurep 'threads)) + (should (eq main-thread (car (all-threads))))) + (defvar threads-test-global nil) (defun threads-test-thread1 () (setq threads-test-global 23)) (ert-deftest threads-basic () - "basic thread test" + "Basic thread test." + (skip-unless (featurep 'threads)) (should (progn (setq threads-test-global nil) @@ -61,19 +96,30 @@ threads-test-global))) (ert-deftest threads-join () - "test of thread-join" + "Test of `thread-join'." + (skip-unless (featurep 'threads)) (should (progn (setq threads-test-global nil) (let ((thread (make-thread #'threads-test-thread1))) - (thread-join thread) - (and threads-test-global - (not (thread-alive-p thread))))))) + (and (= (thread-join thread) 23) + (= threads-test-global 23) + (not (thread-live-p thread))))))) (ert-deftest threads-join-self () - "cannot thread-join the current thread" + "Cannot `thread-join' the current thread." + (skip-unless (featurep 'threads)) (should-error (thread-join (current-thread)))) +(ert-deftest threads-join-error () + "Test of error signaling from `thread-join'." + :tags '(:unstable) + (skip-unless (featurep 'threads)) + (let ((thread (make-thread #'threads-call-error))) + (while (thread-live-p thread) + (thread-yield)) + (should-error (thread-join thread)))) + (defvar threads-test-binding nil) (defun threads-test-thread2 () @@ -82,7 +128,8 @@ (setq threads-test-global 23)) (ert-deftest threads-let-binding () - "simple test of threads and let bindings" + "Simple test of threads and let bindings." + (skip-unless (featurep 'threads)) (should (progn (setq threads-test-global nil) @@ -93,19 +140,23 @@ threads-test-global)))) (ert-deftest threads-mutexp () - "simple test of mutexp" + "Simple test of `mutexp'." + (skip-unless (featurep 'threads)) (should-not (mutexp 'hi))) (ert-deftest threads-mutexp-2 () - "another simple test of mutexp" + "Another simple test of `mutexp'." + (skip-unless (featurep 'threads)) (should (mutexp (make-mutex)))) (ert-deftest threads-mutex-type () - "type-of mutex" + "type-of mutex." + (skip-unless (featurep 'threads)) (should (eq (type-of (make-mutex)) 'mutex))) (ert-deftest threads-mutex-lock-unlock () - "test mutex-lock and unlock" + "Test `mutex-lock' and unlock." + (skip-unless (featurep 'threads)) (should (let ((mx (make-mutex))) (mutex-lock mx) @@ -113,7 +164,8 @@ t))) (ert-deftest threads-mutex-recursive () - "test mutex-lock and unlock" + "Test mutex recursion." + (skip-unless (featurep 'threads)) (should (let ((mx (make-mutex))) (mutex-lock mx) @@ -133,7 +185,8 @@ (mutex-unlock threads-mutex)) (ert-deftest threads-mutex-contention () - "test of mutex contention" + "Test of mutex contention." + (skip-unless (featurep 'threads)) (should (progn (setq threads-mutex (make-mutex)) @@ -153,8 +206,9 @@ (mutex-lock threads-mutex)) (ert-deftest threads-mutex-signal () - "test signaling a blocked thread" - (should + "Test signaling a blocked thread." + (skip-unless (featurep 'threads)) + (should-error (progn (setq threads-mutex (make-mutex)) (setq threads-mutex-key nil) @@ -163,14 +217,17 @@ (while (not threads-mutex-key) (thread-yield)) (thread-signal thr 'quit nil) - (thread-join thr)) - t))) + ;; `quit' is not catched by `should-error'. We must indicate it. + (condition-case nil + (thread-join thr) + (quit (signal 'error nil))))))) (defun threads-test-io-switch () (setq threads-test-global 23)) (ert-deftest threads-io-switch () - "test that accept-process-output causes thread switch" + "Test that `accept-process-output' causes thread switch." + (skip-unless (featurep 'threads)) (should (progn (setq threads-test-global nil) @@ -180,60 +237,72 @@ threads-test-global))) (ert-deftest threads-condvarp () - "simple test of condition-variable-p" + "Simple test of `condition-variable-p'." + (skip-unless (featurep 'threads)) (should-not (condition-variable-p 'hi))) (ert-deftest threads-condvarp-2 () - "another simple test of condition-variable-p" + "Another simple test of `condition-variable-p'." + (skip-unless (featurep 'threads)) (should (condition-variable-p (make-condition-variable (make-mutex))))) (ert-deftest threads-condvar-type () "type-of condvar" + (skip-unless (featurep 'threads)) (should (eq (type-of (make-condition-variable (make-mutex))) 'condition-variable))) (ert-deftest threads-condvar-mutex () - "simple test of condition-mutex" + "Simple test of `condition-mutex'." + (skip-unless (featurep 'threads)) (should (let ((m (make-mutex))) (eq m (condition-mutex (make-condition-variable m)))))) (ert-deftest threads-condvar-name () - "simple test of condition-name" + "Simple test of `condition-name'." + (skip-unless (featurep 'threads)) (should (eq nil (condition-name (make-condition-variable (make-mutex)))))) (ert-deftest threads-condvar-name-2 () - "another simple test of condition-name" + "Another simple test of `condition-name'." + (skip-unless (featurep 'threads)) (should (string= "hi bob" (condition-name (make-condition-variable (make-mutex) "hi bob"))))) -(defun call-error () + +(defun threads-call-error () "Call `error'." (error "Error is called")) ;; This signals an error internally; the error should be caught. -(defun thread-custom () - (defcustom thread-custom-face 'highlight +(defun threads-custom () + (defcustom threads-custom-face 'highlight "Face used for thread customizations." :type 'face :group 'widget-faces)) -(ert-deftest thread-errors () +(ert-deftest threads-errors () "Test what happens when a thread signals an error." + (skip-unless (featurep 'threads)) (let (th1 th2) - (setq th1 (make-thread #'call-error "call-error")) + (setq th1 (make-thread #'threads-call-error "call-error")) (should (threadp th1)) - (while (thread-alive-p th1) + (while (thread-live-p th1) (thread-yield)) (should (equal (thread-last-error) '(error "Error is called"))) - (setq th2 (make-thread #'thread-custom "thread-custom")) + (should (equal (thread-last-error 'cleanup) + '(error "Error is called"))) + (should-not (thread-last-error)) + (setq th2 (make-thread #'threads-custom "threads-custom")) (should (threadp th2)))) -(ert-deftest thread-sticky-point () +(ert-deftest threads-sticky-point () "Test bug #25165 with point movement in cloned buffer." + (skip-unless (featurep 'threads)) (with-temp-buffer (insert "Lorem ipsum dolor sit amet, consectetur adipiscing elit.") (goto-char (point-min)) @@ -242,16 +311,36 @@ (sit-for 1) (should (= (point) 21)))) -(ert-deftest thread-signal-early () +(ert-deftest threads-signal-early () "Test signaling a thread as soon as it is started by the OS." + (skip-unless (featurep 'threads)) (let ((thread - (make-thread #'(lambda () - (while t (thread-yield)))))) + (make-thread (lambda () + (while t (thread-yield)))))) (thread-signal thread 'error nil) (sit-for 1) - (should-not (thread-alive-p thread)) + (should-not (thread-live-p thread)) (should (equal (thread-last-error) '(error))))) +(ert-deftest threads-signal-main-thread () + "Test signaling the main thread." + (skip-unless (featurep 'threads)) + ;; We cannot use `ert-with-message-capture', because threads do not + ;; know let-bound variables. + (with-current-buffer "*Messages*" + (let (buffer-read-only) + (erase-buffer)) + (let ((thread + (make-thread (lambda () (thread-signal main-thread 'error nil))))) + (while (thread-live-p thread) + (thread-yield)) + (read-event nil nil 0.1) + ;; No error has been raised, which is part of the test. + (should + (string-match + (format-message "Error %s: (error nil)" thread) + (buffer-string )))))) + (defvar threads-condvar nil) (defun threads-test-condvar-wait () @@ -263,7 +352,8 @@ (condition-wait threads-condvar))) (ert-deftest threads-condvar-wait () - "test waiting on conditional variable" + "Test waiting on conditional variable." + (skip-unless (featurep 'threads)) (let ((cv-mutex (make-mutex)) new-thread) ;; We could have spurious threads from the previous tests still @@ -274,7 +364,7 @@ (setq new-thread (make-thread #'threads-test-condvar-wait)) ;; Make sure new-thread is alive. - (should (thread-alive-p new-thread)) + (should (thread-live-p new-thread)) (should (= (length (all-threads)) 2)) ;; Wait for new-thread to become blocked on the condvar. (while (not (eq (thread--blocker new-thread) threads-condvar)) @@ -287,7 +377,7 @@ (sleep-for 0.1) ;; Make sure the thread is still there. This used to fail due to ;; a bug in thread.c:condition_wait_callback. - (should (thread-alive-p new-thread)) + (should (thread-live-p new-thread)) (should (= (length (all-threads)) 2)) (should (eq (thread--blocker new-thread) threads-condvar)) @@ -298,4 +388,34 @@ (should (= (length (all-threads)) 1)) (should (equal (thread-last-error) '(error "Die, die, die!"))))) -;;; threads.el ends here +(ert-deftest threads-test-bug33073 () + (skip-unless (fboundp 'make-thread)) + (let ((th (make-thread 'ignore))) + (should-not (equal th main-thread)))) + +(defvar threads-test--var 'global) + +(ert-deftest threads-test-bug48990 () + (skip-unless (fboundp 'make-thread)) + (let ((buf1 (generate-new-buffer " thread-test")) + (buf2 (generate-new-buffer " thread-test"))) + (with-current-buffer buf1 + (setq-local threads-test--var 'local1)) + (with-current-buffer buf2 + (setq-local threads-test--var 'local2)) + (let ((seen nil)) + (with-current-buffer buf1 + (should (eq threads-test--var 'local1)) + (make-thread (lambda () (setq seen threads-test--var)))) + (with-current-buffer buf2 + (should (eq threads-test--var 'local2)) + (let ((threads-test--var 'let2)) + (should (eq threads-test--var 'let2)) + (while (not seen) + (thread-yield)) + (should (eq threads-test--var 'let2)) + (should (eq seen 'local1))) + (should (eq threads-test--var 'local2))) + (should (eq threads-test--var 'global))))) + +;;; thread-tests.el ends here diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el new file mode 100644 index 00000000000..24f9000ffbd --- /dev/null +++ b/test/src/timefns-tests.el @@ -0,0 +1,264 @@ +;;; timefns-tests.el --- tests for timefns.c -*- lexical-binding: t -*- + +;; Copyright (C) 2016-2022 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) + +(defun timefns-tests--decode-time (look zone decoded-time) + (should (equal (decode-time look zone t) decoded-time)) + (should (equal (decode-time look zone 'integer) + (cons (time-convert (car decoded-time) 'integer) + (cdr decoded-time))))) + +;;; Check format-time-string and decode-time with various TZ settings. +;;; Use only POSIX-compatible TZ values, since the tests should work +;;; even if tzdb is not in use. +(ert-deftest format-time-string-with-zone () + ;; Don’t use (0 0 0 0) as the test case, as there are too many bugs + ;; in MS-Windows (and presumably other) C libraries when formatting + ;; time stamps near the Epoch of 1970-01-01 00:00:00 UTC, and this + ;; test is for GNU Emacs, not for C runtimes. Instead, look before + ;; you leap: "look" is the timestamp just before the first leap + ;; second on 1972-06-30 23:59:60 UTC, so it should format to the + ;; same string regardless of whether the underlying C library + ;; ignores leap seconds, while avoiding circa-1970 glitches. + ;; + ;; Similarly, stick to the limited set of time zones that are + ;; supported by both POSIX and MS-Windows: exactly 3 ASCII letters + ;; in the abbreviation, and no DST. + (let ((format "%Y-%m-%d %H:%M:%S.%3N %z (%Z)")) + (dolist (look '((1202 22527 999999 999999) + (7879679999900 . 100000) + (78796799999999999999 . 1000000000000))) + ;; UTC. + (let* ((look-ticks-hz (time-convert look t)) + (hz (cdr look-ticks-hz)) + (look-integer (time-convert look 'integer)) + (sec (time-add (time-convert 59 hz) + (time-subtract look-ticks-hz + (time-convert look-integer hz))))) + (should (string-equal + (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" look t) + "1972-06-30 23:59:59.999 +0000")) + (timefns-tests--decode-time look t + (list sec 59 23 30 6 1972 5 nil 0)) + ;; "UTC0". + (should (string-equal + (format-time-string format look "UTC0") + "1972-06-30 23:59:59.999 +0000 (UTC)")) + (timefns-tests--decode-time look "UTC0" + (list sec 59 23 30 6 1972 5 nil 0)) + ;; Negative UTC offset, as a Lisp list. + (should (string-equal + (format-time-string format look '(-28800 "PST")) + "1972-06-30 15:59:59.999 -0800 (PST)")) + (timefns-tests--decode-time look '(-28800 "PST") + (list sec 59 15 30 6 1972 5 nil -28800)) + ;; Negative UTC offset, as a Lisp integer. + (should (string-equal + (format-time-string format look -28800) + ;; MS-Windows build replaces unrecognizable TZ values, + ;; such as "-08", with "ZZZ". + (if (eq system-type 'windows-nt) + "1972-06-30 15:59:59.999 -0800 (ZZZ)" + "1972-06-30 15:59:59.999 -0800 (-08)"))) + (timefns-tests--decode-time look -28800 + (list sec 59 15 30 6 1972 5 nil -28800)) + ;; Positive UTC offset that is not an hour multiple, as a string. + (should (string-equal + (format-time-string format look "IST-5:30") + "1972-07-01 05:29:59.999 +0530 (IST)")) + (timefns-tests--decode-time look "IST-5:30" + (list sec 29 5 1 7 1972 6 nil 19800)))))) + +(ert-deftest decode-then-encode-time () + (let ((time-values (list 0 -2 1 0.0 -0.0 -2.0 1.0 + most-negative-fixnum most-positive-fixnum + (1- most-negative-fixnum) + (1+ most-positive-fixnum) + '(0 1 0 0) '(1 0 0 0) '(-1 0 0 0) + '(123456789000000 . 1000000) + (cons (1+ most-positive-fixnum) 1000000000000) + (cons 1000000000000 (1+ most-positive-fixnum))))) + (dolist (a time-values) + (let* ((d (ignore-errors (decode-time a t t))) + (d-integer (ignore-errors (decode-time a t 'integer))) + (e (if d (encode-time d))) + (e-integer (if d-integer (encode-time d-integer)))) + (should (or (not d) (time-equal-p a e))) + (should (or (not d-integer) (time-equal-p (time-convert a 'integer) + e-integer))))))) + +;;; This should not dump core. +(ert-deftest format-time-string-with-outlandish-zone () + (should (stringp + (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" nil + (concat (make-string 2048 ?X) "0"))))) + +(defun timefns-tests--have-leap-seconds () + (string-equal (format-time-string "%Y-%m-%d %H:%M:%S" 78796800 t) + "1972-06-30 23:59:60")) + +(ert-deftest format-time-string-with-bignum-on-32-bit () + (should (or (string-equal + (format-time-string "%Y-%m-%d %H:%M:%S" (- (ash 1 31) 3600) t) + "2038-01-19 02:14:08") + (timefns-tests--have-leap-seconds)))) + +;;; Tests of format-time-string padding + +(ert-deftest format-time-string-padding-minimal-deletes-unneeded-zeros () + (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 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 (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 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 (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 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 (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 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 () + (should (time-equal-p nil nil))) + +(ert-deftest time-arith-tests () + (let ((time-values (list 0 -1 1 0.0 -0.0 -1.0 1.0 + most-negative-fixnum most-positive-fixnum + (1- most-negative-fixnum) + (1+ most-positive-fixnum) + 1e1 -1e1 1e-1 -1e-1 + 1e8 -1e8 1e-8 -1e-8 + 1e9 -1e9 1e-9 -1e-9 + 1e10 -1e10 1e-10 -1e-10 + 1e16 -1e16 1e-16 -1e-16 + 1e37 -1e37 1e-37 -1e-37 + '(0 0 0 1) '(0 0 1 0) '(0 1 0 0) '(1 0 0 0) + '(-1 0 0 0) '(1 2 3 4) '(-1 2 3 4) + '(-123456789 . 100000) '(123456789 . 1000000) + (cons (1+ most-positive-fixnum) 1000000000000) + (cons 1000000000000 (1+ most-positive-fixnum))))) + (dolist (a time-values) + (should-error (time-add a 'ouch)) + (should-error (time-add 'ouch a)) + (should-error (time-subtract a 'ouch)) + (should-error (time-subtract 'ouch a)) + (dolist (b time-values) + (let ((aa (time-subtract (time-add a b) b))) + (should (or (time-equal-p a aa) (and (floatp aa) (isnan aa))))) + (should (= 1 (+ (if (time-less-p a b) 1 0) + (if (time-equal-p a b) 1 0) + (if (time-less-p b a) 1 0) + (if (or (and (floatp a) (isnan a)) + (and (floatp b) (isnan b))) + 1 0)))) + (should (or (not (time-less-p 0 b)) + (time-less-p a (time-add a b)) + (time-equal-p a (time-add a b)) + (and (floatp (time-add a b)) (isnan (time-add a b))))) + (let ((x (float-time (time-add a b))) + (y (+ (float-time a) (float-time b)))) + (should (or (and (isnan x) (isnan y)) + (= x y) + (< 0.99 (/ x y) 1.01) + (< 0.99 (/ (- (float-time a)) (float-time b)) + 1.01)))))))) + +(ert-deftest time-rounding-tests () + (should (time-equal-p 1e-13 (time-add 0 1e-13)))) + +(ert-deftest encode-time-dst-numeric-zone () + "Check for Bug#35502." + (should (time-equal-p + (encode-time '(29 31 17 30 4 2019 2 t 7200)) + '(23752 27217)))) + +(ert-deftest encode-time-alternate-apis () + (let* ((time '(30 30 12 15 6 1970)) + (time-1 (append time '(nil -1 nil))) + (etime (encode-time time))) + (should (time-equal-p etime (encode-time time-1))) + (should (time-equal-p etime (apply #'encode-time time))) + (should (time-equal-p etime (apply #'encode-time time-1))) + (should (time-equal-p etime (apply #'encode-time (append time '(nil))))))) + +(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)) + + (let ((x 1.0)) + (while (not (zerop x)) + (dolist (multiplier '(-1.9 -1.5 -1.1 -1 1 1.1 1.5 1.9)) + (let ((xmult (* x multiplier))) + (should (= xmult (float-time (time-convert xmult t)))))) + (setq x (/ x 2)))) + + (let ((x 1.0)) + (while (ignore-errors (time-convert x t)) + (dolist (divisor '(-1.9 -1.5 -1.1 -1 1 1.1 1.5 1.9)) + (let ((xdiv (/ x divisor))) + (should (= xdiv (float-time (time-convert xdiv t)))))) + (setq x (* x 2))))) + +(ert-deftest time-convert-forms () + ;; These computations involve numbers that should have exact + ;; representations on any Emacs platform. + (dolist (time '(-86400 -1 0 1 86400)) + (dolist (delta '(0 0.0 0.25 3.25 1000 1000.25)) + (let ((time+ (+ time delta)) + (time- (- time delta))) + (dolist (form '(nil t list 4 1000 1000000 1000000000)) + (should (time-equal-p time (time-convert time form))) + (should (time-equal-p time- (time-convert time- form))) + (should (time-equal-p time+ (time-convert time+ form)))))))) + +;;; timefns-tests.el ends here diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el index 3ff75ae68d5..cb0822fb1b9 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-2017 Free Software Foundation, Inc. +;; Copyright (C) 2012-2022 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: @@ -44,6 +46,8 @@ ;;; Code: (require 'ert) +(require 'ert-x) +(require 'facemenu) (ert-deftest undo-test0 () "Test basics of \\[undo]." @@ -72,7 +76,7 @@ (undo-boundary) (put-text-property (point-min) (point-max) 'face 'bold) (undo-boundary) - (remove-text-properties (point-min) (point-max) '(face default)) + (remove-list-of-text-properties (point-min) (point-max) '(face)) (undo-boundary) (set-buffer-multibyte (not enable-multibyte-characters)) (undo-boundary) @@ -85,6 +89,7 @@ (ert-deftest undo-test1 () "Test undo of \\[undo] command (redo)." + (require 'facemenu) (with-temp-buffer (buffer-enable-undo) (undo-boundary) @@ -214,17 +219,14 @@ (ert-deftest undo-test-file-modified () "Test undoing marks buffer visiting file unmodified." - (let ((tempfile (make-temp-file "undo-test"))) - (unwind-protect - (progn - (with-current-buffer (find-file-noselect tempfile) - (insert "1") - (undo-boundary) - (set-buffer-modified-p nil) - (insert "2") - (undo) - (should-not (buffer-modified-p)))) - (delete-file tempfile)))) + (ert-with-temp-file tempfile + (with-current-buffer (find-file-noselect tempfile) + (insert "1") + (undo-boundary) + (set-buffer-modified-p nil) + (insert "2") + (undo) + (should-not (buffer-modified-p))))) (ert-deftest undo-test-region-not-most-recent () "Test undo in region of an edit not the most recent." @@ -255,7 +257,7 @@ (insert "12345") (search-backward "4") (undo-boundary) - (delete-forward-char 1) + (funcall-interactively 'delete-forward-char 1) (search-backward "1") (undo-boundary) (insert "xxxx") @@ -299,7 +301,7 @@ undo-make-selective-list." (insert "ddd") (search-backward "ad") (undo-boundary) - (delete-forward-char 2) + (funcall-interactively 'delete-forward-char 2) (undo-boundary) ;; Select "dd" (push-mark (point) t t) @@ -348,7 +350,7 @@ undo-make-selective-list." (let ((m (make-marker))) (set-marker m 2 (current-buffer)) (goto-char (point-min)) - (delete-forward-char 3) + (funcall-interactively 'delete-forward-char 3) (undo-boundary) (should (= (point-min) (marker-position m))) (undo) @@ -369,7 +371,7 @@ undo-make-selective-list." (push-mark (point) t t) (setq mark-active t) (goto-char (point-min)) - (delete-forward-char 1) ;; delete region covering "ab" + (funcall-interactively 'delete-forward-char 1) ; delete region covering "ab" (undo-boundary) (should (= (point-min) (marker-position m))) ;; Resurrect "ab". m's insertion type means the reinsertion @@ -389,7 +391,7 @@ Demonstrates bug 16818." (let ((m (make-marker))) (set-marker m 2 (current-buffer)) ; m at b (goto-char (point-min)) - (delete-forward-char 3) ; m at d + (funcall-interactively 'delete-forward-char 3) ; m at d (undo-boundary) (set-marker m 4) ; m at g (undo) @@ -422,7 +424,7 @@ Demonstrates bug 16818." (push-mark (point) t t) (setq mark-active t) (goto-char (- (point) 3)) - (delete-forward-char 1) + (funcall-interactively 'delete-forward-char 1) (undo-boundary) (insert "bbb") @@ -452,17 +454,16 @@ 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)))))) (save-excursion (goto-char (point-min)) - (let ((ov (make-overlay (line-beginning-position 2) - (line-end-position 2)))) + (let ((ov (make-overlay (pos-bol 2) (pos-eol 2)))) (overlay-put ov 'insert-in-front-hooks (list overlay-modified))))) - (kill-region (point-min) (line-beginning-position 2)) + (kill-region (point-min) (pos-bol 2)) (undo-boundary) (undo))) diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el new file mode 100644 index 00000000000..6ff64d0431a --- /dev/null +++ b/test/src/xdisp-tests.el @@ -0,0 +1,182 @@ +;;; xdisp-tests.el --- tests for xdisp.c functions -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2022 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))))) + +(ert-deftest xdisp-tests--window-text-pixel-size () ;; bug#45748 + (with-temp-buffer + (insert "xxx") + (switch-to-buffer (current-buffer)) + (let* ((char-width (frame-char-width)) + (size (window-text-pixel-size nil t t)) + (width-in-chars (/ (car size) char-width))) + (should (equal width-in-chars 3))))) + +(ert-deftest xdisp-tests--window-text-pixel-size-leading-space () ;; bug#45748 + (with-temp-buffer + (insert " xx") + (switch-to-buffer (current-buffer)) + (let* ((char-width (frame-char-width)) + (size (window-text-pixel-size nil t t)) + (width-in-chars (/ (car size) char-width))) + (should (equal width-in-chars 3))))) + +(ert-deftest xdisp-tests--window-text-pixel-size-trailing-space () ;; bug#45748 + (with-temp-buffer + (insert "xx ") + (switch-to-buffer (current-buffer)) + (let* ((char-width (frame-char-width)) + (size (window-text-pixel-size nil t t)) + (width-in-chars (/ (car size) char-width))) + (should (equal width-in-chars 3))))) + +(ert-deftest xdisp-tests--find-directional-overrides-case-1 () + (with-temp-buffer + (insert "\ +int main() { + bool isAdmin = false; + /* }if (isAdmin) begin admins only */ + printf(\"You are an admin.\\n\"); + /* end admins only { */ + return 0; +}") + (goto-char (point-min)) + (should (eq (bidi-find-overridden-directionality (point-min) (point-max) + nil) + 46)))) + +(ert-deftest xdisp-tests--find-directional-overrides-case-2 () + (with-temp-buffer + (insert "\ +#define is_restricted_user(user) \\ + !strcmp (user, \"root\") ? 0 : \\ + !strcmp (user, \"admin\") ? 0 : \\ + !strcmp (user, \"superuser? 0 : 1 \") + +int main () { + printf (\"root: %d\\n\", is_restricted_user (\"root\")); + printf (\"admin: %d\\n\", is_restricted_user (\"admin\")); + printf (\"superuser: %d\\n\", is_restricted_user (\"superuser\")); + printf (\"luser: %d\\n\", is_restricted_user (\"luser\")); + printf (\"nobody: %d\\n\", is_restricted_user (\"nobody\")); +}") + (goto-char (point-min)) + (should (eq (bidi-find-overridden-directionality (point-min) (point-max) + nil) + 138)))) + +(ert-deftest xdisp-tests--find-directional-overrides-case-3 () + (with-temp-buffer + (insert "\ +#define is_restricted_user(user) \\ + !strcmp (user, \"root\") ? 0 : \\ + !strcmp (user, \"admin\") ? 0 : \\ + !strcmp (user, \"superuser? '#' : '!' \") + +int main () { + printf (\"root: %d\\n\", is_restricted_user (\"root\")); + printf (\"admin: %d\\n\", is_restricted_user (\"admin\")); + printf (\"superuser: %d\\n\", is_restricted_user (\"superuser\")); + printf (\"luser: %d\\n\", is_restricted_user (\"luser\")); + printf (\"nobody: %d\\n\", is_restricted_user (\"nobody\")); +}") + (goto-char (point-min)) + (should (eq (bidi-find-overridden-directionality (point-min) (point-max) + nil) + 138)))) + +(ert-deftest test-get-display-property () + (with-temp-buffer + (insert (propertize "foo" 'face 'bold 'display '(height 2.0))) + (should (equal (get-display-property 2 'height) 2.0))) + (with-temp-buffer + (insert (propertize "foo" 'face 'bold 'display '((height 2.0) + (space-width 2.0)))) + (should (equal (get-display-property 2 'height) 2.0)) + (should (equal (get-display-property 2 'space-width) 2.0))) + (with-temp-buffer + (insert (propertize "foo bar" 'face 'bold + 'display '[(height 2.0) + (space-width 20)])) + (should (equal (get-display-property 2 'height) 2.0)) + (should (equal (get-display-property 2 'space-width) 20)))) + +(ert-deftest test-messages-buffer-name () + (should + (equal + (let ((messages-buffer-name "test-message")) + (message "foo") + (with-current-buffer messages-buffer-name + (buffer-string))) + "foo\n"))) + +;;; 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..16f16537918 --- /dev/null +++ b/test/src/xfaces-tests.el @@ -0,0 +1,57 @@ +;;; xfaces-tests.el --- tests for xfaces.c -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2022 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) + +(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)) + (should (equal (color-values-from-color-spec "rgbi:0/0/ 0") nil)) + (should (equal (color-values-from-color-spec "rgbi:0/0x0/0") nil)) + (should (equal (color-values-from-color-spec "rgbi:0/+0x1/0") nil))) + +(provide 'xfaces-tests) + +;;; xfaces-tests.el ends here diff --git a/test/src/xml-tests.el b/test/src/xml-tests.el index 557e6da4524..6a8290bd0c8 100644 --- a/test/src/xml-tests.el +++ b/test/src/xml-tests.el @@ -1,6 +1,6 @@ -;;; libxml-parse-tests.el --- Test suite for libxml parsing. +;;; xml-tests.el --- Test suite for libxml parsing. -*- lexical-binding: t -*- -;; Copyright (C) 2014-2017 Free Software Foundation, Inc. +;; Copyright (C) 2014-2022 Free Software Foundation, Inc. ;; Author: Ulf Jasper <ulf.jasper@web.de> ;; Keywords: internal @@ -27,6 +27,8 @@ (require 'ert) +(declare-function libxml-parse-xml-region "xml.c") + (defvar libxml-tests--data-comments-preserved `(;; simple case ("<?xml version=\"1.0\"?><foo baz=\"true\">bar</foo>" @@ -42,33 +44,14 @@ (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) - (with-temp-buffer - (dolist (test libxml-tests--data-comments-preserved) - (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-tests.el ends here + (skip-unless (fboundp 'libxml-parse-xml-region)) + (with-temp-buffer + (dolist (test libxml-tests--data-comments-preserved) + (erase-buffer) + (insert (car test)) + (should (equal (cdr test) + (libxml-parse-xml-region (point-min) (point-max))))))) + +;;; xml-tests.el ends here |