diff options
author | Andrea Corallo <akrl@sdf.org> | 2021-03-09 10:03:47 +0100 |
---|---|---|
committer | Andrea Corallo <akrl@sdf.org> | 2021-03-09 10:03:47 +0100 |
commit | 43b0df62cd5922df5495b3f4aee5b7beca14384f (patch) | |
tree | 3c0bfa9526d08c9c85e646cd355467e3dfb439ac /test/lisp | |
parent | 380ba045c48bfbb160da288b1bd50f82d3f999f0 (diff) | |
parent | 9cbdf20316e1cec835a7dfe28877142e437976f4 (diff) | |
download | emacs-43b0df62cd5922df5495b3f4aee5b7beca14384f.tar.gz emacs-43b0df62cd5922df5495b3f4aee5b7beca14384f.tar.bz2 emacs-43b0df62cd5922df5495b3f4aee5b7beca14384f.zip |
Merge commit '9cbdf20316' into native-comp
Diffstat (limited to 'test/lisp')
-rw-r--r-- | test/lisp/calc/calc-tests.el | 76 | ||||
-rw-r--r-- | test/lisp/custom-tests.el | 160 | ||||
-rw-r--r-- | test/lisp/emacs-lisp/bindat-tests.el | 133 | ||||
-rw-r--r-- | test/lisp/emacs-lisp/bytecomp-tests.el | 23 | ||||
-rw-r--r-- | test/lisp/emacs-lisp/cconv-tests.el | 9 | ||||
-rw-r--r-- | test/lisp/emacs-lisp/checkdoc-tests.el | 42 | ||||
-rw-r--r-- | test/lisp/emacs-lisp/map-tests.el | 474 | ||||
-rw-r--r-- | test/lisp/emacs-lisp/pcase-tests.el | 27 | ||||
-rw-r--r-- | test/lisp/emacs-lisp/rx-tests.el | 8 | ||||
-rw-r--r-- | test/lisp/erc/erc-tests.el | 64 | ||||
-rw-r--r-- | test/lisp/json-tests.el | 194 | ||||
-rw-r--r-- | test/lisp/minibuffer-tests.el | 6 | ||||
-rw-r--r-- | test/lisp/net/puny-tests.el | 6 | ||||
-rw-r--r-- | test/lisp/obsolete/inversion-tests.el (renamed from test/lisp/cedet/inversion-tests.el) | 0 |
14 files changed, 791 insertions, 431 deletions
diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index bdcf78e020a..c5aa5a31eb2 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -707,6 +707,82 @@ An existing calc stack is reused, otherwise a new one is created." (var c var-c)))))) (calc-set-language nil))) +(defvar var-g) + +;; Test `let'. +(defmath test1 (x) + (let ((x (+ x 1)) + (y (+ x 3))) + (let ((z (+ y 6))) + (* x y z g)))) + +;; Test `let*'. +(defmath test2 (x) + (let* ((y (+ x 1)) + (z (+ y 3))) + (let* ((u (+ z 6))) + (* x y z u g)))) + +;; Test `for'. +(defmath test3 (x) + (let ((s 0)) + (for ((ii 1 x) + (jj 1 ii)) + (setq s (+ s (* ii jj)))) + s)) + +;; Test `for' with non-unit stride. +(defmath test4 (x) + (let ((l nil)) + (for ((ii 1 x 1) + (jj 1 10 ii)) + (setq l ('cons jj l))) ; Use Lisp `cons', not `calcFunc-cons'. + (reverse l))) + +;; Test `foreach'. +(defmath test5 (x) + (let ((s 0)) + (foreach ((a x) + (b a)) + (setq s (+ s b))) + s)) + +;; Test `break'. +(defmath test6 (x) + (let ((a (for ((ii 1 10)) + (when (= ii x) + (break (* ii 2))))) + (b (foreach ((e '(9 3 6))) + (when (= e x) + (break (- e 1)))))) + (* a b))) + +;; Test `return' from `for'. +(defmath test7 (x) + (for ((ii 1 10)) + (when (= ii x) + (return (* ii 2)))) + 5) + +(ert-deftest calc-defmath () + (let ((var-g 17)) + (should (equal (calcFunc-test1 2) (* 3 5 11 17))) + (should (equal (calcFunc-test2 2) (* 2 3 6 12 17)))) + (should (equal (calcFunc-test3 3) + (+ (* 1 1) + (* 2 1) (* 2 2) + (* 3 1) (* 3 2) (* 3 3)))) + (should (equal (calcFunc-test4 5) + '( 1 2 3 4 5 6 7 8 9 10 + 1 3 5 7 9 + 1 4 7 10 + 1 5 9 + 1 6))) + (should (equal (calcFunc-test5 '((2 3) (5) (7 11 13))) + (+ 2 3 5 7 11 13))) + (should (equal (calcFunc-test6 3) (* (* 3 2) (- 3 1)))) + (should (equal (calcFunc-test7 3) (* 3 2)))) + (provide 'calc-tests) ;;; calc-tests.el ends here diff --git a/test/lisp/custom-tests.el b/test/lisp/custom-tests.el index 09f79c1a089..02a9239824d 100644 --- a/test/lisp/custom-tests.el +++ b/test/lisp/custom-tests.el @@ -24,70 +24,108 @@ (require 'wid-edit) (require 'cus-edit) -(require 'seq) ; For `seq-find'. + +(defmacro custom-tests--with-temp-dir (&rest body) + "Eval BODY with `temporary-file-directory' bound to a fresh directory. +Ensure the directory is recursively deleted after the fact." + (declare (debug t) (indent 0)) + (let ((dir (make-symbol "dir"))) + `(let ((,dir (file-name-as-directory (make-temp-file "custom-tests-" t)))) + (unwind-protect + (let ((temporary-file-directory ,dir)) + ,@body) + (delete-directory ,dir t))))) (ert-deftest custom-theme--load-path () "Test `custom-theme--load-path' behavior." - (let ((tmpdir (file-name-as-directory (make-temp-file "custom-tests-" t)))) - (unwind-protect - ;; Create all temporary files under the same deletable parent. - (let ((temporary-file-directory tmpdir)) - ;; Path is empty. - (let ((custom-theme-load-path ())) - (should (null (custom-theme--load-path)))) - - ;; Path comprises non-existent file. - (let* ((name (make-temp-name tmpdir)) - (custom-theme-load-path (list name))) - (should (not (file-exists-p name))) - (should (null (custom-theme--load-path)))) - - ;; Path comprises existing file. - (let* ((file (make-temp-file "file")) - (custom-theme-load-path (list file))) - (should (file-exists-p file)) - (should (not (file-directory-p file))) - (should (null (custom-theme--load-path)))) - - ;; Path comprises existing directory. - (let* ((dir (make-temp-file "dir" t)) - (custom-theme-load-path (list dir))) - (should (file-directory-p dir)) - (should (equal (custom-theme--load-path) custom-theme-load-path))) - - ;; Expand `custom-theme-directory' path element. - (let ((custom-theme-load-path '(custom-theme-directory))) - (let ((custom-theme-directory (make-temp-name tmpdir))) - (should (not (file-exists-p custom-theme-directory))) - (should (null (custom-theme--load-path)))) - (let ((custom-theme-directory (make-temp-file "file"))) - (should (file-exists-p custom-theme-directory)) - (should (not (file-directory-p custom-theme-directory))) - (should (null (custom-theme--load-path)))) - (let ((custom-theme-directory (make-temp-file "dir" t))) - (should (file-directory-p custom-theme-directory)) - (should (equal (custom-theme--load-path) - (list custom-theme-directory))))) - - ;; Expand t path element. - (let ((custom-theme-load-path '(t))) - (let ((data-directory (make-temp-name tmpdir))) - (should (not (file-exists-p data-directory))) - (should (null (custom-theme--load-path)))) - (let ((data-directory tmpdir) - (themedir (expand-file-name "themes" tmpdir))) - (should (not (file-exists-p themedir))) - (should (null (custom-theme--load-path))) - (with-temp-file themedir) - (should (file-exists-p themedir)) - (should (not (file-directory-p themedir))) - (should (null (custom-theme--load-path))) - (delete-file themedir) - (make-directory themedir) - (should (file-directory-p themedir)) - (should (equal (custom-theme--load-path) (list themedir)))))) - (when (file-directory-p tmpdir) - (delete-directory tmpdir t))))) + (custom-tests--with-temp-dir + ;; Path is empty. + (let ((custom-theme-load-path ())) + (should (null (custom-theme--load-path)))) + + ;; Path comprises non-existent file. + (let* ((name (make-temp-name temporary-file-directory)) + (custom-theme-load-path (list name))) + (should (not (file-exists-p name))) + (should (null (custom-theme--load-path)))) + + ;; Path comprises existing file. + (let* ((file (make-temp-file "file")) + (custom-theme-load-path (list file))) + (should (file-exists-p file)) + (should (not (file-directory-p file))) + (should (null (custom-theme--load-path)))) + + ;; Path comprises existing directory. + (let* ((dir (make-temp-file "dir" t)) + (custom-theme-load-path (list dir))) + (should (file-directory-p dir)) + (should (equal (custom-theme--load-path) custom-theme-load-path))) + + ;; Expand `custom-theme-directory' path element. + (let ((custom-theme-load-path '(custom-theme-directory))) + (let ((custom-theme-directory (make-temp-name temporary-file-directory))) + (should (not (file-exists-p custom-theme-directory))) + (should (null (custom-theme--load-path)))) + (let ((custom-theme-directory (make-temp-file "file"))) + (should (file-exists-p custom-theme-directory)) + (should (not (file-directory-p custom-theme-directory))) + (should (null (custom-theme--load-path)))) + (let ((custom-theme-directory (make-temp-file "dir" t))) + (should (file-directory-p custom-theme-directory)) + (should (equal (custom-theme--load-path) + (list custom-theme-directory))))) + + ;; Expand t path element. + (let ((custom-theme-load-path '(t))) + (let ((data-directory (make-temp-name temporary-file-directory))) + (should (not (file-exists-p data-directory))) + (should (null (custom-theme--load-path)))) + (let ((data-directory temporary-file-directory) + (themedir (expand-file-name "themes" temporary-file-directory))) + (should (not (file-exists-p themedir))) + (should (null (custom-theme--load-path))) + (with-temp-file themedir) + (should (file-exists-p themedir)) + (should (not (file-directory-p themedir))) + (should (null (custom-theme--load-path))) + (delete-file themedir) + (make-directory themedir) + (should (file-directory-p themedir)) + (should (equal (custom-theme--load-path) (list themedir))))))) + +(ert-deftest custom-tests-require-theme () + "Test `require-theme'." + (custom-tests--with-temp-dir + (let* ((default-directory temporary-file-directory) + (custom-theme-load-path (list default-directory)) + (load-path ())) + ;; Generate some `.el' and `.elc' files. + (with-temp-file "custom-tests--a.el" + (insert "(provide 'custom-tests--a)")) + (make-empty-file "custom-tests--b.el") + (with-temp-file "custom-tests--b.elc" + (byte-compile-insert-header nil (current-buffer)) + (insert "(provide 'custom-tests--b)")) + (make-empty-file "custom-tests--c.el") + (with-temp-file "custom-tests--d.elc" + (byte-compile-insert-header nil (current-buffer))) + ;; Load them. + (dolist (feature '(a b c d e)) + (should-not (featurep (intern (format "custom-tests--%s" feature))))) + (should (eq (require-theme 'custom-tests--a) 'custom-tests--a)) + (delete-file "custom-tests--a.el") + (dolist (feature '(custom-tests--a custom-tests--b)) + (should (eq (require-theme feature) feature)) + (should (featurep feature))) + (dolist (feature '(custom-tests--c custom-tests--d)) + (dolist (noerror '(nil t)) + (let ((err (should-error (require-theme feature noerror)))) + (should (string-search "failed to provide feature" (cadr err)))))) + (should-error (require-theme 'custom-tests--e) :type 'file-missing) + (should-not (require-theme 'custom-tests--e t)) + (dolist (feature '(custom-tests--c custom-tests--d custom-tests--e)) + (should-not (featurep feature)))))) (defcustom custom--test-user-option 'foo "User option for test." diff --git a/test/lisp/emacs-lisp/bindat-tests.el b/test/lisp/emacs-lisp/bindat-tests.el index 72883fc2ec7..911a5f0c7b1 100644 --- a/test/lisp/emacs-lisp/bindat-tests.el +++ b/test/lisp/emacs-lisp/bindat-tests.el @@ -1,4 +1,4 @@ -;;; bindat-tests.el --- tests for bindat.el -*- lexical-binding: t; coding: utf-8; -*- +;;; bindat-tests.el --- tests for bindat.el -*- lexical-binding: t -*- ;; Copyright (C) 2019-2021 Free Software Foundation, Inc. @@ -23,47 +23,50 @@ (require 'bindat) (require 'cl-lib) -(defvar header-bindat-spec - (bindat-spec +(bindat-defmacro ip () "An IPv4 address" '(vec 4 byte)) + +(defconst header-bindat-spec + (bindat-type (dest-ip ip) (src-ip ip) - (dest-port u16) - (src-port u16))) + (dest-port uint 16) + (src-port uint 16))) -(defvar data-bindat-spec - (bindat-spec +(defconst data-bindat-spec + (bindat-type (type u8) (opcode u8) - (length u16r) ;; little endian order + (length uintr 16) ;; little endian order (id strz 8) - (data vec (length)) - (align 4))) + (data vec length) + (_ align 4))) + -(defvar packet-bindat-spec - (bindat-spec - (header struct header-bindat-spec) +(defconst packet-bindat-spec + (bindat-type + (header type header-bindat-spec) (items u8) - (fill 3) - (item repeat (items) - (struct data-bindat-spec)))) + (_ fill 3) + (item repeat items + (_ type data-bindat-spec)))) -(defvar struct-bindat +(defconst struct-bindat '((header (dest-ip . [192 168 1 100]) (src-ip . [192 168 1 101]) (dest-port . 284) (src-port . 5408)) (items . 2) - (item ((data . [1 2 3 4 5]) - (id . "ABCDEF") - (length . 5) + (item ((type . 2) (opcode . 3) - (type . 2)) - ((data . [6 7 8 9 10 11 12]) - (id . "BCDEFG") - (length . 7) + (length . 5) + (id . "ABCDEF") + (data . [1 2 3 4 5])) + ((type . 1) (opcode . 4) - (type . 1))))) + (length . 7) + (id . "BCDEFG") + (data . [6 7 8 9 10 11 12]))))) (ert-deftest bindat-test-pack () (should (equal @@ -77,27 +80,7 @@ (should (equal (bindat-unpack packet-bindat-spec (bindat-pack packet-bindat-spec struct-bindat)) - '((item - ((data . - [1 2 3 4 5]) - (id . "ABCDEF") - (length . 5) - (opcode . 3) - (type . 2)) - ((data . - [6 7 8 9 10 11 12]) - (id . "BCDEFG") - (length . 7) - (opcode . 4) - (type . 1))) - (items . 2) - (header - (src-port . 5408) - (dest-port . 284) - (src-ip . - [192 168 1 101]) - (dest-ip . - [192 168 1 100])))))) + struct-bindat))) (ert-deftest bindat-test-pack/multibyte-string-fails () (should-error (bindat-pack nil nil "ö"))) @@ -121,4 +104,62 @@ (should (equal (bindat-ip-to-string [192 168 0 1]) "192.168.0.1")) (should (equal (bindat-ip-to-string "\300\250\0\1") "192.168.0.1"))) +(defconst bindat-test--int-websocket-type + (bindat-type + :pack-var value + (n1 u8 + :pack-val (if (< value 126) value (if (< value 65536) 126 127))) + (n2 uint (pcase n1 (127 64) (126 16) (_ 0)) + :pack-val value) + :unpack-val (if (< n1 126) n1 n2))) + +(ert-deftest bindat-test--pack-val () + ;; This is intended to test the :(un)pack-val feature that offers + ;; control over the unpacked representation of the data. + (dolist (n '(0 42 125 126 127 128 150 255 5000 65535 65536 8769786876)) + (should + (equal (bindat-unpack bindat-test--int-websocket-type + (bindat-pack bindat-test--int-websocket-type n)) + n)))) + +(ert-deftest bindat-test--sint () + (dotimes (kind 32) + (let ((bitlen (* 8 (/ kind 2))) + (r (zerop (% kind 2)))) + (dotimes (_ 100) + (let* ((n (random (ash 1 bitlen))) + (i (- n (ash 1 (1- bitlen))))) + (should (equal (bindat-unpack + (bindat-type sint bitlen r) + (bindat-pack (bindat-type sint bitlen r) i)) + i)) + (when (>= i 0) + (should (equal (bindat-pack + (bindat-type if r (uintr bitlen) (uint bitlen)) i) + (bindat-pack (bindat-type sint bitlen r) i))) + (should (equal (bindat-unpack + (bindat-type if r (uintr bitlen) (uint bitlen)) + (bindat-pack (bindat-type sint bitlen r) i)) + i)))))))) + +(defconst bindat-test--LEB128 + (bindat-type + letrec ((loop + (struct :pack-var n + (head u8 + :pack-val (+ (logand n 127) (if (> n 127) 128 0))) + (tail if (< head 128) (unit 0) loop + :pack-val (ash n -7)) + :unpack-val (+ (logand head 127) (ash tail 7))))) + loop)) + +(ert-deftest bindat-test--recursive () + (dotimes (n 10) + (let ((max (ash 1 (* n 10)))) + (dotimes (_ 10) + (let ((n (random max))) + (should (equal (bindat-unpack bindat-test--LEB128 + (bindat-pack bindat-test--LEB128 n)) + n))))))) + ;;; bindat-tests.el ends here diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index fb84596ad3f..03c267ccd0f 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1199,6 +1199,29 @@ interpreted and compiled." (should (equal (funcall (eval fun t)) '(c d))) (should (equal (funcall (byte-compile fun)) '(c d)))))) +(ert-deftest bytecomp-reify-function () + "Check that closures that modify their bound variables are +compiled correctly." + (cl-letf ((lexical-binding t) + ((symbol-function 'counter) nil)) + (let ((x 0)) + (defun counter () (cl-incf x)) + (should (equal (counter) 1)) + (should (equal (counter) 2)) + ;; byte compiling should not cause counter to always return the + ;; same value (bug#46834) + (byte-compile 'counter) + (should (equal (counter) 3)) + (should (equal (counter) 4))) + (let ((x 0)) + (let ((x 1)) + (defun counter () x) + (should (equal (counter) 1)) + ;; byte compiling should not cause the outer binding to shadow + ;; the inner one (bug#46834) + (byte-compile 'counter) + (should (equal (counter) 1)))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 517373386e3..5aeed0cc155 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -182,7 +182,14 @@ (should (eq (cconv-tests-cl-defsubst) 'cl-defsubst-result))) (ert-deftest cconv-convert-lambda-lifted () - "Bug#30872." + ;; Verify that lambda-lifting is actually performed at all. + (should (equal (cconv-closure-convert + '#'(lambda (x) (let ((f #'(lambda () (+ x 1)))) + (funcall f)))) + '#'(lambda (x) (let ((f #'(lambda (x) (+ x 1)))) + (funcall f x))))) + + ;; Bug#30872. (should (equal (funcall (byte-compile diff --git a/test/lisp/emacs-lisp/checkdoc-tests.el b/test/lisp/emacs-lisp/checkdoc-tests.el index cf7baf4ce44..7a7aa9fb3cd 100644 --- a/test/lisp/emacs-lisp/checkdoc-tests.el +++ b/test/lisp/emacs-lisp/checkdoc-tests.el @@ -52,49 +52,31 @@ (insert "(cl-defmethod foo ((a (eql smthg)) (b list)) \"Return A+B.\")") (checkdoc-defun))) -(ert-deftest checkdoc-cl-defun-with-key-ok () - "Checkdoc should be happy with a cl-defun using &key." - (with-temp-buffer - (emacs-lisp-mode) - (insert "(cl-defun foo (&key a (b 27)) \"Return :A+:B.\")") - (checkdoc-defun))) - -(ert-deftest checkdoc-cl-defun-with-allow-other-keys-ok () - "Checkdoc should be happy with a cl-defun using &allow-other-keys." - (with-temp-buffer - (emacs-lisp-mode) - (insert "(cl-defun foo (&key a &allow-other-keys) \"Return :A.\")") - (checkdoc-defun))) - -(ert-deftest checkdoc-cl-defun-with-default-optional-value-ok () - "Checkdoc should be happy with a cl-defun using default values for optional args." +(ert-deftest checkdoc-cl-defmethod-qualified-ok () + "Checkdoc should be happy with a `cl-defmethod' using qualifiers." (with-temp-buffer (emacs-lisp-mode) - ;; B is optional and equals 1+a if not provided. HAS-BS is non-nil - ;; if B was provided in the call: - (insert "(cl-defun foo (a &optional (b (1+ a) has-bs)) \"Return A + B.\")") + (insert "(cl-defmethod test :around ((a (eql smthg))) \"Return A.\")") (checkdoc-defun))) -(ert-deftest checkdoc-cl-defun-with-destructuring-ok () - "Checkdoc should be happy with a cl-defun destructuring its arguments." +(ert-deftest checkdoc-cl-defmethod-with-extra-qualifier-ok () + "Checkdoc should be happy with a :extra qualified `cl-defmethod'." (with-temp-buffer (emacs-lisp-mode) - (insert "(cl-defun foo ((a b &optional c) d) \"Return A+B+C+D.\")") - (checkdoc-defun))) + (insert "(cl-defmethod foo :extra \"foo\" ((a (eql smthg))) \"Return A.\")") + (checkdoc-defun)) -(ert-deftest checkdoc-cl-defmethod-ok () - "Checkdoc should be happy with a simple correct cl-defmethod." (with-temp-buffer (emacs-lisp-mode) - (insert "(cl-defmethod foo (a) \"Return A.\")") + (insert + "(cl-defmethod foo :extra \"foo\" :after ((a (eql smthg))) \"Return A.\")") (checkdoc-defun))) -(ert-deftest checkdoc-cl-defmethod-with-types-ok () - "Checkdoc should be happy with a cl-defmethod using types." +(ert-deftest checkdoc-cl-defmethod-with-extra-qualifier-and-nil-args-ok () + "Checkdoc should be happy with a 0-arity :extra qualified `cl-defmethod'." (with-temp-buffer (emacs-lisp-mode) - ;; this method matches if A is the symbol `smthg' and if b is a list: - (insert "(cl-defmethod foo ((a (eql smthg)) (b list)) \"Return A+B.\")") + (insert "(cl-defmethod foo :extra \"foo\" () \"Return A.\")") (checkdoc-defun))) (ert-deftest checkdoc-cl-defun-with-key-ok () diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 9a2cd42a211..67666d8e7e7 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -22,7 +22,7 @@ ;;; Commentary: -;; Tests for map.el +;; Tests for map.el. ;;; Code: @@ -30,12 +30,10 @@ (require 'map) (defmacro with-maps-do (var &rest body) - "Successively bind VAR to an alist, vector and hash-table. + "Successively bind VAR to an alist, plist, vector, and hash-table. Each map is built from the following alist data: -'((0 . 3) (1 . 4) (2 . 5)). -Evaluate BODY for each created map. - -\(fn (var map) body)" + \\='((0 . 3) (1 . 4) (2 . 5)). +Evaluate BODY for each created map." (declare (indent 1) (debug (symbolp body))) (let ((alist (make-symbol "alist")) (plist (make-symbol "plist")) @@ -53,43 +51,62 @@ Evaluate BODY for each created map. (dolist (,var (list ,alist ,plist ,vec ,ht)) ,@body)))) +(defmacro with-empty-maps-do (var &rest body) + "Like `with-maps-do', but with empty maps." + (declare (indent 1) (debug (symbolp body))) + `(dolist (,var (list (list) (vector) (make-hash-table))) + ,@body)) + +(ert-deftest test-map-plist-p () + "Test `map--plist-p'." + (with-empty-maps-do map + (should-not (map--plist-p map))) + (should-not (map--plist-p "")) + (should-not (map--plist-p '((())))) + (should (map--plist-p '(:a))) + (should (map--plist-p '(a))) + (should (map--plist-p '(nil))) + (should (map--plist-p '("")))) + (ert-deftest test-map-elt () (with-maps-do map (should (= 3 (map-elt map 0))) (should (= 4 (map-elt map 1))) (should (= 5 (map-elt map 2))) - (should (null (map-elt map -1))) - (should (null (map-elt map 4))))) + (should-not (map-elt map -1)) + (should-not (map-elt map 4)) + (should-not (map-elt map 0.1)))) (ert-deftest test-map-elt-default () (with-maps-do map - (should (= 5 (map-elt map 7 5))))) + (should (= 5 (map-elt map 7 5))) + (should (= 5 (map-elt map 0.1 5)))) + (with-empty-maps-do map + (should (= 5 (map-elt map 0 5))))) (ert-deftest test-map-elt-testfn () (let ((map (list (cons "a" 1) (cons "b" 2))) ;; Make sure to use a non-eq "a", even when compiled. (noneq-key (string ?a))) (should-not (map-elt map noneq-key)) - (should (map-elt map noneq-key nil 'equal)))) + (should (map-elt map noneq-key nil #'equal)))) (ert-deftest test-map-elt-with-nil-value () - (should (null (map-elt '((a . 1) - (b)) - 'b - '2)))) + (should-not (map-elt '((a . 1) (b)) 'b 2))) (ert-deftest test-map-put! () (with-maps-do map (setf (map-elt map 2) 'hello) (should (eq (map-elt map 2) 'hello))) (with-maps-do map - (map-put map 2 'hello) + (with-suppressed-warnings ((obsolete map-put)) + (map-put map 2 'hello)) (should (eq (map-elt map 2) 'hello))) (with-maps-do map (map-put! map 2 'hello) (should (eq (map-elt map 2) 'hello)) (if (not (or (hash-table-p map) - (and (listp map) (not (listp (car map)))))) ;plist! + (map--plist-p map))) (should-error (map-put! map 5 'value) ;; For vectors, it could arguably signal ;; map-not-inplace as well, but it currently doesn't. @@ -97,49 +114,88 @@ Evaluate BODY for each created map. 'map-not-inplace 'error)) (map-put! map 5 'value) - (should (eq (map-elt map 5) 'value)))) - (let ((ht (make-hash-table))) - (setf (map-elt ht 2) 'a) - (should (eq (map-elt ht 2) - 'a))) - (let ((alist '((0 . a) (1 . b) (2 . c)))) - (setf (map-elt alist 2) 'a) - (should (eq (map-elt alist 2) - 'a))) - (let ((vec [3 4 5])) - (should-error (setf (map-elt vec 3) 6)))) + (should (eq (map-elt map 5) 'value))))) + +(ert-deftest test-map-put!-new-keys () + "Test `map-put!' with new keys." + (with-maps-do map + (let ((size (map-length map))) + (if (arrayp map) + (progn + (should-error (setf (map-elt map 'k) 'v)) + (should-error (setf (map-elt map size) 'v))) + (setf (map-elt map 'k) 'v) + (should (eq (map-elt map 'k) 'v)) + (setf (map-elt map size) 'v) + (should (eq (map-elt map size) 'v)))))) (ert-deftest test-map-put-alist-new-key () "Regression test for Bug#23105." - (let ((alist '((0 . a)))) - (map-put alist 2 'b) - (should (eq (map-elt alist 2) - 'b)))) + (let ((alist (list (cons 0 'a)))) + (with-suppressed-warnings ((obsolete map-put)) + (map-put alist 2 'b)) + (should (eq (map-elt alist 2) 'b)))) (ert-deftest test-map-put-testfn-alist () (let ((alist (list (cons "a" 1) (cons "b" 2))) ;; Make sure to use a non-eq "a", even when compiled. (noneq-key (string ?a))) - (map-put alist noneq-key 3 #'equal) - (should-not (cddr alist)) - (map-put alist noneq-key 9 #'eql) - (should (cddr alist)))) + (with-suppressed-warnings ((obsolete map-put)) + (map-put alist noneq-key 3 #'equal) + (should-not (cddr alist)) + (map-put alist noneq-key 9 #'eql) + (should (cddr alist))))) (ert-deftest test-map-put-return-value () (let ((ht (make-hash-table))) - (should (eq (map-put ht 'a 'hello) 'hello)))) + (with-suppressed-warnings ((obsolete map-put)) + (should (eq (map-put ht 'a 'hello) 'hello))))) + +(ert-deftest test-map-insert-empty () + "Test `map-insert' on empty maps." + (with-empty-maps-do map + (if (arrayp map) + (should-error (map-insert map 0 6)) + (let ((new (map-insert map 0 6))) + (should-not (eq map new)) + (should-not (map-pairs map)) + (should (= (map-elt new 0) 6)))))) + +(ert-deftest test-map-insert () + "Test `map-insert'." + (with-maps-do map + (let ((pairs (map-pairs map)) + (size (map-length map)) + (new (map-insert map 0 6))) + (should-not (eq map new)) + (should (equal (map-pairs map) pairs)) + (should (= (map-elt new 0) 6)) + (if (arrayp map) + (should-error (map-insert map size 7)) + (setq new (map-insert map size 7)) + (should-not (eq map new)) + (should (equal (map-pairs map) pairs)) + (should (= (map-elt new size) 7)))))) (ert-deftest test-map-delete () (with-maps-do map - (map-delete map 1) - (should (null (map-elt map 1)))) + (should (map-elt map 1)) + (should (eq map (map-delete map 1))) + (should-not (map-elt map 1))) (with-maps-do map - (map-delete map -2) - (should (null (map-elt map -2))))) + (should-not (map-elt map -2)) + (should (eq map (map-delete map -2))) + (should-not (map-elt map -2))) + (with-maps-do map + ;; Check for OBOE. + (let ((key (map-length map))) + (should-not (map-elt map key)) + (should (eq map (map-delete map key))) + (should-not (map-elt map key))))) -(ert-deftest test-map-delete-return-value () - (let ((ht (make-hash-table))) - (should (eq (map-delete ht 'a) ht)))) +(ert-deftest test-map-delete-empty () + (with-empty-maps-do map + (should (eq map (map-delete map t))))) (ert-deftest test-map-nested-elt () (let ((vec [a b [c d [e f]]])) @@ -149,8 +205,9 @@ Evaluate BODY for each created map. (d . 3) (e . ((f . 4) (g . 5)))))))) - (should (eq (map-nested-elt alist '(b e f)) - 4))) + (should (eq (map-nested-elt alist '(b e f)) 4))) + (let ((plist '(a 1 b (c 2 d 3 e (f 4 g 5))))) + (should (eq (map-nested-elt plist '(b e f)) 4))) (let ((ht (make-hash-table))) (setf (map-elt ht 'a) 1) (setf (map-elt ht 'b) (make-hash-table)) @@ -160,214 +217,238 @@ Evaluate BODY for each created map. (ert-deftest test-map-nested-elt-default () (let ((vec [a b [c d]])) - (should (null (map-nested-elt vec '(2 3)))) - (should (null (map-nested-elt vec '(2 1 1)))) + (should-not (map-nested-elt vec '(2 3))) + (should-not (map-nested-elt vec '(2 1 1))) (should (= 4 (map-nested-elt vec '(2 1 1) 4))))) (ert-deftest test-mapp () - (should (mapp nil)) - (should (mapp '((a . b) (c . d)))) - (should (mapp '(a b c d))) - (should (mapp [])) - (should (mapp [1 2 3])) - (should (mapp (make-hash-table))) + (with-empty-maps-do map + (should (mapp map))) + (with-maps-do map + (should (mapp map))) + (should (mapp "")) (should (mapp "hello")) - (should (not (mapp 1))) - (should (not (mapp 'hello)))) + (should-not (mapp 1)) + (should-not (mapp 'hello))) (ert-deftest test-map-keys () (with-maps-do map (should (equal (map-keys map) '(0 1 2)))) - (should (null (map-keys nil))) - (should (null (map-keys [])))) + (with-empty-maps-do map + (should-not (map-keys map)))) (ert-deftest test-map-values () (with-maps-do map - (should (equal (map-values map) '(3 4 5))))) + (should (equal (map-values map) '(3 4 5)))) + (with-empty-maps-do map + (should-not (map-values map)))) (ert-deftest test-map-pairs () (with-maps-do map - (should (equal (map-pairs map) '((0 . 3) - (1 . 4) - (2 . 5)))))) + (should (equal (map-pairs map) + '((0 . 3) + (1 . 4) + (2 . 5))))) + (with-empty-maps-do map + (should-not (map-pairs map)))) (ert-deftest test-map-length () - (let ((ht (make-hash-table))) - (puthash 'a 1 ht) - (puthash 'b 2 ht) - (puthash 'c 3 ht) - (puthash 'd 4 ht) - (should (= 0 (map-length nil))) - (should (= 0 (map-length []))) - (should (= 0 (map-length (make-hash-table)))) - (should (= 5 (map-length [0 1 2 3 4]))) - (should (= 2 (map-length '((a . 1) (b . 2))))) - (should (= 4 (map-length ht))))) + (with-empty-maps-do map + (should (zerop (map-length map)))) + (with-maps-do map + (should (= 3 (map-length map)))) + (should (= 1 (map-length '(nil 1)))) + (should (= 2 (map-length '(nil 1 t 2)))) + (should (= 2 (map-length '((a . 1) (b . 2))))) + (should (= 5 (map-length [0 1 2 3 4]))) + (should (= 4 (map-length #s(hash-table data (a 1 b 2 c 3 d 4)))))) (ert-deftest test-map-copy () (with-maps-do map (let ((copy (map-copy map))) - (should (equal (map-keys map) (map-keys copy))) - (should (equal (map-values map) (map-values copy))) - (should (not (eq map copy)))))) + (should (equal (map-pairs map) (map-pairs copy))) + (should-not (eq map copy)) + (map-put! map 0 0) + (should-not (equal (map-pairs map) (map-pairs copy))))) + (with-empty-maps-do map + (should-not (map-pairs (map-copy map))))) + +(ert-deftest test-map-copy-alist () + "Test use of `copy-alist' for alists." + (let* ((cons (list 'a 1 2)) + (alist (list cons)) + (copy (map-copy alist))) + (setcar cons 'b) + (should (equal alist '((b 1 2)))) + (should (equal copy '((a 1 2)))) + (setcar (cdr cons) 0) + (should (equal alist '((b 0 2)))) + (should (equal copy '((a 0 2)))) + (setcdr cons 3) + (should (equal alist '((b . 3)))) + (should (equal copy '((a 0 2)))))) (ert-deftest test-map-apply () - (with-maps-do map - (should (equal (map-apply (lambda (k v) (cons (int-to-string k) v)) - map) - '(("0" . 3) ("1" . 4) ("2" . 5))))) - (let ((vec [a b c])) - (should (equal (map-apply (lambda (k v) (cons (1+ k) v)) - vec) - '((1 . a) - (2 . b) - (3 . c)))))) + (let ((fn (lambda (k v) (cons (number-to-string k) v)))) + (with-maps-do map + (should (equal (map-apply fn map) + '(("0" . 3) ("1" . 4) ("2" . 5))))) + (with-empty-maps-do map + (should-not (map-apply fn map))))) (ert-deftest test-map-do () - (with-maps-do map - (let ((result nil)) - (map-do (lambda (k v) - (push (list (int-to-string k) v) result)) - map) - (should (equal result '(("2" 5) ("1" 4) ("0" 3))))))) + (let* (res + (fn (lambda (k v) + (push (list (number-to-string k) v) res)))) + (with-empty-maps-do map + (should-not (map-do fn map)) + (should-not res)) + (with-maps-do map + (setq res nil) + (should-not (map-do fn map)) + (should (equal res '(("2" 5) ("1" 4) ("0" 3))))))) (ert-deftest test-map-keys-apply () (with-maps-do map - (should (equal (map-keys-apply (lambda (k) (int-to-string k)) - map) - '("0" "1" "2")))) - (let ((vec [a b c])) - (should (equal (map-keys-apply (lambda (k) (1+ k)) - vec) - '(1 2 3))))) + (should (equal (map-keys-apply #'1+ map) '(1 2 3)))) + (with-empty-maps-do map + (let (ks) + (should-not (map-keys-apply (lambda (k) (push k ks)) map)) + (should-not ks)))) (ert-deftest test-map-values-apply () (with-maps-do map - (should (equal (map-values-apply (lambda (v) (1+ v)) - map) - '(4 5 6)))) - (let ((vec [a b c])) - (should (equal (map-values-apply (lambda (v) (symbol-name v)) - vec) - '("a" "b" "c"))))) + (should (equal (map-values-apply #'1+ map) '(4 5 6)))) + (with-empty-maps-do map + (let (vs) + (should-not (map-values-apply (lambda (v) (push v vs)) map)) + (should-not vs)))) (ert-deftest test-map-filter () (with-maps-do map - (should (equal (map-keys (map-filter (lambda (_k v) - (<= 4 v)) - map)) - '(1 2))) - (should (null (map-filter (lambda (k _v) - (eq 'd k)) - map)))) - (should (null (map-filter (lambda (_k v) - (eq 3 v)) - [1 2 4 5]))) - (should (equal (map-filter (lambda (k _v) - (eq 3 k)) - [1 2 4 5]) - '((3 . 5))))) + (should (equal (map-filter (lambda (_k v) (> v 3)) map) + '((1 . 4) (2 . 5)))) + (should (equal (map-filter #'always map) (map-pairs map))) + (should-not (map-filter #'ignore map))) + (with-empty-maps-do map + (should-not (map-filter #'always map)) + (should-not (map-filter #'ignore map)))) (ert-deftest test-map-remove () (with-maps-do map - (should (equal (map-keys (map-remove (lambda (_k v) - (>= v 4)) - map)) - '(0))) - (should (equal (map-keys (map-remove (lambda (k _v) - (eq 'd k)) - map)) - (map-keys map)))) - (should (equal (map-remove (lambda (_k v) - (eq 3 v)) - [1 2 4 5]) - '((0 . 1) - (1 . 2) - (2 . 4) - (3 . 5)))) - (should (null (map-remove (lambda (k _v) - (>= k 0)) - [1 2 4 5])))) + (should (equal (map-remove (lambda (_k v) (> v 3)) map) + '((0 . 3)))) + (should (equal (map-remove #'ignore map) (map-pairs map))) + (should-not (map-remove #'always map))) + (with-empty-maps-do map + (should-not (map-remove #'always map)) + (should-not (map-remove #'ignore map)))) (ert-deftest test-map-empty-p () - (should (map-empty-p nil)) - (should (not (map-empty-p '((a . b) (c . d))))) - (should (map-empty-p [])) - (should (not (map-empty-p [1 2 3]))) - (should (map-empty-p (make-hash-table))) - (should (not (map-empty-p "hello"))) - (should (map-empty-p ""))) + (with-empty-maps-do map + (should (map-empty-p map))) + (should (map-empty-p "")) + (should-not (map-empty-p '((a . b) (c . d)))) + (should-not (map-empty-p [1 2 3])) + (should-not (map-empty-p "hello"))) (ert-deftest test-map-contains-key () - (should (map-contains-key '((a . 1) (b . 2)) 'a)) - (should (not (map-contains-key '((a . 1) (b . 2)) 'c))) - (should (map-contains-key '(("a" . 1)) "a")) - (should (not (map-contains-key '(("a" . 1)) "a" #'eq))) - (should (map-contains-key [a b c] 2)) - (should (not (map-contains-key [a b c] 3)))) + (with-empty-maps-do map + (should-not (map-contains-key map -1)) + (should-not (map-contains-key map 0)) + (should-not (map-contains-key map 1)) + (should-not (map-contains-key map (map-length map)))) + (with-maps-do map + (should-not (map-contains-key map -1)) + (should (map-contains-key map 0)) + (should (map-contains-key map 1)) + (should-not (map-contains-key map (map-length map))))) + +(ert-deftest test-map-contains-key-testfn () + "Test `map-contains-key' under different equalities." + (let ((key (string ?a)) + (plist '("a" 1 a 2)) + (alist '(("a" . 1) (a . 2)))) + (should (map-contains-key alist 'a)) + (should (map-contains-key plist 'a)) + (should (map-contains-key alist 'a #'eq)) + (should (map-contains-key plist 'a #'eq)) + (should (map-contains-key alist key)) + (should-not (map-contains-key plist key)) + (should-not (map-contains-key alist key #'eq)) + (should-not (map-contains-key plist key #'eq)))) (ert-deftest test-map-some () (with-maps-do map - (should (map-some (lambda (k _v) - (eq 1 k)) - map)) - (should-not (map-some (lambda (k _v) - (eq 'd k)) - map))) - (let ((vec [a b c])) - (should (map-some (lambda (k _v) - (> k 1)) - vec)) - (should-not (map-some (lambda (k _v) - (> k 3)) - vec)))) + (should (eq (map-some (lambda (k _v) (and (= k 1) 'found)) map) + 'found)) + (should-not (map-some #'ignore map))) + (with-empty-maps-do map + (should-not (map-some #'always map)) + (should-not (map-some #'ignore map)))) (ert-deftest test-map-every-p () (with-maps-do map - (should (map-every-p (lambda (k _v) - k) - map)) - (should (not (map-every-p (lambda (_k _v) - nil) - map)))) - (let ((vec [a b c])) - (should (map-every-p (lambda (k _v) - (>= k 0)) - vec)) - (should (not (map-every-p (lambda (k _v) - (> k 3)) - vec))))) + (should (map-every-p #'always map)) + (should-not (map-every-p #'ignore map)) + (should-not (map-every-p (lambda (k _v) (zerop k)) map))) + (with-empty-maps-do map + (should (map-every-p #'always map)) + (should (map-every-p #'ignore map)) + (should (map-every-p (lambda (k _v) (zerop k)) map)))) (ert-deftest test-map-into () - (let* ((alist '((a . 1) (b . 2))) + (let* ((plist '(a 1 b 2)) + (alist '((a . 1) (b . 2))) (ht (map-into alist 'hash-table)) (ht2 (map-into alist '(hash-table :test equal)))) (should (hash-table-p ht)) - (should (equal (map-into (map-into alist 'hash-table) 'list) - alist)) - (should (listp (map-into ht 'list))) - (should (equal (map-keys (map-into (map-into ht 'list) 'hash-table)) - (map-keys ht))) - (should (equal (map-values (map-into (map-into ht 'list) 'hash-table)) - (map-values ht))) + (should (equal (map-into ht 'list) alist)) + (should (equal (map-pairs (map-into (map-into ht 'list) 'hash-table)) + (map-pairs ht))) (should (equal (map-into ht 'alist) (map-into ht2 'alist))) - (should (eq (hash-table-test ht2) 'equal)) - (should (null (map-into nil 'list))) - (should (map-empty-p (map-into nil 'hash-table))) - (should-error (map-into [1 2 3] 'string)))) + (should (equal (map-into alist 'list) alist)) + (should (equal (map-into alist 'alist) alist)) + (should (equal (map-into alist 'plist) plist)) + (should (equal (map-into plist 'alist) alist)) + (should (equal (map-into plist 'plist) plist))) + (should-error (map-into [1 2 3] 'string) :type 'cl-no-applicable-method)) + +(ert-deftest test-map-into-hash-test () + "Test `map-into' with different hash-table test functions." + (should (eq (hash-table-test (map-into () 'hash-table)) #'equal)) + (should (eq (hash-table-test (map-into () '(hash-table))) #'eql)) + (should (eq (hash-table-test (map-into () '(hash-table :test eq))) #'eq)) + (should (eq (hash-table-test (map-into () '(hash-table :test eql))) #'eql)) + (should (eq (hash-table-test (map-into () '(hash-table :test equal))) + #'equal))) + +(ert-deftest test-map-into-empty () + "Test `map-into' with empty maps." + (with-empty-maps-do map + (should-not (map-into map 'list)) + (should-not (map-into map 'alist)) + (should-not (map-into map 'plist)) + (should (map-empty-p (map-into map 'hash-table))))) (ert-deftest test-map-let () (map-let (foo bar baz) '((foo . 1) (bar . 2)) (should (= foo 1)) (should (= bar 2)) - (should (null baz))) + (should-not baz)) (map-let (('foo a) ('bar b) ('baz c)) '((foo . 1) (bar . 2)) (should (= a 1)) (should (= b 2)) - (should (null c)))) + (should-not c))) + +(ert-deftest test-map-merge () + "Test `map-merge'." + (should (equal (map-merge 'list '(a 1) '((b . 2) (c . 3)) + #s(hash-table data (c 4))) + '((c . 4) (b . 2) (a . 1))))) (ert-deftest test-map-merge-with () (should (equal (map-merge-with 'list #'+ @@ -376,6 +457,19 @@ Evaluate BODY for each created map. '((1 . 1) (2 . 5) (3 . 0))) '((3 . 0) (2 . 9) (1 . 6))))) +(ert-deftest test-map-merge-empty () + "Test merging of empty maps." + (should-not (map-merge 'list)) + (should-not (map-merge 'alist)) + (should-not (map-merge 'plist)) + (should-not (map-merge-with 'list #'+)) + (should-not (map-merge-with 'alist #'+)) + (should-not (map-merge-with 'plist #'+)) + (should (map-empty-p (map-merge 'hash-table))) + (should (map-empty-p (map-merge-with 'hash-table #'+))) + (should-error (map-merge 'array) :type 'cl-no-applicable-method) + (should-error (map-merge-with 'array #'+) :type 'cl-no-applicable-method)) + (ert-deftest test-map-plist-pcase () (let ((plist '(:one 1 :two 2))) (should (equal (pcase-let (((map :one (:two two)) plist)) diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index e6f4c097504..2120139ec18 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -75,8 +75,29 @@ (ert-deftest pcase-tests-vectors () (should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3))) -;; Local Variables: -;; no-byte-compile: t -;; End: +(ert-deftest pcase-tests-bug14773 () + (let ((f (lambda (x) + (pcase 'dummy + ((and (let var x) (guard var)) 'left) + ((and (let var (not x)) (guard var)) 'right))))) + (should (equal (funcall f t) 'left)) + (should (equal (funcall f nil) 'right)))) + +(ert-deftest pcase-tests-bug46786 () + (let ((self 'outer)) + (ignore self) + (should (equal (cl-macrolet ((show-self () `(list 'self self))) + (pcase-let ((`(,self ,_self2) '(inner "2"))) + (show-self))) + '(self inner))))) + +(ert-deftest pcase-tests-or-vars () + (let ((f (lambda (v) + (pcase v + ((or (and 'b1 (let x1 4) (let x2 5)) + (and 'b2 (let y1 8) (let y2 9))) + (list x1 x2 y1 y2)))))) + (should (equal (funcall f 'b1) '(4 5 nil nil))) + (should (equal (funcall f 'b2) '(nil nil 8 9))))) ;;; pcase-tests.el ends here. diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index fecdcf55aff..2dd1bca22d1 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -156,6 +156,8 @@ "....."))) (ert-deftest rx-pcase () + (should (equal (pcase "i18n" ((rx (let x (+ digit))) (list 'ok x))) + '(ok "18"))) (should (equal (pcase "a 1 2 3 1 1 b" ((rx (let u (+ digit)) space (let v (+ digit)) space @@ -176,6 +178,12 @@ ((rx nonl) 'wrong) (_ 'correct)) 'correct)) + (should (equal (pcase "PQR" + ((and (rx (let a nonl)) (rx ?z)) + (list 'one a)) + ((rx (let b ?Q)) + (list 'two b))) + '(two "Q"))) (should (equal (pcase-let (((rx ?B (let z nonl)) "ABC")) (list 'ok z)) '(ok "C"))) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 26e14b98e91..d13397274aa 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -23,6 +23,7 @@ (require 'ert) (require 'erc) +(require 'erc-ring) (ert-deftest erc--read-time-period () (cl-letf (((symbol-function 'read-string) (lambda (&rest _) ""))) @@ -45,3 +46,66 @@ (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1d"))) (should (equal (erc--read-time-period "foo: ") 86400)))) + +(ert-deftest erc-ring-previous-command-base-case () + (ert-info ("Create ring when nonexistent and do nothing") + (let (erc-input-ring + erc-input-ring-index) + (erc-previous-command) + (should (ring-p erc-input-ring)) + (should (zerop (ring-length erc-input-ring))) + (should-not erc-input-ring-index))) + (should-not erc-input-ring)) + +(ert-deftest erc-ring-previous-command () + (with-current-buffer (get-buffer-create "*#fake*") + (erc-mode) + (insert "\n\n") + (setq erc-input-marker (make-marker) ; these are all local + erc-insert-marker (make-marker) + erc-send-completed-hook nil) + (set-marker erc-insert-marker (point-max)) + (erc-display-prompt) + (should (= (point) erc-input-marker)) + (add-hook 'erc-pre-send-functions #'erc-add-to-input-ring nil t) + ;; + (cl-letf (((symbol-function 'erc-process-input-line) + (lambda (&rest _) + (insert-before-markers + (erc-display-message-highlight 'notice "echo: one\n")))) + ((symbol-function 'erc-command-no-process-p) + (lambda (&rest _) t))) + (ert-info ("Create ring, populate, recall") + (insert "/one") + (erc-send-current-line) + (should (ring-p erc-input-ring)) + (should (zerop (ring-member erc-input-ring "/one"))) ; equal + (should (save-excursion (forward-line -1) (goto-char (point-at-bol)) + (looking-at-p "[*]+ echo: one"))) + (should-not erc-input-ring-index) + (erc-bol) + (should (looking-at "$")) + (erc-previous-command) + (erc-bol) + (should (looking-at "/one")) + (should (zerop erc-input-ring-index))) + (ert-info ("Back to one") + (should (= (ring-length erc-input-ring) (1+ erc-input-ring-index))) + (erc-previous-command) + (should-not erc-input-ring-index) + (erc-bol) + (should (looking-at "$")) + (should (equal (ring-ref erc-input-ring 0) "/one"))) + (ert-info ("Swap input after prompt with previous (#bug46339)") + (insert "abc") + (erc-previous-command) + (should (= 1 erc-input-ring-index)) + (erc-bol) + (should (looking-at "/one")) + (should (equal (ring-ref erc-input-ring 0) "abc")) + (should (equal (ring-ref erc-input-ring 1) "/one")) + (erc-next-command) + (erc-bol) + (should (looking-at "abc"))))) + (when noninteractive + (kill-buffer "*#fake*"))) diff --git a/test/lisp/json-tests.el b/test/lisp/json-tests.el index 9886dc0d457..f400fb064a6 100644 --- a/test/lisp/json-tests.el +++ b/test/lisp/json-tests.el @@ -329,13 +329,13 @@ Point is moved to beginning of the buffer." (should (equal (read str) res))))))) (ert-deftest test-json-encode-number () - (should (equal (json-encode-number 0) "0")) - (should (equal (json-encode-number -0) "0")) - (should (equal (json-encode-number 3) "3")) - (should (equal (json-encode-number -5) "-5")) - (should (equal (json-encode-number 123.456) "123.456")) + (should (equal (json-encode 0) "0")) + (should (equal (json-encode -0) "0")) + (should (equal (json-encode 3) "3")) + (should (equal (json-encode -5) "-5")) + (should (equal (json-encode 123.456) "123.456")) (let ((bignum (1+ most-positive-fixnum))) - (should (equal (json-encode-number bignum) + (should (equal (json-encode bignum) (number-to-string bignum))))) ;;; Strings @@ -404,6 +404,8 @@ Point is moved to beginning of the buffer." (should (equal (json-read-string) "abcαβγ"))) (json-tests--with-temp-buffer "\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"" (should (equal (json-read-string) "\nasdфывfgh\t"))) + (json-tests--with-temp-buffer "\"abc\uFFFFαβγ𝔸𝐁𝖢\\\"\\\\\"" + (should (equal (json-read-string) "abc\uFFFFαβγ𝔸𝐁𝖢\"\\"))) ;; Bug#24784 (json-tests--with-temp-buffer "\"\\uD834\\uDD1E\"" (should (equal (json-read-string) "\U0001D11E"))) @@ -418,30 +420,37 @@ Point is moved to beginning of the buffer." (should (equal (json-encode-string "foo") "\"foo\"")) (should (equal (json-encode-string "a\n\fb") "\"a\\n\\fb\"")) (should (equal (json-encode-string "\nasdфыв\u001f\u007ffgh\t") - "\"\\nasdфыв\\u001f\u007ffgh\\t\""))) + "\"\\nasdфыв\\u001f\u007ffgh\\t\"")) + ;; Bug#43549. + (should (equal (json-encode-string (propertize "foo" 'read-only t)) + "\"foo\"")) + (should (equal (json-encode-string "a\0b") "\"a\\u0000b\"")) + (should (equal (json-encode-string "abc\uFFFFαβγ𝔸𝐁𝖢\"\\") + "\"abc\uFFFFαβγ𝔸𝐁𝖢\\\"\\\\\""))) (ert-deftest test-json-encode-key () - (should (equal (json-encode-key '##) "\"\"")) - (should (equal (json-encode-key :) "\"\"")) - (should (equal (json-encode-key "") "\"\"")) - (should (equal (json-encode-key 'a) "\"a\"")) - (should (equal (json-encode-key :a) "\"a\"")) - (should (equal (json-encode-key "a") "\"a\"")) - (should (equal (json-encode-key t) "\"t\"")) - (should (equal (json-encode-key :t) "\"t\"")) - (should (equal (json-encode-key "t") "\"t\"")) - (should (equal (json-encode-key nil) "\"nil\"")) - (should (equal (json-encode-key :nil) "\"nil\"")) - (should (equal (json-encode-key "nil") "\"nil\"")) - (should (equal (json-encode-key ":a") "\":a\"")) - (should (equal (json-encode-key ":t") "\":t\"")) - (should (equal (json-encode-key ":nil") "\":nil\"")) - (should (equal (should-error (json-encode-key 5)) - '(json-key-format 5))) - (should (equal (should-error (json-encode-key ["foo"])) - '(json-key-format ["foo"]))) - (should (equal (should-error (json-encode-key '("foo"))) - '(json-key-format ("foo"))))) + (with-suppressed-warnings ((obsolete json-encode-key)) + (should (equal (json-encode-key '##) "\"\"")) + (should (equal (json-encode-key :) "\"\"")) + (should (equal (json-encode-key "") "\"\"")) + (should (equal (json-encode-key 'a) "\"a\"")) + (should (equal (json-encode-key :a) "\"a\"")) + (should (equal (json-encode-key "a") "\"a\"")) + (should (equal (json-encode-key t) "\"t\"")) + (should (equal (json-encode-key :t) "\"t\"")) + (should (equal (json-encode-key "t") "\"t\"")) + (should (equal (json-encode-key nil) "\"nil\"")) + (should (equal (json-encode-key :nil) "\"nil\"")) + (should (equal (json-encode-key "nil") "\"nil\"")) + (should (equal (json-encode-key ":a") "\":a\"")) + (should (equal (json-encode-key ":t") "\":t\"")) + (should (equal (json-encode-key ":nil") "\":nil\"")) + (should (equal (should-error (json-encode-key 5)) + '(json-key-format 5))) + (should (equal (should-error (json-encode-key ["foo"])) + '(json-key-format ["foo"]))) + (should (equal (should-error (json-encode-key '("foo"))) + '(json-key-format ("foo")))))) ;;; Objects @@ -578,45 +587,32 @@ Point is moved to beginning of the buffer." (ert-deftest test-json-encode-hash-table () (let ((json-encoding-object-sort-predicate nil) (json-encoding-pretty-print nil)) - (should (equal (json-encode-hash-table #s(hash-table)) "{}")) - (should (equal (json-encode-hash-table #s(hash-table data (a 1))) - "{\"a\":1}")) - (should (equal (json-encode-hash-table #s(hash-table data (t 1))) - "{\"t\":1}")) - (should (equal (json-encode-hash-table #s(hash-table data (nil 1))) - "{\"nil\":1}")) - (should (equal (json-encode-hash-table #s(hash-table data (:a 1))) - "{\"a\":1}")) - (should (equal (json-encode-hash-table #s(hash-table data (:t 1))) - "{\"t\":1}")) - (should (equal (json-encode-hash-table #s(hash-table data (:nil 1))) - "{\"nil\":1}")) - (should (equal (json-encode-hash-table - #s(hash-table test equal data ("a" 1))) + (should (equal (json-encode #s(hash-table)) "{}")) + (should (equal (json-encode #s(hash-table data (a 1))) "{\"a\":1}")) + (should (equal (json-encode #s(hash-table data (t 1))) "{\"t\":1}")) + (should (equal (json-encode #s(hash-table data (nil 1))) "{\"nil\":1}")) + (should (equal (json-encode #s(hash-table data (:a 1))) "{\"a\":1}")) + (should (equal (json-encode #s(hash-table data (:t 1))) "{\"t\":1}")) + (should (equal (json-encode #s(hash-table data (:nil 1))) "{\"nil\":1}")) + (should (equal (json-encode #s(hash-table test equal data ("a" 1))) "{\"a\":1}")) - (should (equal (json-encode-hash-table - #s(hash-table test equal data ("t" 1))) + (should (equal (json-encode #s(hash-table test equal data ("t" 1))) "{\"t\":1}")) - (should (equal (json-encode-hash-table - #s(hash-table test equal data ("nil" 1))) + (should (equal (json-encode #s(hash-table test equal data ("nil" 1))) "{\"nil\":1}")) - (should (equal (json-encode-hash-table - #s(hash-table test equal data (":a" 1))) + (should (equal (json-encode #s(hash-table test equal data (":a" 1))) "{\":a\":1}")) - (should (equal (json-encode-hash-table - #s(hash-table test equal data (":t" 1))) + (should (equal (json-encode #s(hash-table test equal data (":t" 1))) "{\":t\":1}")) - (should (equal (json-encode-hash-table - #s(hash-table test equal data (":nil" 1))) + (should (equal (json-encode #s(hash-table test equal data (":nil" 1))) "{\":nil\":1}")) - (should (member (json-encode-hash-table #s(hash-table data (t 2 :nil 1))) + (should (member (json-encode #s(hash-table data (t 2 :nil 1))) '("{\"nil\":1,\"t\":2}" "{\"t\":2,\"nil\":1}"))) - (should (member (json-encode-hash-table - #s(hash-table test equal data (:t 2 ":t" 1))) + (should (member (json-encode #s(hash-table test equal data (:t 2 ":t" 1))) '("{\":t\":1,\"t\":2}" "{\"t\":2,\":t\":1}"))) - (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1))) + (should (member (json-encode #s(hash-table data (b 2 a 1))) '("{\"a\":1,\"b\":2}" "{\"b\":2,\"a\":1}"))) - (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1))) + (should (member (json-encode #s(hash-table data (c 3 b 2 a 1))) '("{\"a\":1,\"b\":2,\"c\":3}" "{\"a\":1,\"c\":3,\"b\":2}" "{\"b\":2,\"a\":1,\"c\":3}" @@ -629,13 +625,12 @@ Point is moved to beginning of the buffer." (json-encoding-pretty-print t) (json-encoding-default-indentation " ") (json-encoding-lisp-style-closings nil)) - (should (equal (json-encode-hash-table #s(hash-table)) "{}")) - (should (equal (json-encode-hash-table #s(hash-table data (a 1))) - "{\n \"a\": 1\n}")) - (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1))) + (should (equal (json-encode #s(hash-table)) "{}")) + (should (equal (json-encode #s(hash-table data (a 1))) "{\n \"a\": 1\n}")) + (should (member (json-encode #s(hash-table data (b 2 a 1))) '("{\n \"a\": 1,\n \"b\": 2\n}" "{\n \"b\": 2,\n \"a\": 1\n}"))) - (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1))) + (should (member (json-encode #s(hash-table data (c 3 b 2 a 1))) '("{\n \"a\": 1,\n \"b\": 2,\n \"c\": 3\n}" "{\n \"a\": 1,\n \"c\": 3,\n \"b\": 2\n}" "{\n \"b\": 2,\n \"a\": 1,\n \"c\": 3\n}" @@ -648,13 +643,12 @@ Point is moved to beginning of the buffer." (json-encoding-pretty-print t) (json-encoding-default-indentation " ") (json-encoding-lisp-style-closings t)) - (should (equal (json-encode-hash-table #s(hash-table)) "{}")) - (should (equal (json-encode-hash-table #s(hash-table data (a 1))) - "{\n \"a\": 1}")) - (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1))) + (should (equal (json-encode #s(hash-table)) "{}")) + (should (equal (json-encode #s(hash-table data (a 1))) "{\n \"a\": 1}")) + (should (member (json-encode #s(hash-table data (b 2 a 1))) '("{\n \"a\": 1,\n \"b\": 2}" "{\n \"b\": 2,\n \"a\": 1}"))) - (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1))) + (should (member (json-encode #s(hash-table data (c 3 b 2 a 1))) '("{\n \"a\": 1,\n \"b\": 2,\n \"c\": 3}" "{\n \"a\": 1,\n \"c\": 3,\n \"b\": 2}" "{\n \"b\": 2,\n \"a\": 1,\n \"c\": 3}" @@ -672,7 +666,7 @@ Point is moved to beginning of the buffer." (#s(hash-table data (c 3 b 2 a 1)) . "{\"a\":1,\"b\":2,\"c\":3}"))) (let ((copy (map-pairs in))) - (should (equal (json-encode-hash-table in) out)) + (should (equal (json-encode in) out)) ;; Ensure sorting isn't destructive. (should (seq-set-equal-p (map-pairs in) copy)))))) @@ -785,38 +779,42 @@ Point is moved to beginning of the buffer." (should (equal in copy)))))) (ert-deftest test-json-encode-list () + "Test `json-encode-list' or its more moral equivalents." (let ((json-encoding-object-sort-predicate nil) (json-encoding-pretty-print nil)) - (should (equal (json-encode-list ()) "{}")) - (should (equal (json-encode-list '(a)) "[\"a\"]")) - (should (equal (json-encode-list '(:a)) "[\"a\"]")) - (should (equal (json-encode-list '("a")) "[\"a\"]")) - (should (equal (json-encode-list '(a 1)) "[\"a\",1]")) - (should (equal (json-encode-list '("a" 1)) "[\"a\",1]")) - (should (equal (json-encode-list '(:a 1)) "{\"a\":1}")) - (should (equal (json-encode-list '((a . 1))) "{\"a\":1}")) - (should (equal (json-encode-list '((:a . 1))) "{\"a\":1}")) - (should (equal (json-encode-list '(:b 2 :a)) "[\"b\",2,\"a\"]")) - (should (equal (json-encode-list '(4 3 2 1)) "[4,3,2,1]")) - (should (equal (json-encode-list '(b 2 a 1)) "[\"b\",2,\"a\",1]")) - (should (equal (json-encode-list '(:b 2 :a 1)) "{\"b\":2,\"a\":1}")) - (should (equal (json-encode-list '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}")) - (should (equal (json-encode-list '((:b . 2) (:a . 1))) + ;; Trick `json-encode' into using `json--print-list'. + (let ((json-null (list nil))) + (should (equal (json-encode ()) "{}"))) + (should (equal (json-encode '(a)) "[\"a\"]")) + (should (equal (json-encode '(:a)) "[\"a\"]")) + (should (equal (json-encode '("a")) "[\"a\"]")) + (should (equal (json-encode '(a 1)) "[\"a\",1]")) + (should (equal (json-encode '("a" 1)) "[\"a\",1]")) + (should (equal (json-encode '(:a 1)) "{\"a\":1}")) + (should (equal (json-encode '((a . 1))) "{\"a\":1}")) + (should (equal (json-encode '((:a . 1))) "{\"a\":1}")) + (should (equal (json-encode '(:b 2 :a)) "[\"b\",2,\"a\"]")) + (should (equal (json-encode '(4 3 2 1)) "[4,3,2,1]")) + (should (equal (json-encode '(b 2 a 1)) "[\"b\",2,\"a\",1]")) + (should (equal (json-encode '(:b 2 :a 1)) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode '((:b . 2) (:a . 1))) "{\"b\":2,\"a\":1}")) - (should (equal (json-encode-list '((a) 1)) "[[\"a\"],1]")) - (should (equal (json-encode-list '((:a) 1)) "[[\"a\"],1]")) - (should (equal (json-encode-list '(("a") 1)) "[[\"a\"],1]")) - (should (equal (json-encode-list '((a 1) 2)) "[[\"a\",1],2]")) - (should (equal (json-encode-list '((:a 1) 2)) "[{\"a\":1},2]")) - (should (equal (json-encode-list '(((a . 1)) 2)) "[{\"a\":1},2]")) - (should (equal (json-encode-list '(:a 1 :b (2))) "{\"a\":1,\"b\":[2]}")) - (should (equal (json-encode-list '((a . 1) (b 2))) "{\"a\":1,\"b\":[2]}")) - (should-error (json-encode-list '(a . 1)) :type 'wrong-type-argument) - (should-error (json-encode-list '((a . 1) 2)) :type 'wrong-type-argument) - (should (equal (should-error (json-encode-list [])) - '(json-error []))) - (should (equal (should-error (json-encode-list [a])) - '(json-error [a]))))) + (should (equal (json-encode '((a) 1)) "[[\"a\"],1]")) + (should (equal (json-encode '((:a) 1)) "[[\"a\"],1]")) + (should (equal (json-encode '(("a") 1)) "[[\"a\"],1]")) + (should (equal (json-encode '((a 1) 2)) "[[\"a\",1],2]")) + (should (equal (json-encode '((:a 1) 2)) "[{\"a\":1},2]")) + (should (equal (json-encode '(((a . 1)) 2)) "[{\"a\":1},2]")) + (should (equal (json-encode '(:a 1 :b (2))) "{\"a\":1,\"b\":[2]}")) + (should (equal (json-encode '((a . 1) (b 2))) "{\"a\":1,\"b\":[2]}")) + (should-error (json-encode '(a . 1)) :type 'wrong-type-argument) + (should-error (json-encode '((a . 1) 2)) :type 'wrong-type-argument) + (with-suppressed-warnings ((obsolete json-encode-list)) + (should (equal (should-error (json-encode-list [])) + '(json-error []))) + (should (equal (should-error (json-encode-list [a])) + '(json-error [a])))))) ;;; Arrays diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el index 7349b191caf..791e51cdcd5 100644 --- a/test/lisp/minibuffer-tests.el +++ b/test/lisp/minibuffer-tests.el @@ -125,5 +125,11 @@ '(("completion1" "prefix1" #("suffix1" 0 7 (face shadow))))) (should (equal (get-text-property 19 'face) 'shadow)))) +(ert-deftest completion-pcm--optimize-pattern () + (should (equal (completion-pcm--optimize-pattern '("buf" point "f")) + '("buf" point "f"))) + (should (equal (completion-pcm--optimize-pattern '(any "" any)) + '(any)))) + (provide 'minibuffer-tests) ;;; minibuffer-tests.el ends here diff --git a/test/lisp/net/puny-tests.el b/test/lisp/net/puny-tests.el index b37168f5ca7..28c0d49cbee 100644 --- a/test/lisp/net/puny-tests.el +++ b/test/lisp/net/puny-tests.el @@ -39,10 +39,12 @@ (should (string= (puny-decode-string "xn--9dbdkw") "חנוך"))) (ert-deftest puny-test-encode-domain () - (should (string= (puny-encode-domain "åäö.se") "xn--4cab6c.se"))) + (should (string= (puny-encode-domain "åäö.se") "xn--4cab6c.se")) + (should (string= (puny-encode-domain "яндекс.рф") "xn--d1acpjx3f.xn--p1ai"))) (ert-deftest puny-test-decode-domain () - (should (string= (puny-decode-domain "xn--4cab6c.se") "åäö.se"))) + (should (string= (puny-decode-domain "xn--4cab6c.se") "åäö.se")) + (should (string= (puny-decode-domain "xn--d1acpjx3f.xn--p1ai") "яндекс.рф"))) (ert-deftest puny-highly-restrictive-domain-p () (should (puny-highly-restrictive-domain-p "foo.bar.org")) diff --git a/test/lisp/cedet/inversion-tests.el b/test/lisp/obsolete/inversion-tests.el index c8b45d67ea1..c8b45d67ea1 100644 --- a/test/lisp/cedet/inversion-tests.el +++ b/test/lisp/obsolete/inversion-tests.el |