summaryrefslogtreecommitdiff
path: root/test/src
diff options
context:
space:
mode:
Diffstat (limited to 'test/src')
-rw-r--r--test/src/buffer-tests.el25
-rw-r--r--test/src/callint-tests.el54
-rw-r--r--test/src/data-tests.el177
-rw-r--r--test/src/editfns-tests.el146
-rw-r--r--test/src/emacs-module-tests.el53
-rw-r--r--test/src/eval-tests.el46
-rw-r--r--test/src/fileio-tests.el18
-rw-r--r--test/src/floatfns-tests.el93
-rw-r--r--test/src/fns-tests.el70
-rw-r--r--test/src/json-tests.el291
-rw-r--r--test/src/lread-tests.el50
-rw-r--r--test/src/print-tests.el58
-rw-r--r--test/src/process-tests.el83
-rw-r--r--test/src/regex-emacs-tests.el (renamed from test/src/regex-tests.el)12
-rw-r--r--test/src/thread-tests.el59
-rw-r--r--test/src/timefns-tests.el144
16 files changed, 1287 insertions, 92 deletions
diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el
index 43b7ea75d50..845d41f9d60 100644
--- a/test/src/buffer-tests.el
+++ b/test/src/buffer-tests.el
@@ -69,4 +69,29 @@ with parameters from the *Messages* buffer modification."
(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)))))
+
;;; 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..feee9b692b7
--- /dev/null
+++ b/test/src/callint-tests.el
@@ -0,0 +1,54 @@
+;;; callint-tests.el --- unit tests for callint.c -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018 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 ((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))))
+
+;;; callint-tests.el ends here
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index 0069ee84fe1..bc77a7be94e 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -113,7 +113,24 @@ most-positive-fixnum, which is just less than a power of 2.")
(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)))
+ (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)
+ always (= (logcount n) (data-tests-popcnt n))))
+ ;; https://oeis.org/A000120
+ (should (= 11 (logcount 9727)))
+ (should (= 8 (logcount 9999))))
;; Bool vector tests. Compactly represent bool vectors as hex
;; strings.
@@ -169,17 +186,17 @@ most-positive-fixnum, which is just less than a power of 2.")
(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))
@@ -467,7 +484,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)
@@ -484,7 +501,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)
@@ -508,4 +525,148 @@ comparing the subr with a much slower lisp implementation."
(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 ()
+ (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-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 (= (lsh most-negative-fixnum 1)
+ (* most-negative-fixnum 2)))
+ (should (= (ash (* 2 most-negative-fixnum) -1)
+ most-negative-fixnum))
+ (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)))
+
;;; data-tests.el ends here
diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el
index 041d21d9c16..d3b0a11d836 100644
--- a/test/src/editfns-tests.el
+++ b/test/src/editfns-tests.el
@@ -150,54 +150,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")))
+
+;;; Perhaps Emacs will be improved someday to return the correct
+;;; answer for positive numbers instead of overflowing; in
+;;; that case these tests will need to be changed. In the meantime make
+;;; sure Emacs is reporting the overflow correctly.
+(ert-deftest format-%x-large-float ()
+ (should-error (format "%x" 18446744073709551616.0)
+ :type 'overflow-error))
+(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))
+ (let ((binary-as-unsigned nil))
+ (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))))))))
+
+(ert-deftest format-%o-invalid-float ()
+ (should-error (format "%o" -1e-37)
+ :type 'overflow-error))
+
+;; 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)
@@ -323,4 +328,49 @@
(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 ()
+ (should (stringp (group-name (group-gid))))
+ (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)))))))))
+
;;; editfns-tests.el ends here
diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el
index 6f4490d9d12..e4593044ecd 100644
--- a/test/src/emacs-module-tests.el
+++ b/test/src/emacs-module-tests.el
@@ -17,7 +17,9 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+(require 'cl-lib)
(require 'ert)
+(require 'help-fns)
(defconst mod-test-emacs
(expand-file-name invocation-name invocation-directory)
@@ -25,12 +27,19 @@
(eval-and-compile
(defconst mod-test-file
- (substitute-in-file-name
- "$EMACS_TEST_DIRECTORY/data/emacs-module/mod-test")
+ (expand-file-name "../test/data/emacs-module/mod-test" invocation-directory)
"File name of the module test file."))
(require 'mod-test mod-test-file)
+(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.
;;
@@ -57,12 +66,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,7 +82,9 @@ 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"
@@ -127,8 +138,9 @@ changes."
(defun multiply-string (s n)
(let ((res ""))
- (dotimes (i n res)
- (setq res (concat res s)))))
+ (dotimes (i n)
+ (setq res (concat res s)))
+ res))
(ert-deftest mod-test-globref-make-test ()
(let ((mod-str (mod-test-globref-make))
@@ -152,6 +164,7 @@ 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))))
@@ -254,4 +267,26 @@ during garbage collection."
(rx "Module function called during garbage collection\n")
(mod-test-invalid-finalizer)))
+(ert-deftest module/describe-function-1 ()
+ "Check that Bug#30163 is fixed."
+ (with-temp-buffer
+ (let ((standard-output (current-buffer)))
+ (describe-function-1 #'mod-test-sum)
+ (should (equal
+ (buffer-substring-no-properties 1 (point-max))
+ (format "a module function in `data/emacs-module/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))))
+
;;; emacs-module-tests.el ends here
diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el
index b7509aed58f..48295b81fa3 100644
--- a/test/src/eval-tests.el
+++ b/test/src/eval-tests.el
@@ -26,6 +26,7 @@
;;; Code:
(require 'ert)
+(eval-when-compile (require 'cl-lib))
(ert-deftest eval-tests--bug24673 ()
"Check that Bug#24673 has been fixed."
@@ -37,8 +38,7 @@
(ert-deftest eval-tests--bugs-24912-and-24913 ()
"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)
+ (dolist (args '((&rest &optional)
(&rest a &optional) (&rest &optional a)
(&optional &optional) (&optional &optional a)
(&optional a &optional b)
@@ -47,7 +47,22 @@ Bug#24912 and Bug#24913."
(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)))))
+ (ert-info ((format "bytecomp: args = %S" args))
+ (should-error (eval `(byte-compile (lambda ,args)) t))))))
+
+(ert-deftest eval-tests-accept-empty-optional-rest ()
+ "Check that Emacs accepts empty &optional and &rest arglists.
+Bug#24912."
+ (dolist (args '((&optional) (&rest) (&optional &rest)
+ (&optional &rest a) (&optional a &rest)))
+ (let ((fun `(lambda ,args 'ok)))
+ (ert-info ("eval")
+ (should (eq (funcall (eval fun t)) '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*))
@@ -99,6 +114,31 @@ crash/abort/malloc assert failure on the next test."
(signal-hook-function #'ignore))
(should-error (eval-tests--exceed-specbind-limit))))
+(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
diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el
index 8853a4e9f7b..6262d946df1 100644
--- a/test/src/fileio-tests.el
+++ b/test/src/fileio-tests.el
@@ -29,11 +29,7 @@
(defun fileio-tests--symlink-failure ()
(let* ((dir (make-temp-file "fileio" t))
- (link (expand-file-name "link" dir))
- (file-name-coding-system (if (and (eq system-type 'darwin)
- (featurep 'ucs-normalize))
- 'utf-8-hfs-unix
- file-name-coding-system)))
+ (link (expand-file-name "link" dir)))
(unwind-protect
(let (failure
(char 0))
@@ -99,3 +95,15 @@ 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 ((old-home (getenv "HOME")))
+ (setenv "HOME" "a/b/c")
+ (should (equal (expand-file-name "~/foo")
+ (expand-file-name "a/b/c/foo")))
+ (when (memq system-type '(ms-dos windows-nt))
+ ;; Test expansion of drive-relative file names.
+ (setenv "HOME" "x:foo")
+ (should (equal (expand-file-name "~/bar") "x:/foo/bar")))
+ (setenv "HOME" old-home)))
diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el
index 6dfd01034eb..643866f1146 100644
--- a/test/src/floatfns-tests.el
+++ b/test/src/floatfns-tests.el
@@ -20,10 +20,10 @@
(require 'ert)
(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 +34,89 @@
(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)
+ -2 -1 0 1 2))
+ (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 ()
+ (let ((ns '(-1e+INF 1e+INF -1 1 -1e+NaN 1e+NaN)))
+ (dolist (n ns)
+ (unless (<= (abs n) 1)
+ (should-error (ceiling n))
+ (should-error (floor n))
+ (should-error (round n))
+ (should-error (truncate n)))
+ (dolist (d ns)
+ (unless (<= (abs (/ n d)) 1)
+ (should-error (ceiling n d))
+ (should-error (floor n d))
+ (should-error (round n d))
+ (should-error (truncate n d)))))))
+
+(ert-deftest big-round ()
+ (should (= (floor 54043195528445955 3)
+ (floor 54043195528445955 3.0))))
+
(provide 'floatfns-tests)
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 0d2a15e758b..3d1a8b37b4e 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -23,6 +23,17 @@
(require 'cl-lib)
+;; 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-reverse ()
(should-error (reverse))
(should-error (reverse 1))
@@ -575,4 +586,63 @@
:type 'wrong-type-argument)
'(wrong-type-argument plistp (:foo 1 . :bar)))))
+(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 "我" "她"))))
+
+(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))))
+
+(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))))))))
+
(provide 'fns-tests)
diff --git a/test/src/json-tests.el b/test/src/json-tests.el
new file mode 100644
index 00000000000..651b0a0bb7a
--- /dev/null
+++ b/test/src/json-tests.el
@@ -0,0 +1,291 @@
+;;; json-tests.el --- unit tests for json.c -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2018 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/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)
+ (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/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)
+ ;; FIXME: Reconsider whether this is the right behavior.
+ (should-error (json-parse-string "[a\\u0000b]") :type 'json-parse-error))
+
+(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
+ (replace-regexp-in-string " " "" 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)))))
+
+(provide 'json-tests)
+;;; json-tests.el ends here
diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index b92dfc18c5c..ae918f03120 100644
--- a/test/src/lread-tests.el
+++ b/test/src/lread-tests.el
@@ -142,6 +142,23 @@ literals (Bug#20852)."
"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))))))
+
(ert-deftest lread-test-bug26837 ()
"Test for https://debbugs.gnu.org/26837 ."
(let ((load-path (cons
@@ -156,13 +173,20 @@ literals (Bug#20852)."
(should (string-suffix-p "/somelib.el" (caar load-history)))))
(ert-deftest lread-tests--old-style-backquotes ()
- "Check that loading warns about old-style backquotes."
+ "Check that loading doesn't accept old-style backquotes."
(lread-tests--with-temp-file file-name
(write-region "(` (a b))" nil file-name)
- (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!")))))
+ (let ((data (should-error (load file-name nil :nomessage :nosuffix))))
+ (should (equal (cdr data)
+ (list (concat (format-message "Loading `%s': " file-name)
+ "old-style backquotes detected!")))))))
+
+(ert-deftest lread-tests--force-new-style-backquotes ()
+ (let ((data (should-error (read "(` (a b))"))))
+ (should (equal (cdr data) '("Old-style backquotes detected!"))))
+ (should (equal (let ((force-new-style-backquotes t))
+ (read "(` (a b))"))
+ '(`(a b)))))
(ert-deftest lread-lread--substitute-object-in-subtree ()
(let ((x (cons 0 1)))
@@ -170,6 +194,9 @@ literals (Bug#20852)."
(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 ";; -*- -:*-")
@@ -178,4 +205,17 @@ literals (Bug#20852)."
;; 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))))))
+
;;; lread-tests.el ends here
diff --git a/test/src/print-tests.el b/test/src/print-tests.el
index bb98443bbe2..8e377d71808 100644
--- a/test/src/print-tests.el
+++ b/test/src/print-tests.el
@@ -27,6 +27,42 @@
(prin1-to-string "\u00A2\ff"))
"\"\\x00a2\\ff\"")))
+(defun print-tests--prints-with-charset-p (ch odd-charset)
+ "Return t if `prin1-to-string' 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"
+ (prin1-to-string
+ (propertize (string ch)
+ 'charset
+ (if odd-charset
+ (cl-find (char-charset ch) charset-list :test-not #'eq)
+ (char-charset ch)))))))
+
+(ert-deftest print-charset-text-property-nil ()
+ (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))))
+
+(ert-deftest print-charset-text-property-default ()
+ (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))))
+
+(ert-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 +94,27 @@
(buffer-string))
"--------\n"))))
+(ert-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 (prin1-to-string sym)) sym))
+ (dolist (sym1 syms)
+ (let ((sym2 (intern (concat (symbol-name sym) (symbol-name sym1)))))
+ (should (eq (read (prin1-to-string sym2)) sym2)))))))
+
+(ert-deftest print-bignum ()
+ (let* ((str "999999999999999999999999999999999")
+ (val (read str)))
+ (should (> val most-positive-fixnum))
+ (should (equal (prin1-to-string val) str))))
+
(provide 'print-tests)
;;; print-tests.el ends here
diff --git a/test/src/process-tests.el b/test/src/process-tests.el
index 7cccc5a02cb..514bd04da4e 100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@ -181,5 +181,88 @@
(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"))
+ ;; 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 (process-live-p process)
+ (accept-process-output 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/file-handler/found ()
+ "Check that the ‘:file-handler’ argument of ‘make-process’
+works as expected if a file name handler is found."
+ (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."
+ (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."
+ (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))
+
(provide 'process-tests)
;; process-tests.el ends here.
diff --git a/test/src/regex-tests.el b/test/src/regex-emacs-tests.el
index 26469c304db..e84af6b131b 100644
--- a/test/src/regex-tests.el
+++ b/test/src/regex-emacs-tests.el
@@ -1,4 +1,4 @@
-;;; 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-2019 Free Software Foundation, Inc.
@@ -24,7 +24,7 @@
(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).
@@ -677,4 +677,10 @@ 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))
+
+;;; regex-emacs-tests.el ends here
diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el
index e8d66b87db3..5e5bfd155fb 100644
--- a/test/src/thread-tests.el
+++ b/test/src/thread-tests.el
@@ -19,6 +19,8 @@
;;; 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))
@@ -34,10 +36,11 @@
(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" ())
+(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."
@@ -71,6 +74,11 @@
(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 ()
@@ -94,15 +102,24 @@
(progn
(setq threads-test-global nil)
(let ((thread (make-thread #'threads-test-thread1)))
- (thread-join thread)
- (and threads-test-global
- (not (thread-live-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."
(skip-unless (featurep 'threads))
(should-error (thread-join (current-thread))))
+(ert-deftest threads-join-error ()
+ "Test of error signalling 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 ()
@@ -191,7 +208,7 @@
(ert-deftest threads-mutex-signal ()
"Test signaling a blocked thread."
(skip-unless (featurep 'threads))
- (should
+ (should-error
(progn
(setq threads-mutex (make-mutex))
(setq threads-mutex-key nil)
@@ -200,8 +217,10 @@
(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))
@@ -275,6 +294,9 @@
(thread-yield))
(should (equal (thread-last-error)
'(error "Error is called")))
+ (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))))
@@ -300,6 +322,25 @@
(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 ()
@@ -347,4 +388,8 @@
(should (= (length (all-threads)) 1))
(should (equal (thread-last-error) '(error "Die, die, die!")))))
+(ert-deftest threads-test-bug33073 ()
+ (let ((th (make-thread 'ignore)))
+ (should-not (equal th main-thread))))
+
;;; threads.el ends here
diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el
new file mode 100644
index 00000000000..ebeb43de163
--- /dev/null
+++ b/test/src/timefns-tests.el
@@ -0,0 +1,144 @@
+;;; timefns-tests.el -- tests for timefns.c
+
+;; Copyright (C) 2016-2018 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+(require 'ert)
+
+;;; 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.
+ (should (string-equal
+ (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" look t)
+ "1972-06-30 23:59:59.999 +0000"))
+ (should (equal (decode-time look t)
+ '(59 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)"))
+ (should (equal (decode-time look "UTC0")
+ '(59 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)"))
+ (should (equal (decode-time look '(-28800 "PST"))
+ '(59 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)")))
+ (should (equal (decode-time look -28800)
+ '(59 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)"))
+ (should (equal (decode-time look "IST-5:30")
+ '(59 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)
+ 1e+INF -1e+INF 1e+NaN -1e+NaN
+ '(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)))
+ (e (encode-time d))
+ (diff (float-time (time-subtract a e))))
+ (should (or (not d)
+ (and (<= 0 diff) (< diff 1))))))))
+
+;;; 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))))
+
+(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)
+ 1e+INF -1e+INF 1e+NaN -1e+NaN
+ '(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)
+ (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))))))))
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-08 01:11:14 +0000