mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-10 00:00:39 -08:00
Rename all test files to reflect source layout.
* CONTRIBUTE,Makefile.in,configure.ac: Update to reflect test directory moves. * test/file-organisation.org: New file. * test/automated/Makefile.in test/automated/data/decompress/foo.gz test/automated/data/epg/pubkey.asc test/automated/data/epg/seckey.asc test/automated/data/files-bug18141.el.gz test/automated/data/flymake/test.c test/automated/data/flymake/test.pl test/automated/data/package/archive-contents test/automated/data/package/key.pub test/automated/data/package/key.sec test/automated/data/package/multi-file-0.2.3.tar test/automated/data/package/multi-file-readme.txt test/automated/data/package/newer-versions/archive-contents test/automated/data/package/newer-versions/new-pkg-1.0.el test/automated/data/package/newer-versions/simple-single-1.4.el test/automated/data/package/package-test-server.py test/automated/data/package/signed/archive-contents test/automated/data/package/signed/archive-contents.sig test/automated/data/package/signed/signed-bad-1.0.el test/automated/data/package/signed/signed-bad-1.0.el.sig test/automated/data/package/signed/signed-good-1.0.el test/automated/data/package/signed/signed-good-1.0.el.sig test/automated/data/package/simple-depend-1.0.el test/automated/data/package/simple-single-1.3.el test/automated/data/package/simple-single-readme.txt test/automated/data/package/simple-two-depend-1.1.el test/automated/abbrev-tests.el test/automated/auto-revert-tests.el test/automated/calc-tests.el test/automated/icalendar-tests.el test/automated/character-fold-tests.el test/automated/comint-testsuite.el test/automated/descr-text-test.el test/automated/electric-tests.el test/automated/cl-generic-tests.el test/automated/cl-lib-tests.el test/automated/eieio-test-methodinvoke.el test/automated/eieio-test-persist.el test/automated/eieio-tests.el test/automated/ert-tests.el test/automated/ert-x-tests.el test/automated/generator-tests.el test/automated/let-alist.el test/automated/map-tests.el test/automated/advice-tests.el test/automated/package-test.el test/automated/pcase-tests.el test/automated/regexp-tests.el test/automated/seq-tests.el test/automated/subr-x-tests.el test/automated/tabulated-list-test.el test/automated/thunk-tests.el test/automated/timer-tests.el test/automated/epg-tests.el test/automated/eshell.el test/automated/faces-tests.el test/automated/file-notify-tests.el test/automated/auth-source-tests.el test/automated/gnus-tests.el test/automated/message-mode-tests.el test/automated/help-fns.el test/automated/imenu-test.el test/automated/info-xref.el test/automated/mule-util.el test/automated/isearch-tests.el test/automated/json-tests.el test/automated/bytecomp-tests.el test/automated/coding-tests.el test/automated/core-elisp-tests.el test/automated/decoder-tests.el test/automated/files.el test/automated/font-parse-tests.el test/automated/lexbind-tests.el test/automated/occur-tests.el test/automated/process-tests.el test/automated/syntax-tests.el test/automated/textprop-tests.el test/automated/undo-tests.el test/automated/man-tests.el test/automated/completion-tests.el test/automated/dbus-tests.el test/automated/newsticker-tests.el test/automated/sasl-scram-rfc-tests.el test/automated/tramp-tests.el test/automated/obarray-tests.el test/automated/compile-tests.el test/automated/elisp-mode-tests.el test/automated/f90.el test/automated/flymake-tests.el test/automated/python-tests.el test/automated/ruby-mode-tests.el test/automated/subword-tests.el test/automated/replace-tests.el test/automated/simple-test.el test/automated/sort-tests.el test/automated/subr-tests.el test/automated/reftex-tests.el test/automated/sgml-mode-tests.el test/automated/tildify-tests.el test/automated/thingatpt.el test/automated/url-future-tests.el test/automated/url-util-tests.el test/automated/add-log-tests.el test/automated/vc-bzr.el test/automated/vc-tests.el test/automated/xml-parse-tests.el test/BidiCharacterTest.txt test/biditest.el test/cedet/cedet-utests.el test/cedet/ede-tests.el test/cedet/semantic-ia-utest.el test/cedet/semantic-tests.el test/cedet/semantic-utest-c.el test/cedet/semantic-utest.el test/cedet/srecode-tests.el test/cedet/tests/test.c test/cedet/tests/test.el test/cedet/tests/test.make test/cedet/tests/testdoublens.cpp test/cedet/tests/testdoublens.hpp test/cedet/tests/testfriends.cpp test/cedet/tests/testjavacomp.java test/cedet/tests/testnsp.cpp test/cedet/tests/testpolymorph.cpp test/cedet/tests/testspp.c test/cedet/tests/testsppcomplete.c test/cedet/tests/testsppreplace.c test/cedet/tests/testsppreplaced.c test/cedet/tests/testsubclass.cpp test/cedet/tests/testsubclass.hh test/cedet/tests/testtypedefs.cpp test/cedet/tests/testvarnames.c test/etags/CTAGS.good test/etags/ETAGS.good_1 test/etags/ETAGS.good_2 test/etags/ETAGS.good_3 test/etags/ETAGS.good_4 test/etags/ETAGS.good_5 test/etags/ETAGS.good_6 test/etags/a-src/empty.zz test/etags/a-src/empty.zz.gz test/etags/ada-src/2ataspri.adb test/etags/ada-src/2ataspri.ads test/etags/ada-src/etags-test-for.ada test/etags/ada-src/waroquiers.ada test/etags/c-src/a/b/b.c test/etags/c-src/abbrev.c test/etags/c-src/c.c test/etags/c-src/dostorture.c test/etags/c-src/emacs/src/gmalloc.c test/etags/c-src/emacs/src/keyboard.c test/etags/c-src/emacs/src/lisp.h test/etags/c-src/emacs/src/regex.h test/etags/c-src/etags.c test/etags/c-src/exit.c test/etags/c-src/exit.strange_suffix test/etags/c-src/fail.c test/etags/c-src/getopt.h test/etags/c-src/h.h test/etags/c-src/machsyscalls.c test/etags/c-src/machsyscalls.h test/etags/c-src/sysdep.h test/etags/c-src/tab.c test/etags/c-src/torture.c test/etags/cp-src/MDiagArray2.h test/etags/cp-src/Range.h test/etags/cp-src/burton.cpp test/etags/cp-src/c.C test/etags/cp-src/clheir.cpp.gz test/etags/cp-src/clheir.hpp test/etags/cp-src/conway.cpp test/etags/cp-src/conway.hpp test/etags/cp-src/fail.C test/etags/cp-src/functions.cpp test/etags/cp-src/screen.cpp test/etags/cp-src/screen.hpp test/etags/cp-src/x.cc test/etags/el-src/TAGTEST.EL test/etags/el-src/emacs/lisp/progmodes/etags.el test/etags/erl-src/gs_dialog.erl test/etags/f-src/entry.for test/etags/f-src/entry.strange.gz test/etags/f-src/entry.strange_suffix test/etags/forth-src/test-forth.fth test/etags/html-src/algrthms.html test/etags/html-src/index.shtml test/etags/html-src/software.html test/etags/html-src/softwarelibero.html test/etags/lua-src/allegro.lua test/etags/objc-src/PackInsp.h test/etags/objc-src/PackInsp.m test/etags/objc-src/Subprocess.h test/etags/objc-src/Subprocess.m test/etags/objcpp-src/SimpleCalc.H test/etags/objcpp-src/SimpleCalc.M test/etags/pas-src/common.pas test/etags/perl-src/htlmify-cystic test/etags/perl-src/kai-test.pl test/etags/perl-src/yagrip.pl test/etags/php-src/lce_functions.php test/etags/php-src/ptest.php test/etags/php-src/sendmail.php test/etags/prol-src/natded.prolog test/etags/prol-src/ordsets.prolog test/etags/ps-src/rfc1245.ps test/etags/pyt-src/server.py test/etags/tex-src/gzip.texi test/etags/tex-src/nonewline.tex test/etags/tex-src/testenv.tex test/etags/tex-src/texinfo.tex test/etags/y-src/atest.y test/etags/y-src/cccp.c test/etags/y-src/cccp.y test/etags/y-src/parse.c test/etags/y-src/parse.y test/indent/css-mode.css test/indent/js-indent-init-dynamic.js test/indent/js-indent-init-t.js test/indent/js-jsx.js test/indent/js.js test/indent/latex-mode.tex test/indent/modula2.mod test/indent/nxml.xml test/indent/octave.m test/indent/pascal.pas test/indent/perl.perl test/indent/prolog.prolog test/indent/ps-mode.ps test/indent/ruby.rb test/indent/scheme.scm test/indent/scss-mode.scss test/indent/sgml-mode-attribute.html test/indent/shell.rc test/indent/shell.sh test/redisplay-testsuite.el test/rmailmm.el test/automated/buffer-tests.el test/automated/cmds-tests.el test/automated/data-tests.el test/automated/finalizer-tests.el test/automated/fns-tests.el test/automated/inotify-test.el test/automated/keymap-tests.el test/automated/print-tests.el test/automated/libxml-tests.el test/automated/zlib-tests.el: Files Moved.
This commit is contained in:
Phillip Lord
parent
c378d6c33f
commit
22bbf7ca22
254 changed files with 61 additions and 341 deletions
223
test/lisp/emacs-lisp/cl-generic-tests.el
Normal file
223
test/lisp/emacs-lisp/cl-generic-tests.el
Normal file
|
|
@ -0,0 +1,223 @@
|
|||
;;; cl-generic-tests.el --- Tests for cl-generic.el functionality -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
;; 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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'ert)) ;Don't indirectly require cl-lib at run-time.
|
||||
(require 'cl-generic)
|
||||
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x y))
|
||||
(cl-defgeneric (setf cl--generic-1) (v y z) "My generic doc.")
|
||||
|
||||
(ert-deftest cl-generic-test-00 ()
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x y))
|
||||
(cl-defmethod cl--generic-1 ((x t) y) (cons x y))
|
||||
(should (equal (cl--generic-1 'a 'b) '(a . b))))
|
||||
|
||||
(ert-deftest cl-generic-test-01-eql ()
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x y))
|
||||
(cl-defmethod cl--generic-1 ((x t) y) (cons x y))
|
||||
(cl-defmethod cl--generic-1 ((_x (eql 4)) _y)
|
||||
(cons "quatre" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 ((_x (eql 5)) _y)
|
||||
(cons "cinq" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 ((_x (eql 6)) y)
|
||||
(cons "six" (cl-call-next-method 'a y)))
|
||||
(should (equal (cl--generic-1 'a nil) '(a)))
|
||||
(should (equal (cl--generic-1 4 nil) '("quatre" 4)))
|
||||
(should (equal (cl--generic-1 5 nil) '("cinq" 5)))
|
||||
(should (equal (cl--generic-1 6 nil) '("six" a))))
|
||||
|
||||
(cl-defstruct cl-generic-struct-parent a b)
|
||||
(cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c)
|
||||
(cl-defstruct (cl-generic-struct-child11 (:include cl-generic-struct-child1)) d)
|
||||
(cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent)) e)
|
||||
|
||||
(ert-deftest cl-generic-test-02-struct ()
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x y) "My doc.")
|
||||
(cl-defmethod cl--generic-1 ((x t) y) "Doc 1." (cons x y))
|
||||
(cl-defmethod cl--generic-1 ((_x cl-generic-struct-parent) y)
|
||||
"Doc 2." (cons "parent" (cl-call-next-method 'a y)))
|
||||
(cl-defmethod cl--generic-1 ((_x cl-generic-struct-child1) _y)
|
||||
(cons "child1" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 :around ((_x t) _y)
|
||||
(cons "around" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 :around ((_x cl-generic-struct-child11) _y)
|
||||
(cons "child11" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 ((_x cl-generic-struct-child2) _y)
|
||||
(cons "child2" (cl-call-next-method)))
|
||||
(should (equal (cl--generic-1 (make-cl-generic-struct-child1) nil)
|
||||
'("around" "child1" "parent" a)))
|
||||
(should (equal (cl--generic-1 (make-cl-generic-struct-child2) nil)
|
||||
'("around""child2" "parent" a)))
|
||||
(should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil)
|
||||
'("child11" "around""child1" "parent" a))))
|
||||
|
||||
;; I don't know how to put this inside an `ert-test'. This tests that `setf'
|
||||
;; can be used directly inside the body of the setf method.
|
||||
(cl-defmethod (setf cl--generic-2) (v (y integer) z)
|
||||
(setf (cl--generic-2 (nth y z) z) v))
|
||||
|
||||
(ert-deftest cl-generic-test-03-setf ()
|
||||
(cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z))
|
||||
(cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z))
|
||||
(should (equal (setf (cl--generic-1 'a 'b) 'v) '(v a b)))
|
||||
(should (equal (setf (cl--generic-1 4 'b) 'v) '(v "four" b)))
|
||||
(let ((x ()))
|
||||
(should (equal (setf (cl--generic-1 (progn (push 1 x) 'a)
|
||||
(progn (push 2 x) 'b))
|
||||
(progn (push 3 x) 'v))
|
||||
'(v a b)))
|
||||
(should (equal x '(3 2 1)))))
|
||||
|
||||
(ert-deftest cl-generic-test-04-overlapping-tagcodes ()
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x y) "My doc.")
|
||||
(cl-defmethod cl--generic-1 ((y t) z) (list y z))
|
||||
(cl-defmethod cl--generic-1 ((_y (eql 4)) _z)
|
||||
(cons "four" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 ((_y integer) _z)
|
||||
(cons "integer" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 ((_y number) _z)
|
||||
(cons "number" (cl-call-next-method)))
|
||||
(should (equal (cl--generic-1 'a 'b) '(a b)))
|
||||
(should (equal (cl--generic-1 1 'b) '("integer" "number" 1 b)))
|
||||
(should (equal (cl--generic-1 4 'b) '("four" "integer" "number" 4 b))))
|
||||
|
||||
(ert-deftest cl-generic-test-05-alias ()
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x y) "My doc.")
|
||||
(defalias 'cl--generic-2 #'cl--generic-1)
|
||||
(cl-defmethod cl--generic-1 ((y t) z) (list y z))
|
||||
(cl-defmethod cl--generic-2 ((_y (eql 4)) _z)
|
||||
(cons "four" (cl-call-next-method)))
|
||||
(should (equal (cl--generic-1 4 'b) '("four" 4 b))))
|
||||
|
||||
(ert-deftest cl-generic-test-06-multiple-dispatch ()
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x y) "My doc.")
|
||||
(cl-defmethod cl--generic-1 (x y) (list x y))
|
||||
(cl-defmethod cl--generic-1 (_x (_y integer))
|
||||
(cons "y-int" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 ((_x integer) _y)
|
||||
(cons "x-int" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 ((_x integer) (_y integer))
|
||||
(cons "x&y-int" (cl-call-next-method)))
|
||||
(should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2))))
|
||||
|
||||
(ert-deftest cl-generic-test-07-apo ()
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x y)
|
||||
(:documentation "My doc.") (:argument-precedence-order y x))
|
||||
(cl-defmethod cl--generic-1 (x y) (list x y))
|
||||
(cl-defmethod cl--generic-1 (_x (_y integer))
|
||||
(cons "y-int" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 ((_x integer) _y)
|
||||
(cons "x-int" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 ((_x integer) (_y integer))
|
||||
(cons "x&y-int" (cl-call-next-method)))
|
||||
(should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2))))
|
||||
|
||||
(ert-deftest cl-generic-test-08-after/before ()
|
||||
(let ((log ()))
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x y))
|
||||
(cl-defmethod cl--generic-1 ((_x t) y) (cons y log))
|
||||
(cl-defmethod cl--generic-1 ((_x (eql 4)) _y)
|
||||
(cons "quatre" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 :after (x _y)
|
||||
(push (list :after x) log))
|
||||
(cl-defmethod cl--generic-1 :before (x _y)
|
||||
(push (list :before x) log))
|
||||
(should (equal (cl--generic-1 4 6) '("quatre" 6 (:before 4))))
|
||||
(should (equal log '((:after 4) (:before 4))))))
|
||||
|
||||
(defun cl--generic-test-advice (&rest args) (cons "advice" (apply args)))
|
||||
|
||||
(ert-deftest cl-generic-test-09-advice ()
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x y) "My doc.")
|
||||
(cl-defmethod cl--generic-1 (x y) (list x y))
|
||||
(advice-add 'cl--generic-1 :around #'cl--generic-test-advice)
|
||||
(should (equal (cl--generic-1 4 5) '("advice" 4 5)))
|
||||
(cl-defmethod cl--generic-1 ((_x integer) _y)
|
||||
(cons "integer" (cl-call-next-method)))
|
||||
(should (equal (cl--generic-1 4 5) '("advice" "integer" 4 5)))
|
||||
(advice-remove 'cl--generic-1 #'cl--generic-test-advice)
|
||||
(should (equal (cl--generic-1 4 5) '("integer" 4 5))))
|
||||
|
||||
(ert-deftest cl-generic-test-10-weird ()
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x &rest r) "My doc.")
|
||||
(cl-defmethod cl--generic-1 (x &rest r) (cons x r))
|
||||
;; This kind of definition is not valid according to CLHS, but it does show
|
||||
;; up in EIEIO's tests for no-next-method, so we should either
|
||||
;; detect it and signal an error or do something meaningful with it.
|
||||
(cl-defmethod cl--generic-1 (x (y integer) &rest r)
|
||||
`("integer" ,y ,x ,@r))
|
||||
(should (equal (cl--generic-1 'a 'b) '(a b)))
|
||||
(should (equal (cl--generic-1 1 2) '("integer" 2 1))))
|
||||
|
||||
(ert-deftest cl-generic-test-11-next-method-p ()
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x y))
|
||||
(cl-defmethod cl--generic-1 ((x t) y)
|
||||
(list x y (cl-next-method-p)))
|
||||
(cl-defmethod cl--generic-1 ((_x (eql 4)) _y)
|
||||
(cl-list* "quatre" (cl-next-method-p) (cl-call-next-method)))
|
||||
(should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil))))
|
||||
|
||||
(ert-deftest cl-generic-test-12-context ()
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 ())
|
||||
(cl-defmethod cl--generic-1 (&context (overwrite-mode (eql t)))
|
||||
(list 'is-t (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 (&context (overwrite-mode (eql nil)))
|
||||
(list 'is-nil (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 () 'any)
|
||||
(should (equal (list (let ((overwrite-mode t)) (cl--generic-1))
|
||||
(let ((overwrite-mode nil)) (cl--generic-1))
|
||||
(let ((overwrite-mode 1)) (cl--generic-1)))
|
||||
'((is-t any) (is-nil any) any))))
|
||||
|
||||
(ert-deftest cl-generic-test-13-head ()
|
||||
(fmakunbound 'cl--generic-1)
|
||||
(cl-defgeneric cl--generic-1 (x y))
|
||||
(cl-defmethod cl--generic-1 ((x t) y) (cons x y))
|
||||
(cl-defmethod cl--generic-1 ((_x (head 4)) _y)
|
||||
(cons "quatre" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 ((_x (head 5)) _y)
|
||||
(cons "cinq" (cl-call-next-method)))
|
||||
(cl-defmethod cl--generic-1 ((_x (head 6)) y)
|
||||
(cons "six" (cl-call-next-method 'a y)))
|
||||
(should (equal (cl--generic-1 'a nil) '(a)))
|
||||
(should (equal (cl--generic-1 '(4) nil) '("quatre" (4))))
|
||||
(should (equal (cl--generic-1 '(5) nil) '("cinq" (5))))
|
||||
(should (equal (cl--generic-1 '(6) nil) '("six" a))))
|
||||
|
||||
(provide 'cl-generic-tests)
|
||||
;;; cl-generic-tests.el ends here
|
||||
496
test/lisp/emacs-lisp/cl-lib-tests.el
Normal file
496
test/lisp/emacs-lisp/cl-lib-tests.el
Normal file
|
|
@ -0,0 +1,496 @@
|
|||
;;; cl-lib.el --- tests for emacs-lisp/cl-lib.el -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 2013-2015 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 `http://www.gnu.org/licenses/'.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Extracted from ert-tests.el, back when ert used to reimplement some
|
||||
;; cl functions.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ert)
|
||||
|
||||
(ert-deftest cl-lib-test-remprop ()
|
||||
(let ((x (cl-gensym)))
|
||||
(should (equal (symbol-plist x) '()))
|
||||
;; Remove nonexistent property on empty plist.
|
||||
(cl-remprop x 'b)
|
||||
(should (equal (symbol-plist x) '()))
|
||||
(put x 'a 1)
|
||||
(should (equal (symbol-plist x) '(a 1)))
|
||||
;; Remove nonexistent property on nonempty plist.
|
||||
(cl-remprop x 'b)
|
||||
(should (equal (symbol-plist x) '(a 1)))
|
||||
(put x 'b 2)
|
||||
(put x 'c 3)
|
||||
(put x 'd 4)
|
||||
(should (equal (symbol-plist x) '(a 1 b 2 c 3 d 4)))
|
||||
;; Remove property that is neither first nor last.
|
||||
(cl-remprop x 'c)
|
||||
(should (equal (symbol-plist x) '(a 1 b 2 d 4)))
|
||||
;; Remove last property from a plist of length >1.
|
||||
(cl-remprop x 'd)
|
||||
(should (equal (symbol-plist x) '(a 1 b 2)))
|
||||
;; Remove first property from a plist of length >1.
|
||||
(cl-remprop x 'a)
|
||||
(should (equal (symbol-plist x) '(b 2)))
|
||||
;; Remove property when there is only one.
|
||||
(cl-remprop x 'b)
|
||||
(should (equal (symbol-plist x) '()))))
|
||||
|
||||
(ert-deftest cl-lib-test-remove-if-not ()
|
||||
(let ((list (list 'a 'b 'c 'd))
|
||||
(i 0))
|
||||
(let ((result (cl-remove-if-not (lambda (x)
|
||||
(should (eql x (nth i list)))
|
||||
(cl-incf i)
|
||||
(member i '(2 3)))
|
||||
list)))
|
||||
(should (equal i 4))
|
||||
(should (equal result '(b c)))
|
||||
(should (equal list '(a b c d)))))
|
||||
(should (equal '()
|
||||
(cl-remove-if-not (lambda (_x) (should nil)) '()))))
|
||||
|
||||
(ert-deftest cl-lib-test-remove ()
|
||||
(let ((list (list 'a 'b 'c 'd))
|
||||
(key-index 0)
|
||||
(test-index 0))
|
||||
(let ((result
|
||||
(cl-remove 'foo list
|
||||
:key (lambda (x)
|
||||
(should (eql x (nth key-index list)))
|
||||
(prog1
|
||||
(list key-index x)
|
||||
(cl-incf key-index)))
|
||||
:test
|
||||
(lambda (a b)
|
||||
(should (eql a 'foo))
|
||||
(should (equal b (list test-index
|
||||
(nth test-index list))))
|
||||
(cl-incf test-index)
|
||||
(member test-index '(2 3))))))
|
||||
(should (equal key-index 4))
|
||||
(should (equal test-index 4))
|
||||
(should (equal result '(a d)))
|
||||
(should (equal list '(a b c d)))))
|
||||
(let ((x (cons nil nil))
|
||||
(y (cons nil nil)))
|
||||
(should (equal (cl-remove x (list x y))
|
||||
;; or (list x), since we use `equal' -- the
|
||||
;; important thing is that only one element got
|
||||
;; removed, this proves that the default test is
|
||||
;; `eql', not `equal'
|
||||
(list y)))))
|
||||
|
||||
|
||||
(ert-deftest cl-lib-test-set-functions ()
|
||||
(let ((c1 (cons nil nil))
|
||||
(c2 (cons nil nil))
|
||||
(sym (make-symbol "a")))
|
||||
(let ((e '())
|
||||
(a (list 'a 'b sym nil "" "x" c1 c2))
|
||||
(b (list c1 'y 'b sym 'x)))
|
||||
(should (equal (cl-set-difference e e) e))
|
||||
(should (equal (cl-set-difference a e) a))
|
||||
(should (equal (cl-set-difference e a) e))
|
||||
(should (equal (cl-set-difference a a) e))
|
||||
(should (equal (cl-set-difference b e) b))
|
||||
(should (equal (cl-set-difference e b) e))
|
||||
(should (equal (cl-set-difference b b) e))
|
||||
;; Note: this test (and others) is sensitive to the order of the
|
||||
;; result, which is not documented.
|
||||
(should (equal (cl-set-difference a b) (list 'a nil "" "x" c2)))
|
||||
(should (equal (cl-set-difference b a) (list 'y 'x)))
|
||||
|
||||
;; We aren't testing whether this is really using `eq' rather than `eql'.
|
||||
(should (equal (cl-set-difference e e :test 'eq) e))
|
||||
(should (equal (cl-set-difference a e :test 'eq) a))
|
||||
(should (equal (cl-set-difference e a :test 'eq) e))
|
||||
(should (equal (cl-set-difference a a :test 'eq) e))
|
||||
(should (equal (cl-set-difference b e :test 'eq) b))
|
||||
(should (equal (cl-set-difference e b :test 'eq) e))
|
||||
(should (equal (cl-set-difference b b :test 'eq) e))
|
||||
(should (equal (cl-set-difference a b :test 'eq) (list 'a nil "" "x" c2)))
|
||||
(should (equal (cl-set-difference b a :test 'eq) (list 'y 'x)))
|
||||
|
||||
(should (equal (cl-union e e) e))
|
||||
(should (equal (cl-union a e) a))
|
||||
(should (equal (cl-union e a) a))
|
||||
(should (equal (cl-union a a) a))
|
||||
(should (equal (cl-union b e) b))
|
||||
(should (equal (cl-union e b) b))
|
||||
(should (equal (cl-union b b) b))
|
||||
(should (equal (cl-union a b) (list 'x 'y 'a 'b sym nil "" "x" c1 c2)))
|
||||
|
||||
(should (equal (cl-union b a) (list 'x 'y 'a 'b sym nil "" "x" c1 c2)))
|
||||
|
||||
(should (equal (cl-intersection e e) e))
|
||||
(should (equal (cl-intersection a e) e))
|
||||
(should (equal (cl-intersection e a) e))
|
||||
(should (equal (cl-intersection a a) a))
|
||||
(should (equal (cl-intersection b e) e))
|
||||
(should (equal (cl-intersection e b) e))
|
||||
(should (equal (cl-intersection b b) b))
|
||||
(should (equal (cl-intersection a b) (list sym 'b c1)))
|
||||
(should (equal (cl-intersection b a) (list sym 'b c1))))))
|
||||
|
||||
(ert-deftest cl-lib-test-gensym ()
|
||||
;; Since the expansion of `should' calls `cl-gensym' and thus has a
|
||||
;; side-effect on `cl--gensym-counter', we have to make sure all
|
||||
;; macros in our test body are expanded before we rebind
|
||||
;; `cl--gensym-counter' and run the body. Otherwise, the test would
|
||||
;; fail if run interpreted.
|
||||
(let ((body (byte-compile
|
||||
'(lambda ()
|
||||
(should (equal (symbol-name (cl-gensym)) "G0"))
|
||||
(should (equal (symbol-name (cl-gensym)) "G1"))
|
||||
(should (equal (symbol-name (cl-gensym)) "G2"))
|
||||
(should (equal (symbol-name (cl-gensym "foo")) "foo3"))
|
||||
(should (equal (symbol-name (cl-gensym "bar")) "bar4"))
|
||||
(should (equal cl--gensym-counter 5))))))
|
||||
(let ((cl--gensym-counter 0))
|
||||
(funcall body))))
|
||||
|
||||
(ert-deftest cl-lib-test-coerce-to-vector ()
|
||||
(let* ((a (vector))
|
||||
(b (vector 1 a 3))
|
||||
(c (list))
|
||||
(d (list b a)))
|
||||
(should (eql (cl-coerce a 'vector) a))
|
||||
(should (eql (cl-coerce b 'vector) b))
|
||||
(should (equal (cl-coerce c 'vector) (vector)))
|
||||
(should (equal (cl-coerce d 'vector) (vector b a)))))
|
||||
|
||||
(ert-deftest cl-lib-test-string-position ()
|
||||
(should (eql (cl-position ?x "") nil))
|
||||
(should (eql (cl-position ?a "abc") 0))
|
||||
(should (eql (cl-position ?b "abc") 1))
|
||||
(should (eql (cl-position ?c "abc") 2))
|
||||
(should (eql (cl-position ?d "abc") nil))
|
||||
(should (eql (cl-position ?A "abc") nil)))
|
||||
|
||||
(ert-deftest cl-lib-test-mismatch ()
|
||||
(should (eql (cl-mismatch "" "") nil))
|
||||
(should (eql (cl-mismatch "" "a") 0))
|
||||
(should (eql (cl-mismatch "a" "a") nil))
|
||||
(should (eql (cl-mismatch "ab" "a") 1))
|
||||
(should (eql (cl-mismatch "Aa" "aA") 0))
|
||||
(should (eql (cl-mismatch '(a b c) '(a b d)) 2)))
|
||||
|
||||
(ert-deftest cl-lib-test-loop ()
|
||||
(should (eql (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6)))
|
||||
|
||||
(ert-deftest cl-lib-keyword-names-versus-values ()
|
||||
(should (equal
|
||||
(funcall (cl-function (lambda (&key a b) (list a b)))
|
||||
:b :a :a 42)
|
||||
'(42 :a))))
|
||||
|
||||
(cl-defstruct (mystruct
|
||||
(:constructor cl-lib--con-1 (&aux (abc 1)))
|
||||
(:constructor cl-lib--con-2 (&optional def) "Constructor docstring."))
|
||||
"General docstring."
|
||||
(abc 5 :readonly t) (def nil))
|
||||
(ert-deftest cl-lib-struct-accessors ()
|
||||
(let ((x (make-mystruct :abc 1 :def 2)))
|
||||
(should (eql (cl-struct-slot-value 'mystruct 'abc x) 1))
|
||||
(should (eql (cl-struct-slot-value 'mystruct 'def x) 2))
|
||||
(setf (cl-struct-slot-value 'mystruct 'def x) -1)
|
||||
(should (eql (cl-struct-slot-value 'mystruct 'def x) -1))
|
||||
(should (eql (cl-struct-slot-offset 'mystruct 'abc) 1))
|
||||
(should-error (cl-struct-slot-offset 'mystruct 'marypoppins))
|
||||
(should (pcase (cl-struct-slot-info 'mystruct)
|
||||
(`((cl-tag-slot) (abc 5 :readonly t)
|
||||
(def . ,(or `nil `(nil))))
|
||||
t)))))
|
||||
(ert-deftest cl-lib-struct-constructors ()
|
||||
(should (string-match "\\`Constructor docstring."
|
||||
(documentation 'cl-lib--con-2 t)))
|
||||
(should (mystruct-p (cl-lib--con-1)))
|
||||
(should (mystruct-p (cl-lib--con-2))))
|
||||
|
||||
(ert-deftest cl-lib-arglist-performance ()
|
||||
;; An `&aux' should not cause lambda's arglist to be turned into an &rest
|
||||
;; that's parsed by hand.
|
||||
(should (equal () (help-function-arglist 'cl-lib--con-1)))
|
||||
(should (pcase (help-function-arglist 'cl-lib--con-2)
|
||||
(`(&optional ,_) t))))
|
||||
|
||||
(ert-deftest cl-the ()
|
||||
(should (eql (cl-the integer 42) 42))
|
||||
(should-error (cl-the integer "abc"))
|
||||
(let ((side-effect 0))
|
||||
(should (= (cl-the integer (cl-incf side-effect)) 1))
|
||||
(should (= side-effect 1))))
|
||||
|
||||
(ert-deftest cl-lib-test-plusp ()
|
||||
(should-not (cl-plusp -1.0e+INF))
|
||||
(should-not (cl-plusp -1.5e2))
|
||||
(should-not (cl-plusp -3.14))
|
||||
(should-not (cl-plusp -1))
|
||||
(should-not (cl-plusp -0.0))
|
||||
(should-not (cl-plusp 0))
|
||||
(should-not (cl-plusp 0.0))
|
||||
(should-not (cl-plusp -0.0e+NaN))
|
||||
(should-not (cl-plusp 0.0e+NaN))
|
||||
(should (cl-plusp 1))
|
||||
(should (cl-plusp 3.14))
|
||||
(should (cl-plusp 1.5e2))
|
||||
(should (cl-plusp 1.0e+INF))
|
||||
(should-error (cl-plusp "42") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-minusp ()
|
||||
(should (cl-minusp -1.0e+INF))
|
||||
(should (cl-minusp -1.5e2))
|
||||
(should (cl-minusp -3.14))
|
||||
(should (cl-minusp -1))
|
||||
(should-not (cl-minusp -0.0))
|
||||
(should-not (cl-minusp 0))
|
||||
(should-not (cl-minusp 0.0))
|
||||
(should-not (cl-minusp -0.0e+NaN))
|
||||
(should-not (cl-minusp 0.0e+NaN))
|
||||
(should-not (cl-minusp 1))
|
||||
(should-not (cl-minusp 3.14))
|
||||
(should-not (cl-minusp 1.5e2))
|
||||
(should-not (cl-minusp 1.0e+INF))
|
||||
(should-error (cl-minusp "-42") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-oddp ()
|
||||
(should (cl-oddp -3))
|
||||
(should (cl-oddp 3))
|
||||
(should-not (cl-oddp -2))
|
||||
(should-not (cl-oddp 0))
|
||||
(should-not (cl-oddp 2))
|
||||
(should-error (cl-oddp 3.0e+NaN) :type 'wrong-type-argument)
|
||||
(should-error (cl-oddp 3.0) :type 'wrong-type-argument)
|
||||
(should-error (cl-oddp "3") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-evenp ()
|
||||
(should (cl-evenp -2))
|
||||
(should (cl-evenp 0))
|
||||
(should (cl-evenp 2))
|
||||
(should-not (cl-evenp -3))
|
||||
(should-not (cl-evenp 3))
|
||||
(should-error (cl-evenp 2.0e+NaN) :type 'wrong-type-argument)
|
||||
(should-error (cl-evenp 2.0) :type 'wrong-type-argument)
|
||||
(should-error (cl-evenp "2") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-digit-char-p ()
|
||||
(should (eql 3 (cl-digit-char-p ?3)))
|
||||
(should (eql 10 (cl-digit-char-p ?a 11)))
|
||||
(should (eql 10 (cl-digit-char-p ?A 11)))
|
||||
(should-not (cl-digit-char-p ?a))
|
||||
(should (eql 32 (cl-digit-char-p ?w 36)))
|
||||
(should-error (cl-digit-char-p ?a 37) :type 'args-out-of-range)
|
||||
(should-error (cl-digit-char-p ?a 1) :type 'args-out-of-range))
|
||||
|
||||
(ert-deftest cl-lib-test-first ()
|
||||
(should (null (cl-first '())))
|
||||
(should (= 4 (cl-first '(4))))
|
||||
(should (= 4 (cl-first '(4 2))))
|
||||
(should-error (cl-first "42") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-second ()
|
||||
(should (null (cl-second '())))
|
||||
(should (null (cl-second '(4))))
|
||||
(should (= 2 (cl-second '(1 2))))
|
||||
(should (= 2 (cl-second '(1 2 3))))
|
||||
(should-error (cl-second "1 2 3") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-third ()
|
||||
(should (null (cl-third '())))
|
||||
(should (null (cl-third '(1 2))))
|
||||
(should (= 3 (cl-third '(1 2 3))))
|
||||
(should (= 3 (cl-third '(1 2 3 4))))
|
||||
(should-error (cl-third "123") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-fourth ()
|
||||
(should (null (cl-fourth '())))
|
||||
(should (null (cl-fourth '(1 2 3))))
|
||||
(should (= 4 (cl-fourth '(1 2 3 4))))
|
||||
(should (= 4 (cl-fourth '(1 2 3 4 5))))
|
||||
(should-error (cl-fourth "1234") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-fifth ()
|
||||
(should (null (cl-fifth '())))
|
||||
(should (null (cl-fifth '(1 2 3 4))))
|
||||
(should (= 5 (cl-fifth '(1 2 3 4 5))))
|
||||
(should (= 5 (cl-fifth '(1 2 3 4 5 6))))
|
||||
(should-error (cl-fifth "12345") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-fifth ()
|
||||
(should (null (cl-fifth '())))
|
||||
(should (null (cl-fifth '(1 2 3 4))))
|
||||
(should (= 5 (cl-fifth '(1 2 3 4 5))))
|
||||
(should (= 5 (cl-fifth '(1 2 3 4 5 6))))
|
||||
(should-error (cl-fifth "12345") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-sixth ()
|
||||
(should (null (cl-sixth '())))
|
||||
(should (null (cl-sixth '(1 2 3 4 5))))
|
||||
(should (= 6 (cl-sixth '(1 2 3 4 5 6))))
|
||||
(should (= 6 (cl-sixth '(1 2 3 4 5 6 7))))
|
||||
(should-error (cl-sixth "123456") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-seventh ()
|
||||
(should (null (cl-seventh '())))
|
||||
(should (null (cl-seventh '(1 2 3 4 5 6))))
|
||||
(should (= 7 (cl-seventh '(1 2 3 4 5 6 7))))
|
||||
(should (= 7 (cl-seventh '(1 2 3 4 5 6 7 8))))
|
||||
(should-error (cl-seventh "1234567") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-eighth ()
|
||||
(should (null (cl-eighth '())))
|
||||
(should (null (cl-eighth '(1 2 3 4 5 6 7))))
|
||||
(should (= 8 (cl-eighth '(1 2 3 4 5 6 7 8))))
|
||||
(should (= 8 (cl-eighth '(1 2 3 4 5 6 7 8 9))))
|
||||
(should-error (cl-eighth "12345678") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-ninth ()
|
||||
(should (null (cl-ninth '())))
|
||||
(should (null (cl-ninth '(1 2 3 4 5 6 7 8))))
|
||||
(should (= 9 (cl-ninth '(1 2 3 4 5 6 7 8 9))))
|
||||
(should (= 9 (cl-ninth '(1 2 3 4 5 6 7 8 9 10))))
|
||||
(should-error (cl-ninth "123456789") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-tenth ()
|
||||
(should (null (cl-tenth '())))
|
||||
(should (null (cl-tenth '(1 2 3 4 5 6 7 8 9))))
|
||||
(should (= 10 (cl-tenth '(1 2 3 4 5 6 7 8 9 10))))
|
||||
(should (= 10 (cl-tenth '(1 2 3 4 5 6 7 8 9 10 11))))
|
||||
(should-error (cl-tenth "1234567890") :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-endp ()
|
||||
(should (cl-endp '()))
|
||||
(should-not (cl-endp '(1)))
|
||||
(should-error (cl-endp 1) :type 'wrong-type-argument)
|
||||
(should-error (cl-endp [1]) :type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest cl-lib-test-nth-value ()
|
||||
(let ((vals (cl-values 2 3)))
|
||||
(should (= (cl-nth-value 0 vals) 2))
|
||||
(should (= (cl-nth-value 1 vals) 3))
|
||||
(should (null (cl-nth-value 2 vals)))
|
||||
(should-error (cl-nth-value 0.0 vals) :type 'wrong-type-argument)))
|
||||
|
||||
(ert-deftest cl-lib-nth-value-test-multiple-values ()
|
||||
"While CL multiple values are an alias to list, these won't work."
|
||||
:expected-result :failed
|
||||
(should (eq (cl-nth-value 0 '(2 3)) '(2 3)))
|
||||
(should (= (cl-nth-value 0 1) 1))
|
||||
(should (null (cl-nth-value 1 1)))
|
||||
(should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range)
|
||||
(should (string= (cl-nth-value 0 "only lists") "only lists")))
|
||||
|
||||
(ert-deftest cl-test-caaar ()
|
||||
(should (null (cl-caaar '())))
|
||||
(should (null (cl-caaar '(() (2)))))
|
||||
(should (null (cl-caaar '((() (2)) (a b)))))
|
||||
(should-error (cl-caaar '(1 2)) :type 'wrong-type-argument)
|
||||
(should-error (cl-caaar '((1 2))) :type 'wrong-type-argument)
|
||||
(should (= 1 (cl-caaar '(((1 2) (3 4))))))
|
||||
(should (null (cl-caaar '((() (3 4)))))))
|
||||
|
||||
(ert-deftest cl-test-caadr ()
|
||||
(should (null (cl-caadr '())))
|
||||
(should (null (cl-caadr '(1))))
|
||||
(should-error (cl-caadr '(1 2)) :type 'wrong-type-argument)
|
||||
(should (= 2 (cl-caadr '(1 (2 3)))))
|
||||
(should (equal '((2) (3)) (cl-caadr '((1) (((2) (3))) (4))))))
|
||||
|
||||
(ert-deftest cl-test-ldiff ()
|
||||
(let ((l '(1 2 3)))
|
||||
(should (null (cl-ldiff '() '())))
|
||||
(should (null (cl-ldiff '() l)))
|
||||
(should (null (cl-ldiff l l)))
|
||||
(should (equal l (cl-ldiff l '())))
|
||||
;; must be part of the list
|
||||
(should (equal l (cl-ldiff l '(2 3))))
|
||||
(should (equal '(1) (cl-ldiff l (nthcdr 1 l))))
|
||||
;; should return a copy
|
||||
(should-not (eq (cl-ldiff l '()) l))))
|
||||
|
||||
(ert-deftest cl-lib-adjoin-test ()
|
||||
(let ((nums '(1 2))
|
||||
(myfn-p '=))
|
||||
;; add non-existing item to the front
|
||||
(should (equal '(3 1 2) (cl-adjoin 3 nums)))
|
||||
;; just add - don't copy rest
|
||||
(should (eq nums (cdr (cl-adjoin 3 nums))))
|
||||
;; add only when not already there
|
||||
(should (eq nums (cl-adjoin 2 nums)))
|
||||
(should (equal '(2 1 (2)) (cl-adjoin 2 '(1 (2)))))
|
||||
;; default test function is eql
|
||||
(should (equal '(1.0 1 2) (cl-adjoin 1.0 nums)))
|
||||
;; own :test function - returns true if match
|
||||
(should (equal '(1.0 1 2) (cl-adjoin 1.0 nums :test nil))) ;defaults to eql
|
||||
(should (eq nums (cl-adjoin 2 nums :test myfn-p))) ;match
|
||||
(should (equal '(3 1 2) (cl-adjoin 3 nums :test myfn-p))) ;no match
|
||||
;; own :test-not function - returns false if match
|
||||
(should (equal '(1.0 1 2) (cl-adjoin 1.0 nums :test-not nil))) ;defaults to eql
|
||||
(should (equal '(2 2) (cl-adjoin 2 '(2) :test-not myfn-p))) ; no match
|
||||
(should (eq nums (cl-adjoin 2 nums :test-not myfn-p))) ; 1 matches
|
||||
(should (eq nums (cl-adjoin 3 nums :test-not myfn-p))) ; 1 and 2 matches
|
||||
|
||||
;; according to CLtL2 passing both :test and :test-not should signal error
|
||||
;;(should-error (cl-adjoin 3 nums :test 'myfn-p :test-not myfn-p))
|
||||
|
||||
;; own :key fn
|
||||
(should (eq nums (cl-adjoin 3 nums :key (lambda (x) (if (cl-evenp x) (1+ x) x)))))
|
||||
(should (equal '(3 1 2) (cl-adjoin 3 nums :key (lambda (x) (if (cl-evenp x) (+ 2 x) x)))))
|
||||
|
||||
;; convert using :key, then compare with :test
|
||||
(should (eq nums (cl-adjoin 1 nums :key 'int-to-string :test 'string=)))
|
||||
(should (equal '(3 1 2) (cl-adjoin 3 nums :key 'int-to-string :test 'string=)))
|
||||
(should-error (cl-adjoin 3 nums :key 'int-to-string :test myfn-p)
|
||||
:type 'wrong-type-argument)
|
||||
|
||||
;; convert using :key, then compare with :test-not
|
||||
(should (eq nums (cl-adjoin 3 nums :key 'int-to-string :test-not 'string=)))
|
||||
(should (equal '(1 1) (cl-adjoin 1 '(1) :key 'int-to-string :test-not 'string=)))
|
||||
(should-error (cl-adjoin 1 nums :key 'int-to-string :test-not myfn-p)
|
||||
:type 'wrong-type-argument)))
|
||||
|
||||
(ert-deftest cl-parse-integer ()
|
||||
(should-error (cl-parse-integer "abc"))
|
||||
(should (null (cl-parse-integer "abc" :junk-allowed t)))
|
||||
(should (null (cl-parse-integer "" :junk-allowed t)))
|
||||
(should (= 342391 (cl-parse-integer "0123456789" :radix 8 :junk-allowed t)))
|
||||
(should-error (cl-parse-integer "0123456789" :radix 8))
|
||||
(should (= -239 (cl-parse-integer "-efz" :radix 16 :junk-allowed t)))
|
||||
(should-error (cl-parse-integer "efz" :radix 16))
|
||||
(should (= 239 (cl-parse-integer "zzef" :radix 16 :start 2)))
|
||||
(should (= -123 (cl-parse-integer " -123 "))))
|
||||
|
||||
(ert-deftest cl-loop-destructuring-with ()
|
||||
(should (equal (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6)))
|
||||
|
||||
(ert-deftest cl-flet-test ()
|
||||
(should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5)))
|
||||
|
||||
(ert-deftest cl-lib-test-typep ()
|
||||
(cl-deftype cl-lib-test-type (&optional x) `(member ,x))
|
||||
;; Make sure we correctly implement the rule that deftype's optional args
|
||||
;; default to `*' rather than to nil.
|
||||
(should (cl-typep '* 'cl-lib-test-type))
|
||||
(should-not (cl-typep 1 'cl-lib-test-type)))
|
||||
|
||||
;;; cl-lib.el ends here
|
||||
402
test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el
Normal file
402
test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el
Normal file
|
|
@ -0,0 +1,402 @@
|
|||
;;; eieio-testsinvoke.el -- eieio tests for method invocation
|
||||
|
||||
;; Copyright (C) 2005, 2008, 2010, 2013-2015 Free Software Foundation,
|
||||
;; Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; Test method invocation order. From the common lisp reference
|
||||
;; manual:
|
||||
;;
|
||||
;; QUOTE:
|
||||
;; - All the :before methods are called, in most-specific-first
|
||||
;; order. Their values are ignored. An error is signaled if
|
||||
;; call-next-method is used in a :before method.
|
||||
;;
|
||||
;; - The most specific primary method is called. Inside the body of a
|
||||
;; primary method, call-next-method may be used to call the next
|
||||
;; most specific primary method. When that method returns, the
|
||||
;; previous primary method can execute more code, perhaps based on
|
||||
;; the returned value or values. The generic function no-next-method
|
||||
;; is invoked if call-next-method is used and there are no more
|
||||
;; applicable primary methods. The function next-method-p may be
|
||||
;; used to determine whether a next method exists. If
|
||||
;; call-next-method is not used, only the most specific primary
|
||||
;; method is called.
|
||||
;;
|
||||
;; - All the :after methods are called, in most-specific-last order.
|
||||
;; Their values are ignored. An error is signaled if
|
||||
;; call-next-method is used in a :after method.
|
||||
;;
|
||||
;;
|
||||
;; Also test behavior of `call-next-method'. From clos.org:
|
||||
;;
|
||||
;; QUOTE:
|
||||
;; When call-next-method is called with no arguments, it passes the
|
||||
;; current method's original arguments to the next method.
|
||||
|
||||
(require 'eieio)
|
||||
(require 'ert)
|
||||
|
||||
(defvar eieio-test-method-order-list nil
|
||||
"List of symbols stored during method invocation.")
|
||||
|
||||
(defun eieio-test-method-store (&rest args)
|
||||
"Store current invocation class symbol in the invocation order list."
|
||||
(push args eieio-test-method-order-list))
|
||||
|
||||
(defun eieio-test-match (rightanswer)
|
||||
"Do a test match."
|
||||
(if (equal rightanswer eieio-test-method-order-list)
|
||||
t
|
||||
(error "eieio-test-methodinvoke.el: Test Failed: %S != %S"
|
||||
rightanswer eieio-test-method-order-list)))
|
||||
|
||||
(defvar eieio-test-call-next-method-arguments nil
|
||||
"List of passed to methods during execution of `call-next-method'.")
|
||||
|
||||
(defun eieio-test-arguments-for (class)
|
||||
"Returns arguments passed to method of CLASS during `call-next-method'."
|
||||
(cdr (assoc class eieio-test-call-next-method-arguments)))
|
||||
|
||||
(defclass eitest-A () ())
|
||||
(defclass eitest-AA (eitest-A) ())
|
||||
(defclass eitest-AAA (eitest-AA) ())
|
||||
(defclass eitest-B-base1 () ())
|
||||
(defclass eitest-B-base2 () ())
|
||||
(defclass eitest-B (eitest-B-base1 eitest-B-base2) ())
|
||||
|
||||
(defmethod eitest-F :BEFORE ((p eitest-B-base1))
|
||||
(eieio-test-method-store :BEFORE 'eitest-B-base1))
|
||||
|
||||
(defmethod eitest-F :BEFORE ((p eitest-B-base2))
|
||||
(eieio-test-method-store :BEFORE 'eitest-B-base2))
|
||||
|
||||
(defmethod eitest-F :BEFORE ((p eitest-B))
|
||||
(eieio-test-method-store :BEFORE 'eitest-B))
|
||||
|
||||
(defmethod eitest-F ((p eitest-B))
|
||||
(eieio-test-method-store :PRIMARY 'eitest-B)
|
||||
(call-next-method))
|
||||
|
||||
(defmethod eitest-F ((p eitest-B-base1))
|
||||
(eieio-test-method-store :PRIMARY 'eitest-B-base1)
|
||||
(call-next-method))
|
||||
|
||||
(defmethod eitest-F ((p eitest-B-base2))
|
||||
(eieio-test-method-store :PRIMARY 'eitest-B-base2)
|
||||
(when (next-method-p)
|
||||
(call-next-method))
|
||||
)
|
||||
|
||||
(defmethod eitest-F :AFTER ((p eitest-B-base1))
|
||||
(eieio-test-method-store :AFTER 'eitest-B-base1))
|
||||
|
||||
(defmethod eitest-F :AFTER ((p eitest-B-base2))
|
||||
(eieio-test-method-store :AFTER 'eitest-B-base2))
|
||||
|
||||
(defmethod eitest-F :AFTER ((p eitest-B))
|
||||
(eieio-test-method-store :AFTER 'eitest-B))
|
||||
|
||||
(ert-deftest eieio-test-method-order-list-3 ()
|
||||
(let ((eieio-test-method-order-list nil)
|
||||
(ans '(
|
||||
(:BEFORE eitest-B)
|
||||
(:BEFORE eitest-B-base1)
|
||||
(:BEFORE eitest-B-base2)
|
||||
|
||||
(:PRIMARY eitest-B)
|
||||
(:PRIMARY eitest-B-base1)
|
||||
(:PRIMARY eitest-B-base2)
|
||||
|
||||
(:AFTER eitest-B-base2)
|
||||
(:AFTER eitest-B-base1)
|
||||
(:AFTER eitest-B)
|
||||
)))
|
||||
(eitest-F (eitest-B nil))
|
||||
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
|
||||
(eieio-test-match ans)))
|
||||
|
||||
;;; Test static invocation
|
||||
;;
|
||||
(defmethod eitest-H :STATIC ((class eitest-A))
|
||||
"No need to do work in here."
|
||||
'moose)
|
||||
|
||||
(ert-deftest eieio-test-method-order-list-4 ()
|
||||
;; Both of these situations should succeed.
|
||||
(should (eitest-H 'eitest-A))
|
||||
(should (eitest-H (eitest-A nil))))
|
||||
|
||||
;;; Return value from :PRIMARY
|
||||
;;
|
||||
(defmethod eitest-I :BEFORE ((a eitest-A))
|
||||
(eieio-test-method-store :BEFORE 'eitest-A)
|
||||
":before")
|
||||
|
||||
(defmethod eitest-I :PRIMARY ((a eitest-A))
|
||||
(eieio-test-method-store :PRIMARY 'eitest-A)
|
||||
":primary")
|
||||
|
||||
(defmethod eitest-I :AFTER ((a eitest-A))
|
||||
(eieio-test-method-store :AFTER 'eitest-A)
|
||||
":after")
|
||||
|
||||
(ert-deftest eieio-test-method-order-list-5 ()
|
||||
(let ((eieio-test-method-order-list nil)
|
||||
(ans (eitest-I (eitest-A nil))))
|
||||
(should (string= ans ":primary"))))
|
||||
|
||||
;;; Multiple inheritance and the 'constructor' method.
|
||||
;;
|
||||
;; Constructor is a static method, so this is really testing
|
||||
;; static method invocation and multiple inheritance.
|
||||
;;
|
||||
(defclass C-base1 () ())
|
||||
(defclass C-base2 () ())
|
||||
(defclass C (C-base1 C-base2) ())
|
||||
|
||||
;; Just use the obsolete name once, to make sure it also works.
|
||||
(defmethod constructor :STATIC ((p C-base1) &rest args)
|
||||
(eieio-test-method-store :STATIC 'C-base1)
|
||||
(if (next-method-p) (call-next-method))
|
||||
)
|
||||
|
||||
(defmethod make-instance :STATIC ((p C-base2) &rest args)
|
||||
(eieio-test-method-store :STATIC 'C-base2)
|
||||
(if (next-method-p) (call-next-method))
|
||||
)
|
||||
|
||||
(cl-defmethod make-instance ((p (subclass C)) &rest args)
|
||||
(eieio-test-method-store :STATIC 'C)
|
||||
(cl-call-next-method)
|
||||
)
|
||||
|
||||
(ert-deftest eieio-test-method-order-list-6 ()
|
||||
(let ((eieio-test-method-order-list nil)
|
||||
(ans '(
|
||||
(:STATIC C)
|
||||
(:STATIC C-base1)
|
||||
(:STATIC C-base2)
|
||||
)))
|
||||
(C nil)
|
||||
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
|
||||
(eieio-test-match ans)))
|
||||
|
||||
;;; Diamond Test
|
||||
;;
|
||||
;; For a diamond shaped inheritance structure, (call-next-method) can break.
|
||||
;; As such, there are two possible orders.
|
||||
|
||||
(defclass D-base0 () () :method-invocation-order :depth-first)
|
||||
(defclass D-base1 (D-base0) () :method-invocation-order :depth-first)
|
||||
(defclass D-base2 (D-base0) () :method-invocation-order :depth-first)
|
||||
(defclass D (D-base1 D-base2) () :method-invocation-order :depth-first)
|
||||
|
||||
(defmethod eitest-F ((p D))
|
||||
"D"
|
||||
(eieio-test-method-store :PRIMARY 'D)
|
||||
(call-next-method))
|
||||
|
||||
(defmethod eitest-F ((p D-base0))
|
||||
"D-base0"
|
||||
(eieio-test-method-store :PRIMARY 'D-base0)
|
||||
;; This should have no next
|
||||
;; (when (next-method-p) (call-next-method))
|
||||
)
|
||||
|
||||
(defmethod eitest-F ((p D-base1))
|
||||
"D-base1"
|
||||
(eieio-test-method-store :PRIMARY 'D-base1)
|
||||
(call-next-method))
|
||||
|
||||
(defmethod eitest-F ((p D-base2))
|
||||
"D-base2"
|
||||
(eieio-test-method-store :PRIMARY 'D-base2)
|
||||
(when (next-method-p)
|
||||
(call-next-method))
|
||||
)
|
||||
|
||||
(ert-deftest eieio-test-method-order-list-7 ()
|
||||
(let ((eieio-test-method-order-list nil)
|
||||
(ans '(
|
||||
(:PRIMARY D)
|
||||
(:PRIMARY D-base1)
|
||||
;; (:PRIMARY D-base2)
|
||||
(:PRIMARY D-base0)
|
||||
)))
|
||||
(eitest-F (D nil))
|
||||
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
|
||||
(eieio-test-match ans)))
|
||||
|
||||
;;; Other invocation order
|
||||
|
||||
(defclass E-base0 () () :method-invocation-order :breadth-first)
|
||||
(defclass E-base1 (E-base0) () :method-invocation-order :breadth-first)
|
||||
(defclass E-base2 (E-base0) () :method-invocation-order :breadth-first)
|
||||
(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)
|
||||
|
||||
(defmethod eitest-F ((p E))
|
||||
(eieio-test-method-store :PRIMARY 'E)
|
||||
(call-next-method))
|
||||
|
||||
(defmethod eitest-F ((p E-base0))
|
||||
(eieio-test-method-store :PRIMARY 'E-base0)
|
||||
;; This should have no next
|
||||
;; (when (next-method-p) (call-next-method))
|
||||
)
|
||||
|
||||
(defmethod eitest-F ((p E-base1))
|
||||
(eieio-test-method-store :PRIMARY 'E-base1)
|
||||
(call-next-method))
|
||||
|
||||
(defmethod eitest-F ((p E-base2))
|
||||
(eieio-test-method-store :PRIMARY 'E-base2)
|
||||
(when (next-method-p)
|
||||
(call-next-method))
|
||||
)
|
||||
|
||||
(ert-deftest eieio-test-method-order-list-8 ()
|
||||
(let ((eieio-test-method-order-list nil)
|
||||
(ans '(
|
||||
(:PRIMARY E)
|
||||
(:PRIMARY E-base1)
|
||||
(:PRIMARY E-base2)
|
||||
(:PRIMARY E-base0)
|
||||
)))
|
||||
(eitest-F (E nil))
|
||||
(setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
|
||||
(eieio-test-match ans)))
|
||||
|
||||
;;; Jan's methodinvoke order w/ multiple inheritance and :after methods.
|
||||
;;
|
||||
(defclass eitest-Ja ()
|
||||
())
|
||||
|
||||
(defmethod initialize-instance :after ((this eitest-Ja) &rest slots)
|
||||
;(message "+Ja")
|
||||
;; FIXME: Using next-method-p in an after-method is invalid!
|
||||
(when (next-method-p)
|
||||
(call-next-method))
|
||||
;(message "-Ja")
|
||||
)
|
||||
|
||||
(defclass eitest-Jb ()
|
||||
())
|
||||
|
||||
(defmethod initialize-instance :after ((this eitest-Jb) &rest slots)
|
||||
;(message "+Jb")
|
||||
;; FIXME: Using next-method-p in an after-method is invalid!
|
||||
(when (next-method-p)
|
||||
(call-next-method))
|
||||
;(message "-Jb")
|
||||
)
|
||||
|
||||
(defclass eitest-Jc (eitest-Jb)
|
||||
())
|
||||
|
||||
(defclass eitest-Jd (eitest-Jc eitest-Ja)
|
||||
())
|
||||
|
||||
(defmethod initialize-instance ((this eitest-Jd) &rest slots)
|
||||
;(message "+Jd")
|
||||
(when (next-method-p)
|
||||
(call-next-method))
|
||||
;(message "-Jd")
|
||||
)
|
||||
|
||||
(ert-deftest eieio-test-method-order-list-9 ()
|
||||
(should (eitest-Jd "test")))
|
||||
|
||||
;;; call-next-method with replacement arguments across a simple class hierarchy.
|
||||
;;
|
||||
|
||||
(defclass CNM-0 ()
|
||||
())
|
||||
|
||||
(defclass CNM-1-1 (CNM-0)
|
||||
())
|
||||
|
||||
(defclass CNM-1-2 (CNM-0)
|
||||
())
|
||||
|
||||
(defclass CNM-2 (CNM-1-1 CNM-1-2)
|
||||
())
|
||||
|
||||
(defmethod CNM-M ((this CNM-0) args)
|
||||
(push (cons 'CNM-0 (copy-sequence args))
|
||||
eieio-test-call-next-method-arguments)
|
||||
(when (next-method-p)
|
||||
(call-next-method
|
||||
this (cons 'CNM-0 args))))
|
||||
|
||||
(defmethod CNM-M ((this CNM-1-1) args)
|
||||
(push (cons 'CNM-1-1 (copy-sequence args))
|
||||
eieio-test-call-next-method-arguments)
|
||||
(when (next-method-p)
|
||||
(call-next-method
|
||||
this (cons 'CNM-1-1 args))))
|
||||
|
||||
(defmethod CNM-M ((this CNM-1-2) args)
|
||||
(push (cons 'CNM-1-2 (copy-sequence args))
|
||||
eieio-test-call-next-method-arguments)
|
||||
(when (next-method-p)
|
||||
(call-next-method)))
|
||||
|
||||
(defmethod CNM-M ((this CNM-2) args)
|
||||
(push (cons 'CNM-2 (copy-sequence args))
|
||||
eieio-test-call-next-method-arguments)
|
||||
(when (next-method-p)
|
||||
(call-next-method
|
||||
this (cons 'CNM-2 args))))
|
||||
|
||||
(ert-deftest eieio-test-method-order-list-10 ()
|
||||
(let ((eieio-test-call-next-method-arguments nil))
|
||||
(CNM-M (CNM-2 "") '(INIT))
|
||||
(should (equal (eieio-test-arguments-for 'CNM-0)
|
||||
'(CNM-1-1 CNM-2 INIT)))
|
||||
(should (equal (eieio-test-arguments-for 'CNM-1-1)
|
||||
'(CNM-2 INIT)))
|
||||
(should (equal (eieio-test-arguments-for 'CNM-1-2)
|
||||
'(CNM-1-1 CNM-2 INIT)))
|
||||
(should (equal (eieio-test-arguments-for 'CNM-2)
|
||||
'(INIT)))))
|
||||
|
||||
;;; Check cl-generic integration.
|
||||
|
||||
(cl-defgeneric eieio-test--1 (x y))
|
||||
|
||||
(ert-deftest eieio-test-cl-generic-1 ()
|
||||
(cl-defgeneric eieio-test--1 (x y))
|
||||
(cl-defmethod eieio-test--1 (x y) (list x y))
|
||||
(cl-defmethod eieio-test--1 ((_x CNM-0) y)
|
||||
(cons "CNM-0" (cl-call-next-method 7 y)))
|
||||
(cl-defmethod eieio-test--1 ((_x CNM-1-1) _y)
|
||||
(cons "CNM-1-1" (cl-call-next-method)))
|
||||
(cl-defmethod eieio-test--1 ((_x CNM-1-2) _y)
|
||||
(cons "CNM-1-2" (cl-call-next-method)))
|
||||
(cl-defmethod eieio-test--1 ((_x (subclass CNM-1-2)) _y)
|
||||
(cons "subclass CNM-1-2" (cl-call-next-method)))
|
||||
(should (equal (eieio-test--1 4 5) '(4 5)))
|
||||
(should (equal (eieio-test--1 (make-instance 'CNM-0) 5)
|
||||
'("CNM-0" 7 5)))
|
||||
(should (equal (eieio-test--1 (make-instance 'CNM-2) 5)
|
||||
'("CNM-1-1" "CNM-1-2" "CNM-0" 7 5)))
|
||||
(should (equal (eieio-test--1 'CNM-2 6) '("subclass CNM-1-2" CNM-2 6))))
|
||||
219
test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
Normal file
219
test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
Normal file
|
|
@ -0,0 +1,219 @@
|
|||
;;; eieio-persist.el --- Tests for eieio-persistent class
|
||||
|
||||
;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <eric@siege-engine.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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; The eieio-persistent base-class provides a vital service, that
|
||||
;; could be used to accidentally load in malicious code. As such,
|
||||
;; something as simple as calling eval on the generated code can't be
|
||||
;; used. These tests exercises various flavors of data that might be
|
||||
;; in a persistent object, and tries to save/load them.
|
||||
|
||||
;;; Code:
|
||||
(require 'eieio)
|
||||
(require 'eieio-base)
|
||||
(require 'ert)
|
||||
|
||||
(defun eieio--attribute-to-initarg (class attribute)
|
||||
"In CLASS, convert the ATTRIBUTE into the corresponding init argument tag.
|
||||
This is usually a symbol that starts with `:'."
|
||||
(let ((tuple (rassoc attribute (eieio--class-initarg-tuples class))))
|
||||
(if tuple
|
||||
(car tuple)
|
||||
nil)))
|
||||
|
||||
(defun persist-test-save-and-compare (original)
|
||||
"Compare the object ORIGINAL against the one read fromdisk."
|
||||
|
||||
(eieio-persistent-save original)
|
||||
|
||||
(let* ((file (oref original file))
|
||||
(class (eieio-object-class original))
|
||||
(fromdisk (eieio-persistent-read file class))
|
||||
(cv (cl--find-class class))
|
||||
(slots (eieio--class-slots cv))
|
||||
)
|
||||
(unless (object-of-class-p fromdisk class)
|
||||
(error "Persistent class %S != original class %S"
|
||||
(eieio-object-class fromdisk)
|
||||
class))
|
||||
|
||||
(dotimes (i (length slots))
|
||||
(let* ((slot (aref slots i))
|
||||
(oneslot (cl--slot-descriptor-name slot))
|
||||
(origvalue (eieio-oref original oneslot))
|
||||
(fromdiskvalue (eieio-oref fromdisk oneslot))
|
||||
(initarg-p (eieio--attribute-to-initarg
|
||||
(cl--find-class class) oneslot))
|
||||
)
|
||||
|
||||
(if initarg-p
|
||||
(unless (equal origvalue fromdiskvalue)
|
||||
(error "Slot %S Original Val %S != Persistent Val %S"
|
||||
oneslot origvalue fromdiskvalue))
|
||||
;; Else !initarg-p
|
||||
(unless (equal (cl--slot-descriptor-initform slot) fromdiskvalue)
|
||||
(error "Slot %S Persistent Val %S != Default Value %S"
|
||||
oneslot fromdiskvalue (cl--slot-descriptor-initform slot))))
|
||||
))))
|
||||
|
||||
;;; Simple Case
|
||||
;;
|
||||
;; Simplest case is a mix of slots with and without initargs.
|
||||
|
||||
(defclass persist-simple (eieio-persistent)
|
||||
((slot1 :initarg :slot1
|
||||
:type symbol
|
||||
:initform moose)
|
||||
(slot2 :initarg :slot2
|
||||
:initform "foo")
|
||||
(slot3 :initform 2))
|
||||
"A Persistent object with two initializable slots, and one not.")
|
||||
|
||||
(ert-deftest eieio-test-persist-simple-1 ()
|
||||
(let ((persist-simple-1
|
||||
(persist-simple "simple 1" :slot1 'goose :slot2 "testing"
|
||||
:file (concat default-directory "test-ps1.pt"))))
|
||||
(should persist-simple-1)
|
||||
|
||||
;; When the slot w/out an initarg has not been changed
|
||||
(persist-test-save-and-compare persist-simple-1)
|
||||
|
||||
;; When the slot w/out an initarg HAS been changed
|
||||
(oset persist-simple-1 slot3 3)
|
||||
(persist-test-save-and-compare persist-simple-1)
|
||||
(delete-file (oref persist-simple-1 file))))
|
||||
|
||||
;;; Slot Writers
|
||||
;;
|
||||
;; Replica of the test in eieio-tests.el -
|
||||
|
||||
(defclass persist-:printer (eieio-persistent)
|
||||
((slot1 :initarg :slot1
|
||||
:initform 'moose
|
||||
:printer PO-slot1-printer)
|
||||
(slot2 :initarg :slot2
|
||||
:initform "foo"))
|
||||
"A Persistent object with two initializable slots.")
|
||||
|
||||
(defun PO-slot1-printer (slotvalue)
|
||||
"Print the slot value SLOTVALUE to stdout.
|
||||
Assume SLOTVALUE is a symbol of some sort."
|
||||
(princ "'")
|
||||
(princ (symbol-name slotvalue))
|
||||
(princ " ;; RAN PRINTER")
|
||||
nil)
|
||||
|
||||
(ert-deftest eieio-test-persist-printer ()
|
||||
(let ((persist-:printer-1
|
||||
(persist-:printer "persist" :slot1 'goose :slot2 "testing"
|
||||
:file (concat default-directory "test-ps2.pt"))))
|
||||
(should persist-:printer-1)
|
||||
(persist-test-save-and-compare persist-:printer-1)
|
||||
|
||||
(let* ((find-file-hook nil)
|
||||
(tbuff (find-file-noselect "test-ps2.pt"))
|
||||
)
|
||||
(condition-case nil
|
||||
(unwind-protect
|
||||
(with-current-buffer tbuff
|
||||
(goto-char (point-min))
|
||||
(re-search-forward "RAN PRINTER"))
|
||||
(kill-buffer tbuff))
|
||||
(error "persist-:printer-1's Slot1 printer function didn't work.")))
|
||||
(delete-file (oref persist-:printer-1 file))))
|
||||
|
||||
;;; Slot with Object
|
||||
;;
|
||||
;; A slot that contains another object that isn't persistent
|
||||
(defclass persist-not-persistent ()
|
||||
((slot1 :initarg :slot1
|
||||
:initform 1)
|
||||
(slot2 :initform 2))
|
||||
"Class for testing persistent saving of an object that isn't
|
||||
persistent. This class is instead used as a slot value in a
|
||||
persistent class.")
|
||||
|
||||
(defclass persistent-with-objs-slot (eieio-persistent)
|
||||
((pnp :initarg :pnp
|
||||
:type (or null persist-not-persistent)
|
||||
:initform nil))
|
||||
"Class for testing the saving of slots with objects in them.")
|
||||
|
||||
(ert-deftest eieio-test-non-persistent-as-slot ()
|
||||
(let ((persist-wos
|
||||
(persistent-with-objs-slot
|
||||
"persist wos 1"
|
||||
:pnp (persist-not-persistent "pnp 1" :slot1 3)
|
||||
:file (concat default-directory "test-ps3.pt"))))
|
||||
|
||||
(persist-test-save-and-compare persist-wos)
|
||||
(delete-file (oref persist-wos file))))
|
||||
|
||||
;;; Slot with Object child of :type
|
||||
;;
|
||||
;; A slot that contains another object that isn't persistent
|
||||
(defclass persist-not-persistent-subclass (persist-not-persistent)
|
||||
((slot3 :initarg :slot1
|
||||
:initform 1)
|
||||
(slot4 :initform 2))
|
||||
"Class for testing persistent saving of an object subclass that isn't
|
||||
persistent. This class is instead used as a slot value in a
|
||||
persistent class.")
|
||||
|
||||
(defclass persistent-with-objs-slot-subs (eieio-persistent)
|
||||
((pnp :initarg :pnp
|
||||
:type (or null persist-not-persistent)
|
||||
:initform nil))
|
||||
"Class for testing the saving of slots with objects in them.")
|
||||
|
||||
(ert-deftest eieio-test-non-persistent-as-slot-child ()
|
||||
(let ((persist-woss
|
||||
(persistent-with-objs-slot-subs
|
||||
"persist woss 1"
|
||||
:pnp (persist-not-persistent-subclass "pnps 1" :slot1 3)
|
||||
:file (concat default-directory "test-ps4.pt"))))
|
||||
|
||||
(persist-test-save-and-compare persist-woss)
|
||||
(delete-file (oref persist-woss file))))
|
||||
|
||||
;;; Slot with a list of Objects
|
||||
;;
|
||||
;; A slot that contains another object that isn't persistent
|
||||
(defclass persistent-with-objs-list-slot (eieio-persistent)
|
||||
((pnp :initarg :pnp
|
||||
:type (list-of persist-not-persistent)
|
||||
:initform nil))
|
||||
"Class for testing the saving of slots with objects in them.")
|
||||
|
||||
(ert-deftest eieio-test-slot-with-list-of-objects ()
|
||||
(let ((persist-wols
|
||||
(persistent-with-objs-list-slot
|
||||
"persist wols 1"
|
||||
:pnp (list (persist-not-persistent "pnp 1" :slot1 3)
|
||||
(persist-not-persistent "pnp 2" :slot1 4)
|
||||
(persist-not-persistent "pnp 3" :slot1 5))
|
||||
:file (concat default-directory "test-ps5.pt"))))
|
||||
|
||||
(persist-test-save-and-compare persist-wols)
|
||||
(delete-file (oref persist-wols file))))
|
||||
|
||||
;;; eieio-test-persist.el ends here
|
||||
900
test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
Normal file
900
test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
Normal file
|
|
@ -0,0 +1,900 @@
|
|||
;;; eieio-tests.el -- eieio tests routines
|
||||
|
||||
;; Copyright (C) 1999-2003, 2005-2010, 2012-2015 Free Software
|
||||
;; Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; Test the various features of EIEIO.
|
||||
|
||||
(require 'ert)
|
||||
(require 'eieio)
|
||||
(require 'eieio-base)
|
||||
(require 'eieio-opt)
|
||||
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
|
||||
;;; Code:
|
||||
;; Set up some test classes
|
||||
(defclass class-a ()
|
||||
((water :initarg :water
|
||||
:initform h20
|
||||
:type symbol
|
||||
:documentation "Detail about water.")
|
||||
(classslot :initform penguin
|
||||
:type symbol
|
||||
:documentation "A class allocated slot."
|
||||
:allocation :class)
|
||||
(test-tag :initform nil
|
||||
:documentation "Used to make sure methods are called.")
|
||||
(self :initform nil
|
||||
:type (or null class-a)
|
||||
:documentation "Test self referencing types.")
|
||||
)
|
||||
"Class A")
|
||||
|
||||
(defclass class-b ()
|
||||
((land :initform "Sc"
|
||||
:type string
|
||||
:documentation "Detail about land."))
|
||||
"Class B")
|
||||
|
||||
(defclass class-ab (class-a class-b)
|
||||
((amphibian :initform "frog"
|
||||
:documentation "Detail about amphibian on land and water."))
|
||||
"Class A and B combined.")
|
||||
|
||||
(defclass class-c ()
|
||||
((slot-1 :initarg :moose
|
||||
:initform moose
|
||||
:type symbol
|
||||
:allocation :instance
|
||||
:documentation "First slot testing slot arguments."
|
||||
:custom symbol
|
||||
:label "Wild Animal"
|
||||
:group borg
|
||||
:protection :public)
|
||||
(slot-2 :initarg :penguin
|
||||
:initform "penguin"
|
||||
:type string
|
||||
:allocation :instance
|
||||
:documentation "Second slot testing slot arguments."
|
||||
:custom string
|
||||
:label "Wild bird"
|
||||
:group vorlon
|
||||
:accessor get-slot-2
|
||||
:protection :private)
|
||||
(slot-3 :initarg :emu
|
||||
:initform emu
|
||||
:type symbol
|
||||
:allocation :class
|
||||
:documentation "Third slot test class allocated accessor"
|
||||
:custom symbol
|
||||
:label "Fuzz"
|
||||
:group tokra
|
||||
:accessor get-slot-3
|
||||
:protection :private)
|
||||
)
|
||||
(:custom-groups (foo))
|
||||
"A class for testing slot arguments."
|
||||
)
|
||||
|
||||
(defclass class-subc (class-c)
|
||||
((slot-1 ;; :initform moose - don't override this
|
||||
)
|
||||
(slot-2 :initform "linux" ;; Do override this one
|
||||
:protection :private
|
||||
))
|
||||
"A class for testing slot arguments.")
|
||||
|
||||
;;; Defining a class with a slot tag error
|
||||
;;
|
||||
;; Temporarily disable this test because of macro expansion changes in
|
||||
;; current Emacs trunk. It can be re-enabled when we have moved
|
||||
;; `eieio-defclass' into the `defclass' macro and the
|
||||
;; `eval-and-compile' there is removed.
|
||||
|
||||
;; (let ((eieio-error-unsupported-class-tags t))
|
||||
;; (condition-case nil
|
||||
;; (progn
|
||||
;; (defclass class-error ()
|
||||
;; ((error-slot :initarg :error-slot
|
||||
;; :badslottag 1))
|
||||
;; "A class with a bad slot tag.")
|
||||
;; (error "No error was thrown for badslottag"))
|
||||
;; (invalid-slot-type nil)))
|
||||
|
||||
;; (let ((eieio-error-unsupported-class-tags nil))
|
||||
;; (condition-case nil
|
||||
;; (progn
|
||||
;; (defclass class-error ()
|
||||
;; ((error-slot :initarg :error-slot
|
||||
;; :badslottag 1))
|
||||
;; "A class with a bad slot tag."))
|
||||
;; (invalid-slot-type
|
||||
;; (error "invalid-slot-type thrown when eieio-error-unsupported-class-tags is nil")
|
||||
;; )))
|
||||
|
||||
(ert-deftest eieio-test-01-mix-alloc-initarg ()
|
||||
;; Only run this test if the message framework thingy works.
|
||||
(when (and (message "foo") (string= "foo" (current-message)))
|
||||
|
||||
;; Defining this class should generate a warning(!) message that
|
||||
;; you should not mix :initarg with class allocated slots.
|
||||
(defclass class-alloc-initarg ()
|
||||
((throwwarning :initarg :throwwarning
|
||||
:allocation :class))
|
||||
"Throw a warning mixing allocation class and an initarg.")
|
||||
|
||||
;; Check that message is there
|
||||
(should (current-message))
|
||||
(should (string-match "Class allocated slots do not need :initarg"
|
||||
(current-message)))))
|
||||
|
||||
(defclass abstract-class ()
|
||||
((some-slot :initarg :some-slot
|
||||
:initform nil
|
||||
:documentation "A slot."))
|
||||
:documentation "An abstract class."
|
||||
:abstract t)
|
||||
|
||||
(ert-deftest eieio-test-02-abstract-class ()
|
||||
;; Abstract classes cannot be instantiated, so this should throw an
|
||||
;; error
|
||||
(should-error (abstract-class)))
|
||||
|
||||
(defgeneric generic1 () "First generic function")
|
||||
|
||||
(ert-deftest eieio-test-03-generics ()
|
||||
(defun anormalfunction () "A plain function for error testing." nil)
|
||||
(should-error
|
||||
(progn
|
||||
(defgeneric anormalfunction ()
|
||||
"Attempt to turn it into a generic.")))
|
||||
|
||||
;; Check that generic-p works
|
||||
(should (generic-p 'generic1))
|
||||
|
||||
(defmethod generic1 ((c class-a))
|
||||
"Method on generic1."
|
||||
'monkey)
|
||||
|
||||
(defmethod generic1 (not-an-object)
|
||||
"Method generic1 that can take a non-object."
|
||||
not-an-object)
|
||||
|
||||
(let ((ans-obj (generic1 (class-a)))
|
||||
(ans-num (generic1 666)))
|
||||
(should (eq ans-obj 'monkey))
|
||||
(should (eq ans-num 666))))
|
||||
|
||||
(defclass static-method-class ()
|
||||
((some-slot :initform nil
|
||||
:allocation :class
|
||||
:documentation "A slot."))
|
||||
:documentation "A class used for testing static methods.")
|
||||
|
||||
(defmethod static-method-class-method :STATIC ((c static-method-class) value)
|
||||
"Test static methods.
|
||||
Argument C is the class bound to this static method."
|
||||
(if (eieio-object-p c) (setq c (eieio-object-class c)))
|
||||
(oset-default c some-slot value))
|
||||
|
||||
(ert-deftest eieio-test-04-static-method ()
|
||||
;; Call static method on a class and see if it worked
|
||||
(static-method-class-method 'static-method-class 'class)
|
||||
(should (eq (oref-default 'static-method-class some-slot) 'class))
|
||||
(static-method-class-method (static-method-class) 'object)
|
||||
(should (eq (oref-default 'static-method-class some-slot) 'object)))
|
||||
|
||||
(ert-deftest eieio-test-05-static-method-2 ()
|
||||
(defclass static-method-class-2 (static-method-class)
|
||||
()
|
||||
"A second class after the previous for static methods.")
|
||||
|
||||
(defmethod static-method-class-method :STATIC ((c static-method-class-2) value)
|
||||
"Test static methods.
|
||||
Argument C is the class bound to this static method."
|
||||
(if (eieio-object-p c) (setq c (eieio-object-class c)))
|
||||
(oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))
|
||||
|
||||
(static-method-class-method 'static-method-class-2 'class)
|
||||
(should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class))
|
||||
(static-method-class-method (static-method-class-2) 'object)
|
||||
(should (eq (oref-default 'static-method-class-2 some-slot) 'moose-object)))
|
||||
|
||||
|
||||
;;; Perform method testing
|
||||
;;
|
||||
|
||||
;;; Multiple Inheritance, and method signal testing
|
||||
;;
|
||||
(defvar eitest-ab nil)
|
||||
(defvar eitest-a nil)
|
||||
(defvar eitest-b nil)
|
||||
(ert-deftest eieio-test-06-allocate-objects ()
|
||||
;; allocate an object to use
|
||||
(should (setq eitest-ab (class-ab)))
|
||||
(should (setq eitest-a (class-a)))
|
||||
(should (setq eitest-b (class-b))))
|
||||
|
||||
(ert-deftest eieio-test-07-make-instance ()
|
||||
(should (make-instance 'class-ab))
|
||||
(should (make-instance 'class-a :water 'cho))
|
||||
(should (make-instance 'class-b)))
|
||||
|
||||
(defmethod class-cn ((a class-a))
|
||||
"Try calling `call-next-method' when there isn't one.
|
||||
Argument A is object of type symbol `class-a'."
|
||||
(call-next-method))
|
||||
|
||||
(defmethod no-next-method ((a class-a) &rest args)
|
||||
"Override signal throwing for variable `class-a'.
|
||||
Argument A is the object of class variable `class-a'."
|
||||
'moose)
|
||||
|
||||
(ert-deftest eieio-test-08-call-next-method ()
|
||||
;; Play with call-next-method
|
||||
(should (eq (class-cn eitest-ab) 'moose)))
|
||||
|
||||
(defmethod no-applicable-method ((b class-b) method &rest args)
|
||||
"No need.
|
||||
Argument B is for booger.
|
||||
METHOD is the method that was attempting to be called."
|
||||
'moose)
|
||||
|
||||
(ert-deftest eieio-test-09-no-applicable-method ()
|
||||
;; Non-existing methods.
|
||||
(should (eq (class-cn eitest-b) 'moose)))
|
||||
|
||||
(defmethod class-fun ((a class-a))
|
||||
"Fun with class A."
|
||||
'moose)
|
||||
|
||||
(defmethod class-fun ((b class-b))
|
||||
"Fun with class B."
|
||||
(error "Class B fun should not be called")
|
||||
)
|
||||
|
||||
(defmethod class-fun-foo ((b class-b))
|
||||
"Foo Fun with class B."
|
||||
'moose)
|
||||
|
||||
(defmethod class-fun2 ((a class-a))
|
||||
"More fun with class A."
|
||||
'moose)
|
||||
|
||||
(defmethod class-fun2 ((b class-b))
|
||||
"More fun with class B."
|
||||
(error "Class B fun2 should not be called")
|
||||
)
|
||||
|
||||
(defmethod class-fun2 ((ab class-ab))
|
||||
"More fun with class AB."
|
||||
(call-next-method))
|
||||
|
||||
;; How about if B is the only slot?
|
||||
(defmethod class-fun3 ((b class-b))
|
||||
"Even More fun with class B."
|
||||
'moose)
|
||||
|
||||
(defmethod class-fun3 ((ab class-ab))
|
||||
"Even More fun with class AB."
|
||||
(call-next-method))
|
||||
|
||||
(ert-deftest eieio-test-10-multiple-inheritance ()
|
||||
;; play with methods and mi
|
||||
(should (eq (class-fun eitest-ab) 'moose))
|
||||
(should (eq (class-fun-foo eitest-ab) 'moose))
|
||||
;; Play with next-method and mi
|
||||
(should (eq (class-fun2 eitest-ab) 'moose))
|
||||
(should (eq (class-fun3 eitest-ab) 'moose)))
|
||||
|
||||
(ert-deftest eieio-test-11-self ()
|
||||
;; Try the self referencing test
|
||||
(should (oset eitest-a self eitest-a))
|
||||
(should (oset eitest-ab self eitest-ab)))
|
||||
|
||||
|
||||
(defvar class-fun-value-seq '())
|
||||
(defmethod class-fun-value :BEFORE ((a class-a))
|
||||
"Return `before', and push `before' in `class-fun-value-seq'."
|
||||
(push 'before class-fun-value-seq)
|
||||
'before)
|
||||
|
||||
(defmethod class-fun-value :PRIMARY ((a class-a))
|
||||
"Return `primary', and push `primary' in `class-fun-value-seq'."
|
||||
(push 'primary class-fun-value-seq)
|
||||
'primary)
|
||||
|
||||
(defmethod class-fun-value :AFTER ((a class-a))
|
||||
"Return `after', and push `after' in `class-fun-value-seq'."
|
||||
(push 'after class-fun-value-seq)
|
||||
'after)
|
||||
|
||||
(ert-deftest eieio-test-12-generic-function-call ()
|
||||
;; Test value of a generic function call
|
||||
;;
|
||||
(let* ((class-fun-value-seq nil)
|
||||
(value (class-fun-value eitest-a)))
|
||||
;; Test if generic function call returns the primary method's value
|
||||
(should (eq value 'primary))
|
||||
;; Make sure :before and :after methods were run
|
||||
(should (equal class-fun-value-seq '(after primary before)))))
|
||||
|
||||
;;; Test initialization methods
|
||||
;;
|
||||
|
||||
(ert-deftest eieio-test-13-init-methods ()
|
||||
(defmethod initialize-instance ((a class-a) &rest slots)
|
||||
"Initialize the slots of class-a."
|
||||
(call-next-method)
|
||||
(if (/= (oref a test-tag) 1)
|
||||
(error "shared-initialize test failed."))
|
||||
(oset a test-tag 2))
|
||||
|
||||
(defmethod shared-initialize ((a class-a) &rest slots)
|
||||
"Shared initialize method for class-a."
|
||||
(call-next-method)
|
||||
(oset a test-tag 1))
|
||||
|
||||
(let ((ca (class-a)))
|
||||
(should-not (/= (oref ca test-tag) 2))))
|
||||
|
||||
|
||||
;;; Perform slot testing
|
||||
;;
|
||||
(ert-deftest eieio-test-14-slots ()
|
||||
;; Check slot existence
|
||||
(should (oref eitest-ab water))
|
||||
(should (oref eitest-ab land))
|
||||
(should (oref eitest-ab amphibian)))
|
||||
|
||||
(ert-deftest eieio-test-15-slot-missing ()
|
||||
|
||||
(defmethod slot-missing ((ab class-ab) &rest foo)
|
||||
"If a slot in AB is unbound, return something cool. FOO."
|
||||
'moose)
|
||||
|
||||
(should (eq (oref eitest-ab ooga-booga) 'moose))
|
||||
(should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name))
|
||||
|
||||
(ert-deftest eieio-test-16-slot-makeunbound ()
|
||||
(slot-makeunbound eitest-a 'water)
|
||||
;; Should now be unbound
|
||||
(should-not (slot-boundp eitest-a 'water))
|
||||
;; But should still exist
|
||||
(should (slot-exists-p eitest-a 'water))
|
||||
(should-not (slot-exists-p eitest-a 'moose))
|
||||
;; oref of unbound slot must fail
|
||||
(should-error (oref eitest-a water) :type 'unbound-slot))
|
||||
|
||||
(defvar eitest-vsca nil)
|
||||
(defvar eitest-vscb nil)
|
||||
(defclass virtual-slot-class ()
|
||||
((base-value :initarg :base-value))
|
||||
"Class has real slot :base-value and simulated slot :derived-value.")
|
||||
(defmethod slot-missing ((vsc virtual-slot-class)
|
||||
slot-name operation &optional new-value)
|
||||
"Simulate virtual slot derived-value."
|
||||
(cond
|
||||
((or (eq slot-name :derived-value)
|
||||
(eq slot-name 'derived-value))
|
||||
(with-slots (base-value) vsc
|
||||
(if (eq operation 'oref)
|
||||
(+ base-value 1)
|
||||
(setq base-value (- new-value 1)))))
|
||||
(t (call-next-method))))
|
||||
|
||||
(ert-deftest eieio-test-17-virtual-slot ()
|
||||
(setq eitest-vsca (virtual-slot-class :base-value 1))
|
||||
;; Check slot values
|
||||
(should (= (oref eitest-vsca base-value) 1))
|
||||
(should (= (oref eitest-vsca :derived-value) 2))
|
||||
|
||||
(oset eitest-vsca derived-value 3)
|
||||
(should (= (oref eitest-vsca base-value) 2))
|
||||
(should (= (oref eitest-vsca :derived-value) 3))
|
||||
|
||||
(oset eitest-vsca base-value 3)
|
||||
(should (= (oref eitest-vsca base-value) 3))
|
||||
(should (= (oref eitest-vsca :derived-value) 4))
|
||||
|
||||
;; should also be possible to initialize instance using virtual slot
|
||||
|
||||
(setq eitest-vscb (virtual-slot-class :derived-value 5))
|
||||
(should (= (oref eitest-vscb base-value) 4))
|
||||
(should (= (oref eitest-vscb :derived-value) 5)))
|
||||
|
||||
(ert-deftest eieio-test-18-slot-unbound ()
|
||||
|
||||
(defmethod slot-unbound ((a class-a) &rest foo)
|
||||
"If a slot in A is unbound, ignore FOO."
|
||||
'moose)
|
||||
|
||||
(should (eq (oref eitest-a water) 'moose))
|
||||
|
||||
;; Check if oset of unbound works
|
||||
(oset eitest-a water 'moose)
|
||||
(should (eq (oref eitest-a water) 'moose))
|
||||
|
||||
;; oref/oref-default comparison
|
||||
(should-not (eq (oref eitest-a water) (oref-default eitest-a water)))
|
||||
|
||||
;; oset-default -> oref/oref-default comparison
|
||||
(oset-default (eieio-object-class eitest-a) water 'moose)
|
||||
(should (eq (oref eitest-a water) (oref-default eitest-a water)))
|
||||
|
||||
;; After setting 'water to 'moose, make sure a new object has
|
||||
;; the right stuff.
|
||||
(oset-default (eieio-object-class eitest-a) water 'penguin)
|
||||
(should (eq (oref (class-a) water) 'penguin))
|
||||
|
||||
;; Revert the above
|
||||
(defmethod slot-unbound ((a class-a) &rest foo)
|
||||
"If a slot in A is unbound, ignore FOO."
|
||||
;; Disable the old slot-unbound so we can run this test
|
||||
;; more than once
|
||||
(call-next-method)))
|
||||
|
||||
(ert-deftest eieio-test-19-slot-type-checking ()
|
||||
;; Slot type checking
|
||||
;; We should not be able to set a string here
|
||||
(should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type)
|
||||
(should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type)
|
||||
(should-error (class-a :water "a string not a symbol") :type 'invalid-slot-type))
|
||||
|
||||
(ert-deftest eieio-test-20-class-allocated-slots ()
|
||||
;; Test out class allocated slots
|
||||
(defvar eitest-aa nil)
|
||||
(setq eitest-aa (class-a))
|
||||
|
||||
;; Make sure class slots do not track between objects
|
||||
(let ((newval 'moose))
|
||||
(oset eitest-aa classslot newval)
|
||||
(should (eq (oref eitest-a classslot) newval))
|
||||
(should (eq (oref eitest-aa classslot) newval)))
|
||||
|
||||
;; Slot should be bound
|
||||
(should (slot-boundp eitest-a 'classslot))
|
||||
(should (slot-boundp 'class-a 'classslot))
|
||||
|
||||
(slot-makeunbound eitest-a 'classslot)
|
||||
|
||||
(should-not (slot-boundp eitest-a 'classslot))
|
||||
(should-not (slot-boundp 'class-a 'classslot)))
|
||||
|
||||
|
||||
(defvar eieio-test-permuting-value nil)
|
||||
(defvar eitest-pvinit nil)
|
||||
(eval-and-compile
|
||||
(setq eieio-test-permuting-value 1))
|
||||
|
||||
(defclass inittest nil
|
||||
((staticval :initform 1)
|
||||
(symval :initform eieio-test-permuting-value)
|
||||
(evalval :initform (symbol-value 'eieio-test-permuting-value))
|
||||
(evalnow :initform (symbol-value 'eieio-test-permuting-value)
|
||||
:allocation :class)
|
||||
)
|
||||
"Test initforms that eval.")
|
||||
|
||||
(ert-deftest eieio-test-21-eval-at-construction-time ()
|
||||
;; initforms that need to be evalled at construction time.
|
||||
(setq eieio-test-permuting-value 2)
|
||||
(setq eitest-pvinit (inittest))
|
||||
|
||||
(should (eq (oref eitest-pvinit staticval) 1))
|
||||
(should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value))
|
||||
(should (eq (oref eitest-pvinit evalval) 2))
|
||||
(should (eq (oref eitest-pvinit evalnow) 1)))
|
||||
|
||||
(defvar eitest-tests nil)
|
||||
|
||||
(ert-deftest eieio-test-22-init-forms-dont-match-runnable ()
|
||||
;; Init forms with types that don't match the runnable.
|
||||
(defclass eitest-subordinate nil
|
||||
((text :initform "" :type string))
|
||||
"Test class that will be a calculated value.")
|
||||
|
||||
(defclass eitest-superior nil
|
||||
((sub :initform (eitest-subordinate)
|
||||
:type eitest-subordinate))
|
||||
"A class with an initform that creates a class.")
|
||||
|
||||
(should (setq eitest-tests (eitest-superior)))
|
||||
|
||||
(should-error
|
||||
(eval
|
||||
'(defclass broken-init nil
|
||||
((broken :initform 1
|
||||
:type string))
|
||||
"This class should break."))
|
||||
:type 'invalid-slot-type))
|
||||
|
||||
(ert-deftest eieio-test-23-inheritance-check ()
|
||||
(should (child-of-class-p 'class-ab 'class-a))
|
||||
(should (child-of-class-p 'class-ab 'class-b))
|
||||
(should (object-of-class-p eitest-a 'class-a))
|
||||
(should (object-of-class-p eitest-ab 'class-a))
|
||||
(should (object-of-class-p eitest-ab 'class-b))
|
||||
(should (object-of-class-p eitest-ab 'class-ab))
|
||||
(should (eq (eieio-class-parents 'class-a) nil))
|
||||
(should (equal (eieio-class-parents 'class-ab)
|
||||
(mapcar #'find-class '(class-a class-b))))
|
||||
(should (same-class-p eitest-a 'class-a))
|
||||
(should (class-a-p eitest-a))
|
||||
(should (not (class-a-p eitest-ab)))
|
||||
(should (cl-typep eitest-a 'class-a))
|
||||
(should (cl-typep eitest-ab 'class-a))
|
||||
(should (not (class-a-p "foo")))
|
||||
(should (not (cl-typep "foo" 'class-a))))
|
||||
|
||||
(ert-deftest eieio-test-24-object-predicates ()
|
||||
(let ((listooa (list (class-ab) (class-a)))
|
||||
(listoob (list (class-ab) (class-b))))
|
||||
(should (cl-typep listooa '(list-of class-a)))
|
||||
(should (cl-typep listoob '(list-of class-b)))
|
||||
(should-not (cl-typep listooa '(list-of class-b)))
|
||||
(should-not (cl-typep listoob '(list-of class-a)))))
|
||||
|
||||
(defvar eitest-t1 nil)
|
||||
(ert-deftest eieio-test-25-slot-tests ()
|
||||
(setq eitest-t1 (class-c))
|
||||
;; Slot initialization
|
||||
(should (eq (oref eitest-t1 slot-1) 'moose))
|
||||
;; Accessing via the initarg name is deprecated!
|
||||
;; (should (eq (oref eitest-t1 :moose) 'moose))
|
||||
;; Don't pass reference of private slot
|
||||
;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name)
|
||||
;; Check private slot accessor
|
||||
(should (string= (get-slot-2 eitest-t1) "penguin"))
|
||||
;; Pass string instead of symbol
|
||||
(should-error (class-c :moose "not a symbol") :type 'invalid-slot-type)
|
||||
(should (eq (get-slot-3 eitest-t1) 'emu))
|
||||
(should (eq (get-slot-3 'class-c) 'emu))
|
||||
;; Check setf
|
||||
(setf (get-slot-3 eitest-t1) 'setf-emu)
|
||||
(should (eq (get-slot-3 eitest-t1) 'setf-emu))
|
||||
;; Roll back
|
||||
(setf (get-slot-3 eitest-t1) 'emu))
|
||||
|
||||
(defvar eitest-t2 nil)
|
||||
(ert-deftest eieio-test-26-default-inheritance ()
|
||||
;; See previous test, nor for subclass
|
||||
(setq eitest-t2 (class-subc))
|
||||
(should (eq (oref eitest-t2 slot-1) 'moose))
|
||||
;; Accessing via the initarg name is deprecated!
|
||||
;;(should (eq (oref eitest-t2 :moose) 'moose))
|
||||
(should (string= (get-slot-2 eitest-t2) "linux"))
|
||||
;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
|
||||
(should (string= (get-slot-2 eitest-t2) "linux"))
|
||||
(should-error (class-subc :moose "not a symbol") :type 'invalid-slot-type))
|
||||
|
||||
;;(ert-deftest eieio-test-27-inherited-new-value ()
|
||||
;;; HACK ALERT: The new value of a class slot is inherited by the
|
||||
;; subclass! This is probably a bug. We should either share the slot
|
||||
;; so sets on the baseclass change the subclass, or we should inherit
|
||||
;; the original value.
|
||||
;; (should (eq (get-slot-3 eitest-t2) 'emu))
|
||||
;; (should (eq (get-slot-3 class-subc) 'emu))
|
||||
;; (setf (get-slot-3 eitest-t2) 'setf-emu)
|
||||
;; (should (eq (get-slot-3 eitest-t2) 'setf-emu)))
|
||||
|
||||
;; Slot protection
|
||||
(defclass prot-0 ()
|
||||
()
|
||||
"Protection testing baseclass.")
|
||||
|
||||
(defmethod prot0-slot-2 ((s2 prot-0))
|
||||
"Try to access slot-2 from this class which doesn't have it.
|
||||
The object S2 passed in will be of class prot-1, which does have
|
||||
the slot. This could be allowed, and currently is in EIEIO.
|
||||
Needed by the eieio persistent base class."
|
||||
(oref s2 slot-2))
|
||||
|
||||
(defclass prot-1 (prot-0)
|
||||
((slot-1 :initarg :slot-1
|
||||
:initform nil
|
||||
:protection :public)
|
||||
(slot-2 :initarg :slot-2
|
||||
:initform nil
|
||||
:protection :protected)
|
||||
(slot-3 :initarg :slot-3
|
||||
:initform nil
|
||||
:protection :private))
|
||||
"A class for testing the :protection option.")
|
||||
|
||||
(defclass prot-2 (prot-1)
|
||||
nil
|
||||
"A class for testing the :protection option.")
|
||||
|
||||
(defmethod prot1-slot-2 ((s2 prot-1))
|
||||
"Try to access slot-2 in S2."
|
||||
(oref s2 slot-2))
|
||||
|
||||
(defmethod prot1-slot-2 ((s2 prot-2))
|
||||
"Try to access slot-2 in S2."
|
||||
(oref s2 slot-2))
|
||||
|
||||
(defmethod prot1-slot-3-only ((s2 prot-1))
|
||||
"Try to access slot-3 in S2.
|
||||
Do not override for `prot-2'."
|
||||
(oref s2 slot-3))
|
||||
|
||||
(defmethod prot1-slot-3 ((s2 prot-1))
|
||||
"Try to access slot-3 in S2."
|
||||
(oref s2 slot-3))
|
||||
|
||||
(defmethod prot1-slot-3 ((s2 prot-2))
|
||||
"Try to access slot-3 in S2."
|
||||
(oref s2 slot-3))
|
||||
|
||||
(defvar eitest-p1 nil)
|
||||
(defvar eitest-p2 nil)
|
||||
(ert-deftest eieio-test-28-slot-protection ()
|
||||
(setq eitest-p1 (prot-1))
|
||||
(setq eitest-p2 (prot-2))
|
||||
;; Access public slots
|
||||
(oref eitest-p1 slot-1)
|
||||
(oref eitest-p2 slot-1)
|
||||
;; Accessing protected slot out of context used to fail, but we dropped this
|
||||
;; feature, since it was underused and no one noticed that the check was
|
||||
;; incorrect (much too loose).
|
||||
;;PROTECTED (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name)
|
||||
;; Access protected slot in method
|
||||
(prot1-slot-2 eitest-p1)
|
||||
;; Protected slot in subclass method
|
||||
(prot1-slot-2 eitest-p2)
|
||||
;; Protected slot from parent class method
|
||||
(prot0-slot-2 eitest-p1)
|
||||
;; Accessing private slot out of context used to fail, but we dropped this
|
||||
;; feature, since it was not used.
|
||||
;;PRIVATE (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name)
|
||||
;; Access private slot in method
|
||||
(prot1-slot-3 eitest-p1)
|
||||
;; Access private slot in subclass method must fail
|
||||
;;PRIVATE (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name)
|
||||
;; Access private slot by same class
|
||||
(prot1-slot-3-only eitest-p1)
|
||||
;; Access private slot by subclass in sameclass method
|
||||
(prot1-slot-3-only eitest-p2))
|
||||
|
||||
;;; eieio-instance-inheritor
|
||||
;; Test to make sure this works.
|
||||
(defclass II (eieio-instance-inheritor)
|
||||
((slot1 :initform 1)
|
||||
(slot2)
|
||||
(slot3))
|
||||
"Instance Inheritor test class.")
|
||||
|
||||
(defvar eitest-II1 nil)
|
||||
(defvar eitest-II2 nil)
|
||||
(defvar eitest-II3 nil)
|
||||
(ert-deftest eieio-test-29-instance-inheritor ()
|
||||
(setq eitest-II1 (II "II Test."))
|
||||
(oset eitest-II1 slot2 'cat)
|
||||
(setq eitest-II2 (clone eitest-II1 "eitest-II2 Test."))
|
||||
(oset eitest-II2 slot1 'moose)
|
||||
(setq eitest-II3 (clone eitest-II2 "eitest-II3 Test."))
|
||||
(oset eitest-II3 slot3 'penguin)
|
||||
|
||||
;; Test level 1 inheritance
|
||||
(should (eq (oref eitest-II3 slot1) 'moose))
|
||||
;; Test level 2 inheritance
|
||||
(should (eq (oref eitest-II3 slot2) 'cat))
|
||||
;; Test level 0 inheritance
|
||||
(should (eq (oref eitest-II3 slot3) 'penguin)))
|
||||
|
||||
(defclass slotattr-base ()
|
||||
((initform :initform init)
|
||||
(type :type list)
|
||||
(initarg :initarg :initarg)
|
||||
(protection :protection :private)
|
||||
(custom :custom (repeat string)
|
||||
:label "Custom Strings"
|
||||
:group moose)
|
||||
(docstring :documentation
|
||||
"Replace the doc-string for this property.")
|
||||
(printer :printer printer1)
|
||||
)
|
||||
"Baseclass we will attempt to subclass.
|
||||
Subclasses to override slot attributes.")
|
||||
|
||||
(defclass slotattr-ok (slotattr-base)
|
||||
((initform :initform no-init)
|
||||
(initarg :initarg :initblarg)
|
||||
(custom :custom string
|
||||
:label "One String"
|
||||
:group cow)
|
||||
(docstring :documentation
|
||||
"A better doc string for this class.")
|
||||
(printer :printer printer2)
|
||||
)
|
||||
"This class should allow overriding of various slot attributes.")
|
||||
|
||||
|
||||
(ert-deftest eieio-test-30-slot-attribute-override ()
|
||||
;; Subclass should not override :protection slot attribute
|
||||
;;PROTECTION is gone.
|
||||
;;(should-error
|
||||
;; (eval
|
||||
;; '(defclass slotattr-fail (slotattr-base)
|
||||
;; ((protection :protection :public)
|
||||
;; )
|
||||
;; "This class should throw an error.")))
|
||||
|
||||
;; Subclass should not override :type slot attribute
|
||||
(should-error
|
||||
(eval
|
||||
'(defclass slotattr-fail (slotattr-base)
|
||||
((type :type string)
|
||||
)
|
||||
"This class should throw an error.")))
|
||||
|
||||
;; Initform should override instance allocation
|
||||
(let ((obj (slotattr-ok)))
|
||||
(should (eq (oref obj initform) 'no-init))))
|
||||
|
||||
(defclass slotattr-class-base ()
|
||||
((initform :allocation :class
|
||||
:initform init)
|
||||
(type :allocation :class
|
||||
:type list)
|
||||
(initarg :allocation :class
|
||||
:initarg :initarg)
|
||||
(protection :allocation :class
|
||||
:protection :private)
|
||||
(custom :allocation :class
|
||||
:custom (repeat string)
|
||||
:label "Custom Strings"
|
||||
:group moose)
|
||||
(docstring :allocation :class
|
||||
:documentation
|
||||
"Replace the doc-string for this property.")
|
||||
)
|
||||
"Baseclass we will attempt to subclass.
|
||||
Subclasses to override slot attributes.")
|
||||
|
||||
(defclass slotattr-class-ok (slotattr-class-base)
|
||||
((initform :initform no-init)
|
||||
(initarg :initarg :initblarg)
|
||||
(custom :custom string
|
||||
:label "One String"
|
||||
:group cow)
|
||||
(docstring :documentation
|
||||
"A better doc string for this class.")
|
||||
)
|
||||
"This class should allow overriding of various slot attributes.")
|
||||
|
||||
|
||||
(ert-deftest eieio-test-31-slot-attribute-override-class-allocation ()
|
||||
;; Same as test-30, but with class allocation
|
||||
;;PROTECTION is gone.
|
||||
;;(should-error
|
||||
;; (eval
|
||||
;; '(defclass slotattr-fail (slotattr-class-base)
|
||||
;; ((protection :protection :public)
|
||||
;; )
|
||||
;; "This class should throw an error.")))
|
||||
(should-error
|
||||
(eval
|
||||
'(defclass slotattr-fail (slotattr-class-base)
|
||||
((type :type string)
|
||||
)
|
||||
"This class should throw an error.")))
|
||||
(should (eq (oref-default 'slotattr-class-ok initform) 'no-init)))
|
||||
|
||||
(ert-deftest eieio-test-32-slot-attribute-override-2 ()
|
||||
(let* ((cv (cl--find-class 'slotattr-ok))
|
||||
(slots (eieio--class-slots cv))
|
||||
(args (eieio--class-initarg-tuples cv)))
|
||||
;; :initarg should override for subclass
|
||||
(should (assoc :initblarg args))
|
||||
|
||||
(dotimes (i (length slots))
|
||||
(let* ((slot (aref slots i))
|
||||
(props (cl--slot-descriptor-props slot)))
|
||||
(cond
|
||||
((eq (cl--slot-descriptor-name slot) 'custom)
|
||||
;; Custom slot attributes must override
|
||||
(should (eq (alist-get :custom props) 'string))
|
||||
;; Custom label slot attribute must override
|
||||
(should (string= (alist-get :label props) "One String"))
|
||||
(let ((grp (alist-get :group props)))
|
||||
;; Custom group slot attribute must combine
|
||||
(should (and (memq 'moose grp) (memq 'cow grp)))))
|
||||
(t nil))))))
|
||||
|
||||
(defvar eitest-CLONETEST1 nil)
|
||||
(defvar eitest-CLONETEST2 nil)
|
||||
|
||||
(ert-deftest eieio-test-32-test-clone-boring-objects ()
|
||||
;; A simple make instance with EIEIO extension
|
||||
(should (setq eitest-CLONETEST1 (make-instance 'class-a)))
|
||||
(should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))
|
||||
|
||||
;; CLOS form of make-instance
|
||||
(should (setq eitest-CLONETEST1 (make-instance 'class-a)))
|
||||
(should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1))))
|
||||
|
||||
(defclass IT (eieio-instance-tracker)
|
||||
((tracking-symbol :initform IT-list)
|
||||
(slot1 :initform 'die))
|
||||
"Instance Tracker test object.")
|
||||
|
||||
(ert-deftest eieio-test-33-instance-tracker ()
|
||||
(let (IT-list IT1)
|
||||
(should (setq IT1 (IT)))
|
||||
;; The instance tracker must find this
|
||||
(should (eieio-instance-tracker-find 'die 'slot1 'IT-list))
|
||||
;; Test deletion
|
||||
(delete-instance IT1)
|
||||
(should-not (eieio-instance-tracker-find 'die 'slot1 'IT-list))))
|
||||
|
||||
(defclass SINGLE (eieio-singleton)
|
||||
((a-slot :initarg :a-slot :initform t))
|
||||
"A Singleton test object.")
|
||||
|
||||
(ert-deftest eieio-test-34-singletons ()
|
||||
(let ((obj1 (SINGLE))
|
||||
(obj2 (SINGLE)))
|
||||
(should (eieio-object-p obj1))
|
||||
(should (eieio-object-p obj2))
|
||||
(should (eq obj1 obj2))
|
||||
(should (oref obj1 a-slot))))
|
||||
|
||||
(defclass NAMED (eieio-named)
|
||||
((some-slot :initform nil)
|
||||
)
|
||||
"A class inheriting from eieio-named.")
|
||||
|
||||
(ert-deftest eieio-test-35-named-object ()
|
||||
(let (N)
|
||||
(should (setq N (NAMED :object-name "Foo")))
|
||||
(should (string= "Foo" (oref N object-name)))
|
||||
(should-error (oref N missing-slot) :type 'invalid-slot-name)
|
||||
(oset N object-name "NewName")
|
||||
(should (string= "NewName" (oref N object-name)))))
|
||||
|
||||
(defclass opt-test1 ()
|
||||
()
|
||||
"Abstract base class"
|
||||
:abstract t)
|
||||
|
||||
(defclass opt-test2 (opt-test1)
|
||||
()
|
||||
"Instantiable child")
|
||||
|
||||
(ert-deftest eieio-test-36-build-class-alist ()
|
||||
(should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2))
|
||||
(should (= (length (eieio-build-class-alist 'opt-test1 t)) 1)))
|
||||
|
||||
(defclass eieio--testing () ())
|
||||
|
||||
(defmethod constructor :static ((_x eieio--testing) newname &rest _args)
|
||||
(list newname 2))
|
||||
|
||||
(ert-deftest eieio-test-37-obsolete-name-in-constructor ()
|
||||
(should (equal (eieio--testing "toto") '("toto" 2))))
|
||||
|
||||
(provide 'eieio-tests)
|
||||
|
||||
;;; eieio-tests.el ends here
|
||||
843
test/lisp/emacs-lisp/ert-tests.el
Normal file
843
test/lisp/emacs-lisp/ert-tests.el
Normal file
|
|
@ -0,0 +1,843 @@
|
|||
;;; ert-tests.el --- ERT's self-tests -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2007-2008, 2010-2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Christian Ohler <ohler@gnu.org>
|
||||
|
||||
;; 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 `http://www.gnu.org/licenses/'.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This file is part of ERT, the Emacs Lisp Regression Testing tool.
|
||||
;; See ert.el or the texinfo manual for more details.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ert)
|
||||
|
||||
;;; Self-test that doesn't rely on ERT, for bootstrapping.
|
||||
|
||||
;; This is used to test that bodies actually run.
|
||||
(defvar ert--test-body-was-run)
|
||||
(ert-deftest ert-test-body-runs ()
|
||||
(setq ert--test-body-was-run t))
|
||||
|
||||
(defun ert-self-test ()
|
||||
"Run ERT's self-tests and make sure they actually ran."
|
||||
(let ((window-configuration (current-window-configuration)))
|
||||
(let ((ert--test-body-was-run nil))
|
||||
;; The buffer name chosen here should not compete with the default
|
||||
;; results buffer name for completion in `switch-to-buffer'.
|
||||
(let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*")))
|
||||
(cl-assert ert--test-body-was-run)
|
||||
(if (zerop (ert-stats-completed-unexpected stats))
|
||||
;; Hide results window only when everything went well.
|
||||
(set-window-configuration window-configuration)
|
||||
(error "ERT self-test failed"))))))
|
||||
|
||||
(defun ert-self-test-and-exit ()
|
||||
"Run ERT's self-tests and exit Emacs.
|
||||
|
||||
The exit code will be zero if the tests passed, nonzero if they
|
||||
failed or if there was a problem."
|
||||
(unwind-protect
|
||||
(progn
|
||||
(ert-self-test)
|
||||
(kill-emacs 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(message "Error running tests")
|
||||
(backtrace))
|
||||
(kill-emacs 1))))
|
||||
|
||||
|
||||
;;; Further tests are defined using ERT.
|
||||
|
||||
(ert-deftest ert-test-nested-test-body-runs ()
|
||||
"Test that nested test bodies run."
|
||||
(let ((was-run nil))
|
||||
(let ((test (make-ert-test :body (lambda ()
|
||||
(setq was-run t)))))
|
||||
(cl-assert (not was-run))
|
||||
(ert-run-test test)
|
||||
(cl-assert was-run))))
|
||||
|
||||
|
||||
;;; Test that pass/fail works.
|
||||
(ert-deftest ert-test-pass ()
|
||||
(let ((test (make-ert-test :body (lambda ()))))
|
||||
(let ((result (ert-run-test test)))
|
||||
(cl-assert (ert-test-passed-p result)))))
|
||||
|
||||
(ert-deftest ert-test-fail ()
|
||||
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
|
||||
(let ((result (let ((ert-debug-on-error nil))
|
||||
(ert-run-test test))))
|
||||
(cl-assert (ert-test-failed-p result) t)
|
||||
(cl-assert (equal (ert-test-result-with-condition-condition result)
|
||||
'(ert-test-failed "failure message"))
|
||||
t))))
|
||||
|
||||
(ert-deftest ert-test-fail-debug-with-condition-case ()
|
||||
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
|
||||
(condition-case condition
|
||||
(progn
|
||||
(let ((ert-debug-on-error t))
|
||||
(ert-run-test test))
|
||||
(cl-assert nil))
|
||||
((error)
|
||||
(cl-assert (equal condition '(ert-test-failed "failure message")) t)))))
|
||||
|
||||
(ert-deftest ert-test-fail-debug-with-debugger-1 ()
|
||||
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
|
||||
(let ((debugger (lambda (&rest _args)
|
||||
(cl-assert nil))))
|
||||
(let ((ert-debug-on-error nil))
|
||||
(ert-run-test test)))))
|
||||
|
||||
(ert-deftest ert-test-fail-debug-with-debugger-2 ()
|
||||
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
|
||||
(cl-block nil
|
||||
(let ((debugger (lambda (&rest _args)
|
||||
(cl-return-from nil nil))))
|
||||
(let ((ert-debug-on-error t))
|
||||
(ert-run-test test))
|
||||
(cl-assert nil)))))
|
||||
|
||||
(ert-deftest ert-test-fail-debug-nested-with-debugger ()
|
||||
(let ((test (make-ert-test :body (lambda ()
|
||||
(let ((ert-debug-on-error t))
|
||||
(ert-fail "failure message"))))))
|
||||
(let ((debugger (lambda (&rest _args)
|
||||
(cl-assert nil nil "Assertion a"))))
|
||||
(let ((ert-debug-on-error nil))
|
||||
(ert-run-test test))))
|
||||
(let ((test (make-ert-test :body (lambda ()
|
||||
(let ((ert-debug-on-error nil))
|
||||
(ert-fail "failure message"))))))
|
||||
(cl-block nil
|
||||
(let ((debugger (lambda (&rest _args)
|
||||
(cl-return-from nil nil))))
|
||||
(let ((ert-debug-on-error t))
|
||||
(ert-run-test test))
|
||||
(cl-assert nil nil "Assertion b")))))
|
||||
|
||||
(ert-deftest ert-test-error ()
|
||||
(let ((test (make-ert-test :body (lambda () (error "Error message")))))
|
||||
(let ((result (let ((ert-debug-on-error nil))
|
||||
(ert-run-test test))))
|
||||
(cl-assert (ert-test-failed-p result) t)
|
||||
(cl-assert (equal (ert-test-result-with-condition-condition result)
|
||||
'(error "Error message"))
|
||||
t))))
|
||||
|
||||
(ert-deftest ert-test-error-debug ()
|
||||
(let ((test (make-ert-test :body (lambda () (error "Error message")))))
|
||||
(condition-case condition
|
||||
(progn
|
||||
(let ((ert-debug-on-error t))
|
||||
(ert-run-test test))
|
||||
(cl-assert nil))
|
||||
((error)
|
||||
(cl-assert (equal condition '(error "Error message")) t)))))
|
||||
|
||||
|
||||
;;; Test that `should' works.
|
||||
(ert-deftest ert-test-should ()
|
||||
(let ((test (make-ert-test :body (lambda () (should nil)))))
|
||||
(let ((result (let ((ert-debug-on-error nil))
|
||||
(ert-run-test test))))
|
||||
(cl-assert (ert-test-failed-p result) t)
|
||||
(cl-assert (equal (ert-test-result-with-condition-condition result)
|
||||
'(ert-test-failed ((should nil) :form nil :value nil)))
|
||||
t)))
|
||||
(let ((test (make-ert-test :body (lambda () (should t)))))
|
||||
(let ((result (ert-run-test test)))
|
||||
(cl-assert (ert-test-passed-p result) t))))
|
||||
|
||||
(ert-deftest ert-test-should-value ()
|
||||
(should (eql (should 'foo) 'foo))
|
||||
(should (eql (should 'bar) 'bar)))
|
||||
|
||||
(ert-deftest ert-test-should-not ()
|
||||
(let ((test (make-ert-test :body (lambda () (should-not t)))))
|
||||
(let ((result (let ((ert-debug-on-error nil))
|
||||
(ert-run-test test))))
|
||||
(cl-assert (ert-test-failed-p result) t)
|
||||
(cl-assert (equal (ert-test-result-with-condition-condition result)
|
||||
'(ert-test-failed ((should-not t) :form t :value t)))
|
||||
t)))
|
||||
(let ((test (make-ert-test :body (lambda () (should-not nil)))))
|
||||
(let ((result (ert-run-test test)))
|
||||
(cl-assert (ert-test-passed-p result)))))
|
||||
|
||||
|
||||
(ert-deftest ert-test-should-with-macrolet ()
|
||||
(let ((test (make-ert-test :body (lambda ()
|
||||
(cl-macrolet ((foo () `(progn t nil)))
|
||||
(should (foo)))))))
|
||||
(let ((result (let ((ert-debug-on-error nil))
|
||||
(ert-run-test test))))
|
||||
(should (ert-test-failed-p result))
|
||||
(should (equal
|
||||
(ert-test-result-with-condition-condition result)
|
||||
'(ert-test-failed ((should (foo))
|
||||
:form (progn t nil)
|
||||
:value nil)))))))
|
||||
|
||||
(ert-deftest ert-test-should-error ()
|
||||
;; No error.
|
||||
(let ((test (make-ert-test :body (lambda () (should-error (progn))))))
|
||||
(let ((result (let ((ert-debug-on-error nil))
|
||||
(ert-run-test test))))
|
||||
(should (ert-test-failed-p result))
|
||||
(should (equal (ert-test-result-with-condition-condition result)
|
||||
'(ert-test-failed
|
||||
((should-error (progn))
|
||||
:form (progn)
|
||||
:value nil
|
||||
:fail-reason "did not signal an error"))))))
|
||||
;; A simple error.
|
||||
(should (equal (should-error (error "Foo"))
|
||||
'(error "Foo")))
|
||||
;; Error of unexpected type.
|
||||
(let ((test (make-ert-test :body (lambda ()
|
||||
(should-error (error "Foo")
|
||||
:type 'singularity-error)))))
|
||||
(let ((result (ert-run-test test)))
|
||||
(should (ert-test-failed-p result))
|
||||
(should (equal
|
||||
(ert-test-result-with-condition-condition result)
|
||||
'(ert-test-failed
|
||||
((should-error (error "Foo") :type 'singularity-error)
|
||||
:form (error "Foo")
|
||||
:condition (error "Foo")
|
||||
:fail-reason
|
||||
"the error signaled did not have the expected type"))))))
|
||||
;; Error of the expected type.
|
||||
(let* ((error nil)
|
||||
(test (make-ert-test
|
||||
:body (lambda ()
|
||||
(setq error
|
||||
(should-error (signal 'singularity-error nil)
|
||||
:type 'singularity-error))))))
|
||||
(let ((result (ert-run-test test)))
|
||||
(should (ert-test-passed-p result))
|
||||
(should (equal error '(singularity-error))))))
|
||||
|
||||
(ert-deftest ert-test-should-error-subtypes ()
|
||||
(should-error (signal 'singularity-error nil)
|
||||
:type 'singularity-error
|
||||
:exclude-subtypes t)
|
||||
(let ((test (make-ert-test
|
||||
:body (lambda ()
|
||||
(should-error (signal 'arith-error nil)
|
||||
:type 'singularity-error)))))
|
||||
(let ((result (ert-run-test test)))
|
||||
(should (ert-test-failed-p result))
|
||||
(should (equal
|
||||
(ert-test-result-with-condition-condition result)
|
||||
'(ert-test-failed
|
||||
((should-error (signal 'arith-error nil)
|
||||
:type 'singularity-error)
|
||||
:form (signal arith-error nil)
|
||||
:condition (arith-error)
|
||||
:fail-reason
|
||||
"the error signaled did not have the expected type"))))))
|
||||
(let ((test (make-ert-test
|
||||
:body (lambda ()
|
||||
(should-error (signal 'arith-error nil)
|
||||
:type 'singularity-error
|
||||
:exclude-subtypes t)))))
|
||||
(let ((result (ert-run-test test)))
|
||||
(should (ert-test-failed-p result))
|
||||
(should (equal
|
||||
(ert-test-result-with-condition-condition result)
|
||||
'(ert-test-failed
|
||||
((should-error (signal 'arith-error nil)
|
||||
:type 'singularity-error
|
||||
:exclude-subtypes t)
|
||||
:form (signal arith-error nil)
|
||||
:condition (arith-error)
|
||||
:fail-reason
|
||||
"the error signaled did not have the expected type"))))))
|
||||
(let ((test (make-ert-test
|
||||
:body (lambda ()
|
||||
(should-error (signal 'singularity-error nil)
|
||||
:type 'arith-error
|
||||
:exclude-subtypes t)))))
|
||||
(let ((result (ert-run-test test)))
|
||||
(should (ert-test-failed-p result))
|
||||
(should (equal
|
||||
(ert-test-result-with-condition-condition result)
|
||||
'(ert-test-failed
|
||||
((should-error (signal 'singularity-error nil)
|
||||
:type 'arith-error
|
||||
:exclude-subtypes t)
|
||||
:form (signal singularity-error nil)
|
||||
:condition (singularity-error)
|
||||
:fail-reason
|
||||
"the error signaled was a subtype of the expected type")))))
|
||||
))
|
||||
|
||||
(ert-deftest ert-test-skip-unless ()
|
||||
;; Don't skip.
|
||||
(let ((test (make-ert-test :body (lambda () (skip-unless t)))))
|
||||
(let ((result (ert-run-test test)))
|
||||
(should (ert-test-passed-p result))))
|
||||
;; Skip.
|
||||
(let ((test (make-ert-test :body (lambda () (skip-unless nil)))))
|
||||
(let ((result (ert-run-test test)))
|
||||
(should (ert-test-skipped-p result))))
|
||||
;; Skip in case of error.
|
||||
(let ((test (make-ert-test :body (lambda () (skip-unless (error "Foo"))))))
|
||||
(let ((result (ert-run-test test)))
|
||||
(should (ert-test-skipped-p result)))))
|
||||
|
||||
(defmacro ert--test-my-list (&rest args)
|
||||
"Don't use this. Instead, call `list' with ARGS, it does the same thing.
|
||||
|
||||
This macro is used to test if macroexpansion in `should' works."
|
||||
`(list ,@args))
|
||||
|
||||
(ert-deftest ert-test-should-failure-debugging ()
|
||||
"Test that `should' errors contain the information we expect them to."
|
||||
(cl-loop
|
||||
for (body expected-condition) in
|
||||
`((,(lambda () (let ((x nil)) (should x)))
|
||||
(ert-test-failed ((should x) :form x :value nil)))
|
||||
(,(lambda () (let ((x t)) (should-not x)))
|
||||
(ert-test-failed ((should-not x) :form x :value t)))
|
||||
(,(lambda () (let ((x t)) (should (not x))))
|
||||
(ert-test-failed ((should (not x)) :form (not t) :value nil)))
|
||||
(,(lambda () (let ((x nil)) (should-not (not x))))
|
||||
(ert-test-failed ((should-not (not x)) :form (not nil) :value t)))
|
||||
(,(lambda () (let ((x t) (y nil)) (should-not
|
||||
(ert--test-my-list x y))))
|
||||
(ert-test-failed
|
||||
((should-not (ert--test-my-list x y))
|
||||
:form (list t nil)
|
||||
:value (t nil))))
|
||||
(,(lambda () (let ((_x t)) (should (error "Foo"))))
|
||||
(error "Foo")))
|
||||
do
|
||||
(let ((test (make-ert-test :body body)))
|
||||
(condition-case actual-condition
|
||||
(progn
|
||||
(let ((ert-debug-on-error t))
|
||||
(ert-run-test test))
|
||||
(cl-assert nil))
|
||||
((error)
|
||||
(should (equal actual-condition expected-condition)))))))
|
||||
|
||||
(ert-deftest ert-test-deftest ()
|
||||
;; FIXME: These tests don't look very good. What is their intent, i.e. what
|
||||
;; are they really testing? The precise generated code shouldn't matter, so
|
||||
;; we should either test the behavior of the code, or else try to express the
|
||||
;; kind of efficiency guarantees we're looking for.
|
||||
(should (equal (macroexpand '(ert-deftest abc () "foo" :tags '(bar)))
|
||||
'(progn
|
||||
(ert-set-test 'abc
|
||||
(progn
|
||||
"Constructor for objects of type `ert-test'."
|
||||
(vector 'cl-struct-ert-test 'abc "foo"
|
||||
#'(lambda nil)
|
||||
nil ':passed
|
||||
'(bar))))
|
||||
(setq current-load-list
|
||||
(cons
|
||||
'(ert-deftest . abc)
|
||||
current-load-list))
|
||||
'abc)))
|
||||
(should (equal (macroexpand '(ert-deftest def ()
|
||||
:expected-result ':passed))
|
||||
'(progn
|
||||
(ert-set-test 'def
|
||||
(progn
|
||||
"Constructor for objects of type `ert-test'."
|
||||
(vector 'cl-struct-ert-test 'def nil
|
||||
#'(lambda nil)
|
||||
nil ':passed 'nil)))
|
||||
(setq current-load-list
|
||||
(cons
|
||||
'(ert-deftest . def)
|
||||
current-load-list))
|
||||
'def)))
|
||||
;; :documentation keyword is forbidden
|
||||
(should-error (macroexpand '(ert-deftest ghi ()
|
||||
:documentation "foo"))))
|
||||
|
||||
(ert-deftest ert-test-record-backtrace ()
|
||||
(let ((test (make-ert-test :body (lambda () (ert-fail "foo")))))
|
||||
(let ((result (ert-run-test test)))
|
||||
(should (ert-test-failed-p result))
|
||||
(with-temp-buffer
|
||||
(ert--print-backtrace (ert-test-failed-backtrace result))
|
||||
(goto-char (point-min))
|
||||
(end-of-line)
|
||||
(let ((first-line (buffer-substring-no-properties (point-min) (point))))
|
||||
(should (equal first-line " (closure (ert--test-body-was-run t) nil (ert-fail \"foo\"))()")))))))
|
||||
|
||||
(ert-deftest ert-test-messages ()
|
||||
:tags '(:causes-redisplay)
|
||||
(let* ((message-string "Test message")
|
||||
(messages-buffer (get-buffer-create "*Messages*"))
|
||||
(test (make-ert-test :body (lambda () (message "%s" message-string)))))
|
||||
(with-current-buffer messages-buffer
|
||||
(let ((result (ert-run-test test)))
|
||||
(should (equal (concat message-string "\n")
|
||||
(ert-test-result-messages result)))))))
|
||||
|
||||
(ert-deftest ert-test-running-tests ()
|
||||
(let ((outer-test (ert-get-test 'ert-test-running-tests)))
|
||||
(should (equal (ert-running-test) outer-test))
|
||||
(let (test1 test2 test3)
|
||||
(setq test1 (make-ert-test
|
||||
:name "1"
|
||||
:body (lambda ()
|
||||
(should (equal (ert-running-test) outer-test))
|
||||
(should (equal ert--running-tests
|
||||
(list test1 test2 test3
|
||||
outer-test)))))
|
||||
test2 (make-ert-test
|
||||
:name "2"
|
||||
:body (lambda ()
|
||||
(should (equal (ert-running-test) outer-test))
|
||||
(should (equal ert--running-tests
|
||||
(list test3 test2 outer-test)))
|
||||
(ert-run-test test1)))
|
||||
test3 (make-ert-test
|
||||
:name "3"
|
||||
:body (lambda ()
|
||||
(should (equal (ert-running-test) outer-test))
|
||||
(should (equal ert--running-tests
|
||||
(list test3 outer-test)))
|
||||
(ert-run-test test2))))
|
||||
(should (ert-test-passed-p (ert-run-test test3))))))
|
||||
|
||||
(ert-deftest ert-test-test-result-expected-p ()
|
||||
"Test `ert-test-result-expected-p' and (implicitly) `ert-test-result-type-p'."
|
||||
;; passing test
|
||||
(let ((test (make-ert-test :body (lambda ()))))
|
||||
(should (ert-test-result-expected-p test (ert-run-test test))))
|
||||
;; unexpected failure
|
||||
(let ((test (make-ert-test :body (lambda () (ert-fail "failed")))))
|
||||
(should-not (ert-test-result-expected-p test (ert-run-test test))))
|
||||
;; expected failure
|
||||
(let ((test (make-ert-test :body (lambda () (ert-fail "failed"))
|
||||
:expected-result-type ':failed)))
|
||||
(should (ert-test-result-expected-p test (ert-run-test test))))
|
||||
;; `not' expected type
|
||||
(let ((test (make-ert-test :body (lambda ())
|
||||
:expected-result-type '(not :failed))))
|
||||
(should (ert-test-result-expected-p test (ert-run-test test))))
|
||||
(let ((test (make-ert-test :body (lambda ())
|
||||
:expected-result-type '(not :passed))))
|
||||
(should-not (ert-test-result-expected-p test (ert-run-test test))))
|
||||
;; `and' expected type
|
||||
(let ((test (make-ert-test :body (lambda ())
|
||||
:expected-result-type '(and :passed :failed))))
|
||||
(should-not (ert-test-result-expected-p test (ert-run-test test))))
|
||||
(let ((test (make-ert-test :body (lambda ())
|
||||
:expected-result-type '(and :passed
|
||||
(not :failed)))))
|
||||
(should (ert-test-result-expected-p test (ert-run-test test))))
|
||||
;; `or' expected type
|
||||
(let ((test (make-ert-test :body (lambda ())
|
||||
:expected-result-type '(or (and :passed :failed)
|
||||
:passed))))
|
||||
(should (ert-test-result-expected-p test (ert-run-test test))))
|
||||
(let ((test (make-ert-test :body (lambda ())
|
||||
:expected-result-type '(or (and :passed :failed)
|
||||
nil (not t)))))
|
||||
(should-not (ert-test-result-expected-p test (ert-run-test test)))))
|
||||
|
||||
;;; Test `ert-select-tests'.
|
||||
(ert-deftest ert-test-select-regexp ()
|
||||
(should (equal (ert-select-tests "^ert-test-select-regexp$" t)
|
||||
(list (ert-get-test 'ert-test-select-regexp)))))
|
||||
|
||||
(ert-deftest ert-test-test-boundp ()
|
||||
(should (ert-test-boundp 'ert-test-test-boundp))
|
||||
(should-not (ert-test-boundp (make-symbol "ert-not-a-test"))))
|
||||
|
||||
(ert-deftest ert-test-select-member ()
|
||||
(should (equal (ert-select-tests '(member ert-test-select-member) t)
|
||||
(list (ert-get-test 'ert-test-select-member)))))
|
||||
|
||||
(ert-deftest ert-test-select-test ()
|
||||
(should (equal (ert-select-tests (ert-get-test 'ert-test-select-test) t)
|
||||
(list (ert-get-test 'ert-test-select-test)))))
|
||||
|
||||
(ert-deftest ert-test-select-symbol ()
|
||||
(should (equal (ert-select-tests 'ert-test-select-symbol t)
|
||||
(list (ert-get-test 'ert-test-select-symbol)))))
|
||||
|
||||
(ert-deftest ert-test-select-and ()
|
||||
(let ((test (make-ert-test
|
||||
:name nil
|
||||
:body nil
|
||||
:most-recent-result (make-ert-test-failed
|
||||
:condition nil
|
||||
:backtrace nil
|
||||
:infos nil))))
|
||||
(should (equal (ert-select-tests `(and (member ,test) :failed) t)
|
||||
(list test)))))
|
||||
|
||||
(ert-deftest ert-test-select-tag ()
|
||||
(let ((test (make-ert-test
|
||||
:name nil
|
||||
:body nil
|
||||
:tags '(a b))))
|
||||
(should (equal (ert-select-tests `(tag a) (list test)) (list test)))
|
||||
(should (equal (ert-select-tests `(tag b) (list test)) (list test)))
|
||||
(should (equal (ert-select-tests `(tag c) (list test)) '()))))
|
||||
|
||||
|
||||
;;; Tests for utility functions.
|
||||
(ert-deftest ert-test-proper-list-p ()
|
||||
(should (ert--proper-list-p '()))
|
||||
(should (ert--proper-list-p '(1)))
|
||||
(should (ert--proper-list-p '(1 2)))
|
||||
(should (ert--proper-list-p '(1 2 3)))
|
||||
(should (ert--proper-list-p '(1 2 3 4)))
|
||||
(should (not (ert--proper-list-p 'a)))
|
||||
(should (not (ert--proper-list-p '(1 . a))))
|
||||
(should (not (ert--proper-list-p '(1 2 . a))))
|
||||
(should (not (ert--proper-list-p '(1 2 3 . a))))
|
||||
(should (not (ert--proper-list-p '(1 2 3 4 . a))))
|
||||
(let ((a (list 1)))
|
||||
(setf (cdr (last a)) a)
|
||||
(should (not (ert--proper-list-p a))))
|
||||
(let ((a (list 1 2)))
|
||||
(setf (cdr (last a)) a)
|
||||
(should (not (ert--proper-list-p a))))
|
||||
(let ((a (list 1 2 3)))
|
||||
(setf (cdr (last a)) a)
|
||||
(should (not (ert--proper-list-p a))))
|
||||
(let ((a (list 1 2 3 4)))
|
||||
(setf (cdr (last a)) a)
|
||||
(should (not (ert--proper-list-p a))))
|
||||
(let ((a (list 1 2)))
|
||||
(setf (cdr (last a)) (cdr a))
|
||||
(should (not (ert--proper-list-p a))))
|
||||
(let ((a (list 1 2 3)))
|
||||
(setf (cdr (last a)) (cdr a))
|
||||
(should (not (ert--proper-list-p a))))
|
||||
(let ((a (list 1 2 3 4)))
|
||||
(setf (cdr (last a)) (cdr a))
|
||||
(should (not (ert--proper-list-p a))))
|
||||
(let ((a (list 1 2 3)))
|
||||
(setf (cdr (last a)) (cddr a))
|
||||
(should (not (ert--proper-list-p a))))
|
||||
(let ((a (list 1 2 3 4)))
|
||||
(setf (cdr (last a)) (cddr a))
|
||||
(should (not (ert--proper-list-p a))))
|
||||
(let ((a (list 1 2 3 4)))
|
||||
(setf (cdr (last a)) (cl-cdddr a))
|
||||
(should (not (ert--proper-list-p a)))))
|
||||
|
||||
(ert-deftest ert-test-parse-keys-and-body ()
|
||||
(should (equal (ert--parse-keys-and-body '(foo)) '(nil (foo))))
|
||||
(should (equal (ert--parse-keys-and-body '(:bar foo)) '((:bar foo) nil)))
|
||||
(should (equal (ert--parse-keys-and-body '(:bar foo a (b)))
|
||||
'((:bar foo) (a (b)))))
|
||||
(should (equal (ert--parse-keys-and-body '(:bar foo :a (b)))
|
||||
'((:bar foo :a (b)) nil)))
|
||||
(should (equal (ert--parse-keys-and-body '(bar foo :a (b)))
|
||||
'(nil (bar foo :a (b)))))
|
||||
(should-error (ert--parse-keys-and-body '(:bar foo :a))))
|
||||
|
||||
|
||||
(ert-deftest ert-test-run-tests-interactively ()
|
||||
:tags '(:causes-redisplay)
|
||||
(let ((passing-test (make-ert-test :name 'passing-test
|
||||
:body (lambda () (ert-pass))))
|
||||
(failing-test (make-ert-test :name 'failing-test
|
||||
:body (lambda () (ert-fail
|
||||
"failure message"))))
|
||||
(skipped-test (make-ert-test :name 'skipped-test
|
||||
:body (lambda () (ert-skip
|
||||
"skip message")))))
|
||||
(let ((ert-debug-on-error nil))
|
||||
(let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*"))
|
||||
(messages nil)
|
||||
(mock-message-fn
|
||||
(lambda (format-string &rest args)
|
||||
(push (apply #'format format-string args) messages))))
|
||||
(save-window-excursion
|
||||
(unwind-protect
|
||||
(let ((case-fold-search nil))
|
||||
(ert-run-tests-interactively
|
||||
`(member ,passing-test ,failing-test, skipped-test) buffer-name
|
||||
mock-message-fn)
|
||||
(should (equal messages `(,(concat
|
||||
"Ran 3 tests, 1 results were "
|
||||
"as expected, 1 unexpected, "
|
||||
"1 skipped"))))
|
||||
(with-current-buffer buffer-name
|
||||
(goto-char (point-min))
|
||||
(should (equal
|
||||
(buffer-substring (point-min)
|
||||
(save-excursion
|
||||
(forward-line 5)
|
||||
(point)))
|
||||
(concat
|
||||
"Selector: (member <passing-test> <failing-test> "
|
||||
"<skipped-test>)\n"
|
||||
"Passed: 1\n"
|
||||
"Failed: 1 (1 unexpected)\n"
|
||||
"Skipped: 1\n"
|
||||
"Total: 3/3\n")))))
|
||||
(when (get-buffer buffer-name)
|
||||
(kill-buffer buffer-name))))))))
|
||||
|
||||
(ert-deftest ert-test-special-operator-p ()
|
||||
(should (ert--special-operator-p 'if))
|
||||
(should-not (ert--special-operator-p 'car))
|
||||
(should-not (ert--special-operator-p 'ert--special-operator-p))
|
||||
(let ((b (cl-gensym)))
|
||||
(should-not (ert--special-operator-p b))
|
||||
(fset b 'if)
|
||||
(should (ert--special-operator-p b))))
|
||||
|
||||
(ert-deftest ert-test-list-of-should-forms ()
|
||||
(let ((test (make-ert-test :body (lambda ()
|
||||
(should t)
|
||||
(should (null '()))
|
||||
(should nil)
|
||||
(should t)))))
|
||||
(let ((result (let ((ert-debug-on-error nil))
|
||||
(ert-run-test test))))
|
||||
(should (equal (ert-test-result-should-forms result)
|
||||
'(((should t) :form t :value t)
|
||||
((should (null '())) :form (null nil) :value t)
|
||||
((should nil) :form nil :value nil)))))))
|
||||
|
||||
(ert-deftest ert-test-list-of-should-forms-observers-should-not-stack ()
|
||||
(let ((test (make-ert-test
|
||||
:body (lambda ()
|
||||
(let ((test2 (make-ert-test
|
||||
:body (lambda ()
|
||||
(should t)))))
|
||||
(let ((result (ert-run-test test2)))
|
||||
(should (ert-test-passed-p result))))))))
|
||||
(let ((result (let ((ert-debug-on-error nil))
|
||||
(ert-run-test test))))
|
||||
(should (ert-test-passed-p result))
|
||||
(should (eql (length (ert-test-result-should-forms result))
|
||||
1)))))
|
||||
|
||||
(ert-deftest ert-test-list-of-should-forms-no-deep-copy ()
|
||||
(let ((test (make-ert-test :body (lambda ()
|
||||
(let ((obj (list 'a)))
|
||||
(should (equal obj '(a)))
|
||||
(setf (car obj) 'b)
|
||||
(should (equal obj '(b))))))))
|
||||
(let ((result (let ((ert-debug-on-error nil))
|
||||
(ert-run-test test))))
|
||||
(should (ert-test-passed-p result))
|
||||
(should (equal (ert-test-result-should-forms result)
|
||||
'(((should (equal obj '(a))) :form (equal (b) (a)) :value t
|
||||
:explanation nil)
|
||||
((should (equal obj '(b))) :form (equal (b) (b)) :value t
|
||||
:explanation nil)
|
||||
))))))
|
||||
|
||||
(ert-deftest ert-test-string-first-line ()
|
||||
(should (equal (ert--string-first-line "") ""))
|
||||
(should (equal (ert--string-first-line "abc") "abc"))
|
||||
(should (equal (ert--string-first-line "abc\n") "abc"))
|
||||
(should (equal (ert--string-first-line "foo\nbar") "foo"))
|
||||
(should (equal (ert--string-first-line " foo\nbar\nbaz\n") " foo")))
|
||||
|
||||
(ert-deftest ert-test-explain-equal ()
|
||||
(should (equal (ert--explain-equal nil 'foo)
|
||||
'(different-atoms nil foo)))
|
||||
(should (equal (ert--explain-equal '(a a) '(a b))
|
||||
'(list-elt 1 (different-atoms a b))))
|
||||
(should (equal (ert--explain-equal '(1 48) '(1 49))
|
||||
'(list-elt 1 (different-atoms (48 "#x30" "?0")
|
||||
(49 "#x31" "?1")))))
|
||||
(should (equal (ert--explain-equal 'nil '(a))
|
||||
'(different-types nil (a))))
|
||||
(should (equal (ert--explain-equal '(a b c) '(a b c d))
|
||||
'(proper-lists-of-different-length 3 4 (a b c) (a b c d)
|
||||
first-mismatch-at 3)))
|
||||
(let ((sym (make-symbol "a")))
|
||||
(should (equal (ert--explain-equal 'a sym)
|
||||
`(different-symbols-with-the-same-name a ,sym)))))
|
||||
|
||||
(ert-deftest ert-test-explain-equal-improper-list ()
|
||||
(should (equal (ert--explain-equal '(a . b) '(a . c))
|
||||
'(cdr (different-atoms b c)))))
|
||||
|
||||
(ert-deftest ert-test-explain-equal-keymaps ()
|
||||
;; This used to be very slow.
|
||||
(should (equal (make-keymap) (make-keymap)))
|
||||
(should (equal (make-sparse-keymap) (make-sparse-keymap))))
|
||||
|
||||
(ert-deftest ert-test-significant-plist-keys ()
|
||||
(should (equal (ert--significant-plist-keys '()) '()))
|
||||
(should (equal (ert--significant-plist-keys '(a b c d e f c g p q r nil s t))
|
||||
'(a c e p s))))
|
||||
|
||||
(ert-deftest ert-test-plist-difference-explanation ()
|
||||
(should (equal (ert--plist-difference-explanation
|
||||
'(a b c nil) '(a b))
|
||||
nil))
|
||||
(should (equal (ert--plist-difference-explanation
|
||||
'(a b c t) '(a b))
|
||||
'(different-properties-for-key c (different-atoms t nil))))
|
||||
(should (equal (ert--plist-difference-explanation
|
||||
'(a b c t) '(c nil a b))
|
||||
'(different-properties-for-key c (different-atoms t nil))))
|
||||
(should (equal (ert--plist-difference-explanation
|
||||
'(a b c (foo . bar)) '(c (foo . baz) a b))
|
||||
'(different-properties-for-key c
|
||||
(cdr
|
||||
(different-atoms bar baz))))))
|
||||
|
||||
(ert-deftest ert-test-abbreviate-string ()
|
||||
(should (equal (ert--abbreviate-string "foo" 4 nil) "foo"))
|
||||
(should (equal (ert--abbreviate-string "foo" 3 nil) "foo"))
|
||||
(should (equal (ert--abbreviate-string "foo" 3 nil) "foo"))
|
||||
(should (equal (ert--abbreviate-string "foo" 2 nil) "fo"))
|
||||
(should (equal (ert--abbreviate-string "foo" 1 nil) "f"))
|
||||
(should (equal (ert--abbreviate-string "foo" 0 nil) ""))
|
||||
(should (equal (ert--abbreviate-string "bar" 4 t) "bar"))
|
||||
(should (equal (ert--abbreviate-string "bar" 3 t) "bar"))
|
||||
(should (equal (ert--abbreviate-string "bar" 3 t) "bar"))
|
||||
(should (equal (ert--abbreviate-string "bar" 2 t) "ar"))
|
||||
(should (equal (ert--abbreviate-string "bar" 1 t) "r"))
|
||||
(should (equal (ert--abbreviate-string "bar" 0 t) "")))
|
||||
|
||||
(ert-deftest ert-test-explain-equal-string-properties ()
|
||||
(should
|
||||
(equal (ert--explain-equal-including-properties #("foo" 0 1 (a b))
|
||||
"foo")
|
||||
'(char 0 "f"
|
||||
(different-properties-for-key a (different-atoms b nil))
|
||||
context-before ""
|
||||
context-after "oo")))
|
||||
(should (equal (ert--explain-equal-including-properties
|
||||
#("foo" 1 3 (a b))
|
||||
#("goo" 0 1 (c d)))
|
||||
'(array-elt 0 (different-atoms (?f "#x66" "?f")
|
||||
(?g "#x67" "?g")))))
|
||||
(should
|
||||
(equal (ert--explain-equal-including-properties
|
||||
#("foo" 0 1 (a b c d) 1 3 (a b))
|
||||
#("foo" 0 1 (c d a b) 1 2 (a foo)))
|
||||
'(char 1 "o" (different-properties-for-key a (different-atoms b foo))
|
||||
context-before "f" context-after "o"))))
|
||||
|
||||
(ert-deftest ert-test-equal-including-properties ()
|
||||
(should (equal-including-properties "foo" "foo"))
|
||||
(should (ert-equal-including-properties "foo" "foo"))
|
||||
|
||||
(should (equal-including-properties #("foo" 0 3 (a b))
|
||||
(propertize "foo" 'a 'b)))
|
||||
(should (ert-equal-including-properties #("foo" 0 3 (a b))
|
||||
(propertize "foo" 'a 'b)))
|
||||
|
||||
(should (equal-including-properties #("foo" 0 3 (a b c d))
|
||||
(propertize "foo" 'a 'b 'c 'd)))
|
||||
(should (ert-equal-including-properties #("foo" 0 3 (a b c d))
|
||||
(propertize "foo" 'a 'b 'c 'd)))
|
||||
|
||||
(should-not (equal-including-properties #("foo" 0 3 (a b c e))
|
||||
(propertize "foo" 'a 'b 'c 'd)))
|
||||
(should-not (ert-equal-including-properties #("foo" 0 3 (a b c e))
|
||||
(propertize "foo" 'a 'b 'c 'd)))
|
||||
|
||||
;; This is bug 6581.
|
||||
(should-not (equal-including-properties #("foo" 0 3 (a (t)))
|
||||
(propertize "foo" 'a (list t))))
|
||||
(should (ert-equal-including-properties #("foo" 0 3 (a (t)))
|
||||
(propertize "foo" 'a (list t)))))
|
||||
|
||||
(ert-deftest ert-test-stats-set-test-and-result ()
|
||||
(let* ((test-1 (make-ert-test :name 'test-1
|
||||
:body (lambda () nil)))
|
||||
(test-2 (make-ert-test :name 'test-2
|
||||
:body (lambda () nil)))
|
||||
(test-3 (make-ert-test :name 'test-2
|
||||
:body (lambda () nil)))
|
||||
(stats (ert--make-stats (list test-1 test-2) 't))
|
||||
(failed (make-ert-test-failed :condition nil
|
||||
:backtrace nil
|
||||
:infos nil))
|
||||
(skipped (make-ert-test-skipped :condition nil
|
||||
:backtrace nil
|
||||
:infos nil)))
|
||||
(should (eql 2 (ert-stats-total stats)))
|
||||
(should (eql 0 (ert-stats-completed stats)))
|
||||
(should (eql 0 (ert-stats-completed-expected stats)))
|
||||
(should (eql 0 (ert-stats-completed-unexpected stats)))
|
||||
(should (eql 0 (ert-stats-skipped stats)))
|
||||
(ert--stats-set-test-and-result stats 0 test-1 (make-ert-test-passed))
|
||||
(should (eql 2 (ert-stats-total stats)))
|
||||
(should (eql 1 (ert-stats-completed stats)))
|
||||
(should (eql 1 (ert-stats-completed-expected stats)))
|
||||
(should (eql 0 (ert-stats-completed-unexpected stats)))
|
||||
(should (eql 0 (ert-stats-skipped stats)))
|
||||
(ert--stats-set-test-and-result stats 0 test-1 failed)
|
||||
(should (eql 2 (ert-stats-total stats)))
|
||||
(should (eql 1 (ert-stats-completed stats)))
|
||||
(should (eql 0 (ert-stats-completed-expected stats)))
|
||||
(should (eql 1 (ert-stats-completed-unexpected stats)))
|
||||
(should (eql 0 (ert-stats-skipped stats)))
|
||||
(ert--stats-set-test-and-result stats 0 test-1 nil)
|
||||
(should (eql 2 (ert-stats-total stats)))
|
||||
(should (eql 0 (ert-stats-completed stats)))
|
||||
(should (eql 0 (ert-stats-completed-expected stats)))
|
||||
(should (eql 0 (ert-stats-completed-unexpected stats)))
|
||||
(should (eql 0 (ert-stats-skipped stats)))
|
||||
(ert--stats-set-test-and-result stats 0 test-3 failed)
|
||||
(should (eql 2 (ert-stats-total stats)))
|
||||
(should (eql 1 (ert-stats-completed stats)))
|
||||
(should (eql 0 (ert-stats-completed-expected stats)))
|
||||
(should (eql 1 (ert-stats-completed-unexpected stats)))
|
||||
(should (eql 0 (ert-stats-skipped stats)))
|
||||
(ert--stats-set-test-and-result stats 1 test-2 (make-ert-test-passed))
|
||||
(should (eql 2 (ert-stats-total stats)))
|
||||
(should (eql 2 (ert-stats-completed stats)))
|
||||
(should (eql 1 (ert-stats-completed-expected stats)))
|
||||
(should (eql 1 (ert-stats-completed-unexpected stats)))
|
||||
(should (eql 0 (ert-stats-skipped stats)))
|
||||
(ert--stats-set-test-and-result stats 0 test-1 (make-ert-test-passed))
|
||||
(should (eql 2 (ert-stats-total stats)))
|
||||
(should (eql 2 (ert-stats-completed stats)))
|
||||
(should (eql 2 (ert-stats-completed-expected stats)))
|
||||
(should (eql 0 (ert-stats-completed-unexpected stats)))
|
||||
(should (eql 0 (ert-stats-skipped stats)))
|
||||
(ert--stats-set-test-and-result stats 0 test-1 skipped)
|
||||
(should (eql 2 (ert-stats-total stats)))
|
||||
(should (eql 2 (ert-stats-completed stats)))
|
||||
(should (eql 1 (ert-stats-completed-expected stats)))
|
||||
(should (eql 0 (ert-stats-completed-unexpected stats)))
|
||||
(should (eql 1 (ert-stats-skipped stats)))))
|
||||
|
||||
|
||||
(provide 'ert-tests)
|
||||
|
||||
;;; ert-tests.el ends here
|
||||
|
||||
;; Local Variables:
|
||||
;; no-byte-compile: t
|
||||
;; End:
|
||||
280
test/lisp/emacs-lisp/ert-x-tests.el
Normal file
280
test/lisp/emacs-lisp/ert-x-tests.el
Normal file
|
|
@ -0,0 +1,280 @@
|
|||
;;; ert-x-tests.el --- Tests for ert-x.el
|
||||
|
||||
;; Copyright (C) 2008, 2010-2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Phil Hagelberg
|
||||
;; Christian Ohler <ohler@gnu.org>
|
||||
|
||||
;; 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 `http://www.gnu.org/licenses/'.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This file is part of ERT, the Emacs Lisp Regression Testing tool.
|
||||
;; See ert.el or the texinfo manual for more details.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile
|
||||
(require 'cl-lib))
|
||||
(require 'ert)
|
||||
(require 'ert-x)
|
||||
|
||||
;;; Utilities
|
||||
|
||||
(ert-deftest ert-test-buffer-string-reindented ()
|
||||
(ert-with-test-buffer (:name "well-indented")
|
||||
(insert (concat "(hello (world\n"
|
||||
" 'elisp)\n"))
|
||||
(emacs-lisp-mode)
|
||||
(should (equal (ert-buffer-string-reindented) (buffer-string))))
|
||||
(ert-with-test-buffer (:name "badly-indented")
|
||||
(insert (concat "(hello\n"
|
||||
" world)"))
|
||||
(emacs-lisp-mode)
|
||||
(should-not (equal (ert-buffer-string-reindented) (buffer-string)))))
|
||||
|
||||
(defun ert--hash-table-to-alist (table)
|
||||
(let ((accu nil))
|
||||
(maphash (lambda (key value)
|
||||
(push (cons key value) accu))
|
||||
table)
|
||||
(nreverse accu)))
|
||||
|
||||
(ert-deftest ert-test-test-buffers ()
|
||||
(let (buffer-1
|
||||
buffer-2)
|
||||
(let ((test-1
|
||||
(make-ert-test
|
||||
:name 'test-1
|
||||
:body (lambda ()
|
||||
(ert-with-test-buffer (:name "foo")
|
||||
(should (string-match
|
||||
"[*]Test buffer (ert-test-test-buffers): foo[*]"
|
||||
(buffer-name)))
|
||||
(setq buffer-1 (current-buffer))))))
|
||||
(test-2
|
||||
(make-ert-test
|
||||
:name 'test-2
|
||||
:body (lambda ()
|
||||
(ert-with-test-buffer (:name "bar")
|
||||
(should (string-match
|
||||
"[*]Test buffer (ert-test-test-buffers): bar[*]"
|
||||
(buffer-name)))
|
||||
(setq buffer-2 (current-buffer))
|
||||
(ert-fail "fail for test"))))))
|
||||
(let ((ert--test-buffers (make-hash-table :weakness t)))
|
||||
(ert-run-tests `(member ,test-1 ,test-2) #'ignore)
|
||||
(should (equal (ert--hash-table-to-alist ert--test-buffers)
|
||||
`((,buffer-2 . t))))
|
||||
(should-not (buffer-live-p buffer-1))
|
||||
(should (buffer-live-p buffer-2))))))
|
||||
|
||||
|
||||
(ert-deftest ert-filter-string ()
|
||||
(should (equal (ert-filter-string "foo bar baz" "quux")
|
||||
"foo bar baz"))
|
||||
(should (equal (ert-filter-string "foo bar baz" "bar")
|
||||
"foo baz")))
|
||||
|
||||
(ert-deftest ert-propertized-string ()
|
||||
(should (ert-equal-including-properties
|
||||
(ert-propertized-string "a" '(a b) "b" '(c t) "cd")
|
||||
#("abcd" 1 2 (a b) 2 4 (c t))))
|
||||
(should (ert-equal-including-properties
|
||||
(ert-propertized-string "foo " '(face italic) "bar" " baz" nil
|
||||
" quux")
|
||||
#("foo bar baz quux" 4 11 (face italic)))))
|
||||
|
||||
|
||||
;;; Tests for ERT itself that require test features from ert-x.el.
|
||||
|
||||
(ert-deftest ert-test-run-tests-interactively-2 ()
|
||||
:tags '(:causes-redisplay)
|
||||
(let* ((passing-test (make-ert-test :name 'passing-test
|
||||
:body (lambda () (ert-pass))))
|
||||
(failing-test (make-ert-test :name 'failing-test
|
||||
:body (lambda ()
|
||||
(ert-info ((propertize "foo\nbar"
|
||||
'a 'b))
|
||||
(ert-fail
|
||||
"failure message")))))
|
||||
(skipped-test (make-ert-test :name 'skipped-test
|
||||
:body (lambda () (ert-skip
|
||||
"skip message"))))
|
||||
(ert-debug-on-error nil)
|
||||
(buffer-name (generate-new-buffer-name "*ert-test-run-tests*"))
|
||||
(messages nil)
|
||||
(mock-message-fn
|
||||
(lambda (format-string &rest args)
|
||||
(push (apply #'format format-string args) messages))))
|
||||
(cl-flet ((expected-string (with-font-lock-p)
|
||||
(ert-propertized-string
|
||||
"Selector: (member <passing-test> <failing-test> "
|
||||
"<skipped-test>)\n"
|
||||
"Passed: 1\n"
|
||||
"Failed: 1 (1 unexpected)\n"
|
||||
"Skipped: 1\n"
|
||||
"Total: 3/3\n\n"
|
||||
"Started at:\n"
|
||||
"Finished.\n"
|
||||
"Finished at:\n\n"
|
||||
`(category ,(button-category-symbol
|
||||
'ert--results-progress-bar-button)
|
||||
button (t)
|
||||
face ,(if with-font-lock-p
|
||||
'ert-test-result-unexpected
|
||||
'button))
|
||||
".Fs" nil "\n\n"
|
||||
`(category ,(button-category-symbol
|
||||
'ert--results-expand-collapse-button)
|
||||
button (t)
|
||||
face ,(if with-font-lock-p
|
||||
'ert-test-result-unexpected
|
||||
'button))
|
||||
"F" nil " "
|
||||
`(category ,(button-category-symbol
|
||||
'ert--test-name-button)
|
||||
button (t)
|
||||
ert-test-name failing-test)
|
||||
"failing-test"
|
||||
nil "\n Info: " '(a b) "foo\n"
|
||||
nil " " '(a b) "bar"
|
||||
nil "\n (ert-test-failed \"failure message\")\n\n\n"
|
||||
)))
|
||||
(save-window-excursion
|
||||
(unwind-protect
|
||||
(let ((case-fold-search nil))
|
||||
(ert-run-tests-interactively
|
||||
`(member ,passing-test ,failing-test ,skipped-test) buffer-name
|
||||
mock-message-fn)
|
||||
(should (equal messages `(,(concat
|
||||
"Ran 3 tests, 1 results were "
|
||||
"as expected, 1 unexpected, "
|
||||
"1 skipped"))))
|
||||
(with-current-buffer buffer-name
|
||||
(font-lock-mode 0)
|
||||
(should (ert-equal-including-properties
|
||||
(ert-filter-string (buffer-string)
|
||||
'("Started at:\\(.*\\)$" 1)
|
||||
'("Finished at:\\(.*\\)$" 1))
|
||||
(expected-string nil)))
|
||||
;; `font-lock-mode' only works if interactive, so
|
||||
;; pretend we are.
|
||||
(let ((noninteractive nil))
|
||||
(font-lock-mode 1))
|
||||
(should (ert-equal-including-properties
|
||||
(ert-filter-string (buffer-string)
|
||||
'("Started at:\\(.*\\)$" 1)
|
||||
'("Finished at:\\(.*\\)$" 1))
|
||||
(expected-string t)))))
|
||||
(when (get-buffer buffer-name)
|
||||
(kill-buffer buffer-name)))))))
|
||||
|
||||
(ert-deftest ert-test-describe-test ()
|
||||
"Tests `ert-describe-test'."
|
||||
(save-window-excursion
|
||||
(ert-with-buffer-renamed ("*Help*")
|
||||
(if (< emacs-major-version 24)
|
||||
(should (equal (should-error (ert-describe-test 'ert-describe-test))
|
||||
'(error "Requires Emacs 24")))
|
||||
(ert-describe-test 'ert-test-describe-test)
|
||||
(with-current-buffer "*Help*"
|
||||
(let ((case-fold-search nil))
|
||||
(should (string-match (concat
|
||||
"\\`ert-test-describe-test is a test"
|
||||
" defined in"
|
||||
" ['`‘]ert-x-tests.elc?['’]\\.\n\n"
|
||||
"Tests ['`‘]ert-describe-test['’]\\.\n\\'")
|
||||
(buffer-string)))))))))
|
||||
|
||||
(ert-deftest ert-test-message-log-truncation ()
|
||||
:tags '(:causes-redisplay)
|
||||
(let ((test (make-ert-test
|
||||
:body (lambda ()
|
||||
;; Emacs would combine messages if we
|
||||
;; generate the same message multiple
|
||||
;; times.
|
||||
(message "a")
|
||||
(message "b")
|
||||
(message "c")
|
||||
(message "d")))))
|
||||
(let (result)
|
||||
(ert-with-buffer-renamed ("*Messages*")
|
||||
(let ((message-log-max 2))
|
||||
(setq result (ert-run-test test)))
|
||||
(should (equal (with-current-buffer "*Messages*"
|
||||
(buffer-string))
|
||||
"c\nd\n")))
|
||||
(should (equal (ert-test-result-messages result) "a\nb\nc\nd\n")))))
|
||||
|
||||
(ert-deftest ert-test-builtin-message-log-flushing ()
|
||||
"This test attempts to demonstrate that there is no way to
|
||||
force immediate truncation of the *Messages* buffer from Lisp
|
||||
\(and hence justifies the existence of
|
||||
`ert--force-message-log-buffer-truncation'): The only way that
|
||||
came to my mind was \(message \"\"), which doesn't have the
|
||||
desired effect."
|
||||
:tags '(:causes-redisplay)
|
||||
(ert-with-buffer-renamed ("*Messages*")
|
||||
(with-current-buffer "*Messages*"
|
||||
(should (equal (buffer-string) ""))
|
||||
;; We used to get sporadic failures in this test that involved
|
||||
;; a spurious newline at the beginning of the buffer, before
|
||||
;; the first message. Below, we print a message and erase the
|
||||
;; buffer since this seems to eliminate the sporadic failures.
|
||||
(message "foo")
|
||||
(erase-buffer)
|
||||
(should (equal (buffer-string) ""))
|
||||
(let ((message-log-max 2))
|
||||
(let ((message-log-max t))
|
||||
(cl-loop for i below 4 do
|
||||
(message "%s" i))
|
||||
(should (equal (buffer-string) "0\n1\n2\n3\n")))
|
||||
(should (equal (buffer-string) "0\n1\n2\n3\n"))
|
||||
(message "")
|
||||
(should (equal (buffer-string) "0\n1\n2\n3\n"))
|
||||
(message "Test message")
|
||||
(should (equal (buffer-string) "3\nTest message\n"))))))
|
||||
|
||||
(ert-deftest ert-test-force-message-log-buffer-truncation ()
|
||||
:tags '(:causes-redisplay)
|
||||
(cl-labels ((body ()
|
||||
(cl-loop for i below 3 do
|
||||
(message "%s" i)))
|
||||
;; Uses the implicit messages buffer truncation implemented
|
||||
;; in Emacs' C core.
|
||||
(c (x)
|
||||
(ert-with-buffer-renamed ("*Messages*")
|
||||
(let ((message-log-max x))
|
||||
(body))
|
||||
(with-current-buffer "*Messages*"
|
||||
(buffer-string))))
|
||||
;; Uses our lisp reimplementation.
|
||||
(lisp (x)
|
||||
(ert-with-buffer-renamed ("*Messages*")
|
||||
(let ((message-log-max t))
|
||||
(body))
|
||||
(let ((message-log-max x))
|
||||
(ert--force-message-log-buffer-truncation))
|
||||
(with-current-buffer "*Messages*"
|
||||
(buffer-string)))))
|
||||
(cl-loop for x in '(0 1 2 3 4 t) do
|
||||
(should (equal (c x) (lisp x))))))
|
||||
|
||||
|
||||
(provide 'ert-x-tests)
|
||||
|
||||
;;; ert-x-tests.el ends here
|
||||
284
test/lisp/emacs-lisp/generator-tests.el
Normal file
284
test/lisp/emacs-lisp/generator-tests.el
Normal file
|
|
@ -0,0 +1,284 @@
|
|||
;;; generator-tests.el --- Testing generators -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Daniel Colascione <dancol@dancol.org>
|
||||
;; Keywords:
|
||||
|
||||
;; 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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
(require 'generator)
|
||||
(require 'ert)
|
||||
(require 'cl-lib)
|
||||
|
||||
(defun generator-list-subrs ()
|
||||
(cl-loop for x being the symbols
|
||||
when (and (fboundp x)
|
||||
(cps--special-form-p (symbol-function x)))
|
||||
collect x))
|
||||
|
||||
(defmacro cps-testcase (name &rest body)
|
||||
"Perform a simple test of the continuation-transforming code.
|
||||
|
||||
`cps-testcase' defines an ERT testcase called NAME that evaluates
|
||||
BODY twice: once using ordinary `eval' and once using
|
||||
lambda-generators. The test ensures that the two forms produce
|
||||
identical output.
|
||||
"
|
||||
`(progn
|
||||
(ert-deftest ,name ()
|
||||
(should
|
||||
(equal
|
||||
(funcall (lambda () ,@body))
|
||||
(iter-next
|
||||
(funcall
|
||||
(iter-lambda () (iter-yield (progn ,@body))))))))
|
||||
(ert-deftest ,(intern (format "%s-noopt" name)) ()
|
||||
(should
|
||||
(equal
|
||||
(funcall (lambda () ,@body))
|
||||
(iter-next
|
||||
(funcall
|
||||
(let ((cps-inhibit-atomic-optimization t))
|
||||
(iter-lambda () (iter-yield (progn ,@body)))))))))))
|
||||
|
||||
(put 'cps-testcase 'lisp-indent-function 1)
|
||||
|
||||
(defvar *cps-test-i* nil)
|
||||
(defun cps-get-test-i ()
|
||||
*cps-test-i*)
|
||||
|
||||
(cps-testcase cps-simple-1 (progn 1 2 3))
|
||||
(cps-testcase cps-empty-progn (progn))
|
||||
(cps-testcase cps-inline-not-progn (inline 1 2 3))
|
||||
(cps-testcase cps-prog1-a (prog1 1 2 3))
|
||||
(cps-testcase cps-prog1-b (prog1 1))
|
||||
(cps-testcase cps-prog1-c (prog2 1 2 3))
|
||||
(cps-testcase cps-quote (progn 'hello))
|
||||
(cps-testcase cps-function (progn #'hello))
|
||||
|
||||
(cps-testcase cps-and-fail (and 1 nil 2))
|
||||
(cps-testcase cps-and-succeed (and 1 2 3))
|
||||
(cps-testcase cps-and-empty (and))
|
||||
|
||||
(cps-testcase cps-or-fallthrough (or nil 1 2))
|
||||
(cps-testcase cps-or-alltrue (or 1 2 3))
|
||||
(cps-testcase cps-or-empty (or))
|
||||
|
||||
(cps-testcase cps-let* (let* ((i 10)) i))
|
||||
(cps-testcase cps-let*-shadow-empty (let* ((i 10)) (let (i) i)))
|
||||
(cps-testcase cps-let (let ((i 10)) i))
|
||||
(cps-testcase cps-let-shadow-empty (let ((i 10)) (let (i) i)))
|
||||
(cps-testcase cps-let-novars (let nil 42))
|
||||
(cps-testcase cps-let*-novars (let* nil 42))
|
||||
|
||||
(cps-testcase cps-let-parallel
|
||||
(let ((a 5) (b 6)) (let ((a b) (b a)) (list a b))))
|
||||
|
||||
(cps-testcase cps-let*-parallel
|
||||
(let* ((a 5) (b 6)) (let* ((a b) (b a)) (list a b))))
|
||||
|
||||
(cps-testcase cps-while-dynamic
|
||||
(setq *cps-test-i* 0)
|
||||
(while (< *cps-test-i* 10)
|
||||
(setf *cps-test-i* (+ *cps-test-i* 1)))
|
||||
*cps-test-i*)
|
||||
|
||||
(cps-testcase cps-while-lexical
|
||||
(let* ((i 0) (j 10))
|
||||
(while (< i 10)
|
||||
(setf i (+ i 1))
|
||||
(setf j (+ j (* i 10))))
|
||||
j))
|
||||
|
||||
(cps-testcase cps-while-incf
|
||||
(let* ((i 0) (j 10))
|
||||
(while (< i 10)
|
||||
(cl-incf i)
|
||||
(setf j (+ j (* i 10))))
|
||||
j))
|
||||
|
||||
(cps-testcase cps-dynbind
|
||||
(setf *cps-test-i* 0)
|
||||
(let* ((*cps-test-i* 5))
|
||||
(cps-get-test-i)))
|
||||
|
||||
(cps-testcase cps-nested-application
|
||||
(+ (+ 3 5) 1))
|
||||
|
||||
(cps-testcase cps-unwind-protect
|
||||
(setf *cps-test-i* 0)
|
||||
(unwind-protect
|
||||
(setf *cps-test-i* 1)
|
||||
(setf *cps-test-i* 2))
|
||||
*cps-test-i*)
|
||||
|
||||
(cps-testcase cps-catch-unused
|
||||
(catch 'mytag 42))
|
||||
|
||||
(cps-testcase cps-catch-thrown
|
||||
(1+ (catch 'mytag
|
||||
(throw 'mytag (+ 2 2)))))
|
||||
|
||||
(cps-testcase cps-loop
|
||||
(cl-loop for x from 1 to 10 collect x))
|
||||
|
||||
(cps-testcase cps-loop-backquote
|
||||
`(a b ,(cl-loop for x from 1 to 10 collect x) -1))
|
||||
|
||||
(cps-testcase cps-if-branch-a
|
||||
(if t 'abc))
|
||||
|
||||
(cps-testcase cps-if-branch-b
|
||||
(if t 'abc 'def))
|
||||
|
||||
(cps-testcase cps-if-condition-fail
|
||||
(if nil 'abc 'def))
|
||||
|
||||
(cps-testcase cps-cond-empty
|
||||
(cond))
|
||||
|
||||
(cps-testcase cps-cond-atomi
|
||||
(cond (42)))
|
||||
|
||||
(cps-testcase cps-cond-complex
|
||||
(cond (nil 22) ((1+ 1) 42) (t 'bad)))
|
||||
|
||||
(put 'cps-test-error 'error-conditions '(cps-test-condition))
|
||||
|
||||
(cps-testcase cps-condition-case
|
||||
(condition-case
|
||||
condvar
|
||||
(signal 'cps-test-error 'test-data)
|
||||
(cps-test-condition condvar)))
|
||||
|
||||
(cps-testcase cps-condition-case-no-error
|
||||
(condition-case
|
||||
condvar
|
||||
42
|
||||
(cps-test-condition condvar)))
|
||||
|
||||
(ert-deftest cps-generator-basic ()
|
||||
(let* ((gen (iter-lambda ()
|
||||
(iter-yield 1)
|
||||
(iter-yield 2)
|
||||
(iter-yield 3)
|
||||
4))
|
||||
(gen-inst (funcall gen)))
|
||||
(should (eql (iter-next gen-inst) 1))
|
||||
(should (eql (iter-next gen-inst) 2))
|
||||
(should (eql (iter-next gen-inst) 3))
|
||||
|
||||
;; should-error doesn't catch the generator-end condition (which
|
||||
;; isn't an error), so we write our own.
|
||||
(let (errored)
|
||||
(condition-case x
|
||||
(iter-next gen-inst)
|
||||
(iter-end-of-sequence
|
||||
(setf errored (cdr x))))
|
||||
(should (eql errored 4)))))
|
||||
|
||||
(iter-defun mygenerator (i)
|
||||
(iter-yield 1)
|
||||
(iter-yield i)
|
||||
(iter-yield 2))
|
||||
|
||||
(ert-deftest cps-test-iter-do ()
|
||||
(let (mylist)
|
||||
(iter-do (x (mygenerator 4))
|
||||
(push x mylist))
|
||||
(should (equal mylist '(2 4 1)))))
|
||||
|
||||
(iter-defun gen-using-yield-value ()
|
||||
(let (f)
|
||||
(setf f (iter-yield 42))
|
||||
(iter-yield f)
|
||||
-8))
|
||||
|
||||
(ert-deftest cps-yield-value ()
|
||||
(let ((it (gen-using-yield-value)))
|
||||
(should (eql (iter-next it -1) 42))
|
||||
(should (eql (iter-next it -1) -1))))
|
||||
|
||||
(ert-deftest cps-loop ()
|
||||
(should
|
||||
(equal (cl-loop for x iter-by (mygenerator 42)
|
||||
collect x)
|
||||
'(1 42 2))))
|
||||
|
||||
(iter-defun gen-using-yield-from ()
|
||||
(let ((sub-iter (gen-using-yield-value)))
|
||||
(iter-yield (1+ (iter-yield-from sub-iter)))))
|
||||
|
||||
(ert-deftest cps-test-yield-from-works ()
|
||||
(let ((it (gen-using-yield-from)))
|
||||
(should (eql (iter-next it -1) 42))
|
||||
(should (eql (iter-next it -1) -1))
|
||||
(should (eql (iter-next it -1) -7))))
|
||||
|
||||
(defvar cps-test-closed-flag nil)
|
||||
|
||||
(ert-deftest cps-test-iter-close ()
|
||||
(garbage-collect)
|
||||
(let ((cps-test-closed-flag nil))
|
||||
(let ((iter (funcall
|
||||
(iter-lambda ()
|
||||
(unwind-protect (iter-yield 1)
|
||||
(setf cps-test-closed-flag t))))))
|
||||
(should (equal (iter-next iter) 1))
|
||||
(should (not cps-test-closed-flag))
|
||||
(iter-close iter)
|
||||
(should cps-test-closed-flag))))
|
||||
|
||||
(ert-deftest cps-test-iter-close-idempotent ()
|
||||
(garbage-collect)
|
||||
(let ((cps-test-closed-flag nil))
|
||||
(let ((iter (funcall
|
||||
(iter-lambda ()
|
||||
(unwind-protect (iter-yield 1)
|
||||
(setf cps-test-closed-flag t))))))
|
||||
(should (equal (iter-next iter) 1))
|
||||
(should (not cps-test-closed-flag))
|
||||
(iter-close iter)
|
||||
(should cps-test-closed-flag)
|
||||
(setf cps-test-closed-flag nil)
|
||||
(iter-close iter)
|
||||
(should (not cps-test-closed-flag)))))
|
||||
|
||||
(ert-deftest cps-test-iter-cleanup-once-only ()
|
||||
(let* ((nr-unwound 0)
|
||||
(iter
|
||||
(funcall (iter-lambda ()
|
||||
(unwind-protect
|
||||
(progn
|
||||
(iter-yield 1)
|
||||
(error "test")
|
||||
(iter-yield 2))
|
||||
(cl-incf nr-unwound))))))
|
||||
(should (equal (iter-next iter) 1))
|
||||
(should-error (iter-next iter))
|
||||
(should (equal nr-unwound 1))))
|
||||
|
||||
(iter-defun generator-with-docstring ()
|
||||
"Documentation!"
|
||||
(declare (indent 5))
|
||||
nil)
|
||||
|
||||
(ert-deftest cps-test-declarations-preserved ()
|
||||
(should (equal (documentation 'generator-with-docstring) "Documentation!"))
|
||||
(should (equal (get 'generator-with-docstring 'lisp-indent-function) 5)))
|
||||
91
test/lisp/emacs-lisp/let-alist-tests.el
Normal file
91
test/lisp/emacs-lisp/let-alist-tests.el
Normal file
|
|
@ -0,0 +1,91 @@
|
|||
;;; let-alist.el --- tests for file handling. -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2012-2015 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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'cl-lib)
|
||||
(require 'let-alist)
|
||||
|
||||
(ert-deftest let-alist-surface-test ()
|
||||
"Tests basic macro expansion for `let-alist'."
|
||||
(should
|
||||
(equal '(let ((symbol data))
|
||||
(let ((.test-one (cdr (assq 'test-one symbol)))
|
||||
(.test-two (cdr (assq 'test-two symbol))))
|
||||
(list .test-one .test-two
|
||||
.test-two .test-two)))
|
||||
(cl-letf (((symbol-function #'make-symbol) (lambda (x) 'symbol)))
|
||||
(macroexpand
|
||||
'(let-alist data (list .test-one .test-two
|
||||
.test-two .test-two))))))
|
||||
(should
|
||||
(equal
|
||||
(let ((.external "ext")
|
||||
(.external.too "et"))
|
||||
(let-alist '((test-two . 0)
|
||||
(test-three . 1)
|
||||
(sublist . ((foo . 2)
|
||||
(bar . 3))))
|
||||
(list .test-one .test-two .test-three
|
||||
.sublist.foo .sublist.bar
|
||||
..external ..external.too)))
|
||||
(list nil 0 1 2 3 "ext" "et"))))
|
||||
|
||||
(ert-deftest let-alist-cons ()
|
||||
(should
|
||||
(equal
|
||||
(let ((.external "ext")
|
||||
(.external.too "et"))
|
||||
(let-alist '((test-two . 0)
|
||||
(test-three . 1)
|
||||
(sublist . ((foo . 2)
|
||||
(bar . 3))))
|
||||
(list `(, .test-one . , .test-two)
|
||||
.sublist.bar ..external)))
|
||||
(list '(nil . 0) 3 "ext"))))
|
||||
|
||||
(defvar let-alist--test-counter 0
|
||||
"Used to count number of times a function is called.")
|
||||
|
||||
(ert-deftest let-alist-evaluate-once ()
|
||||
"Check that the alist argument is only evaluated once."
|
||||
(let ((let-alist--test-counter 0))
|
||||
(should
|
||||
(equal
|
||||
(let-alist (list
|
||||
(cons 'test-two (cl-incf let-alist--test-counter))
|
||||
(cons 'test-three (cl-incf let-alist--test-counter)))
|
||||
(list .test-one .test-two .test-two .test-three .cl-incf))
|
||||
'(nil 1 1 2 nil)))))
|
||||
|
||||
(ert-deftest let-alist-remove-dot ()
|
||||
"Remove first dot from symbol."
|
||||
(should (equal (let-alist--remove-dot 'hi) 'hi))
|
||||
(should (equal (let-alist--remove-dot '.hi) 'hi))
|
||||
(should (equal (let-alist--remove-dot '..hi) '.hi)))
|
||||
|
||||
(ert-deftest let-alist-list-to-sexp ()
|
||||
"Check that multiple dots are handled correctly."
|
||||
(should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1)))))))))
|
||||
(should (equal (let-alist--access-sexp '.foo.bar.baz 'var)
|
||||
'(cdr (assq 'baz (cdr (assq 'bar (cdr (assq 'foo var))))))))
|
||||
(should (equal (let-alist--access-sexp '..foo.bar.baz 'var) '.foo.bar.baz)))
|
||||
|
||||
;;; let-alist.el ends here
|
||||
331
test/lisp/emacs-lisp/map-tests.el
Normal file
331
test/lisp/emacs-lisp/map-tests.el
Normal file
|
|
@ -0,0 +1,331 @@
|
|||
;;; map-tests.el --- Tests for map.el -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Nicolas Petton <nicolas@petton.fr>
|
||||
;; Maintainer: emacs-devel@gnu.org
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Tests for map.el
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'map)
|
||||
|
||||
(defmacro with-maps-do (var &rest body)
|
||||
"Successively bind VAR to an alist, 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)"
|
||||
(declare (indent 1) (debug t))
|
||||
(let ((alist (make-symbol "alist"))
|
||||
(vec (make-symbol "vec"))
|
||||
(ht (make-symbol "ht")))
|
||||
`(let ((,alist (list (cons 0 3)
|
||||
(cons 1 4)
|
||||
(cons 2 5)))
|
||||
(,vec (vector 3 4 5))
|
||||
(,ht (make-hash-table)))
|
||||
(puthash 0 3 ,ht)
|
||||
(puthash 1 4 ,ht)
|
||||
(puthash 2 5 ,ht)
|
||||
(dolist (,var (list ,alist ,vec ,ht))
|
||||
,@body))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(ert-deftest test-map-elt-default ()
|
||||
(with-maps-do map
|
||||
(should (= 5 (map-elt map 7 5)))))
|
||||
|
||||
(ert-deftest test-map-elt-with-nil-value ()
|
||||
(should (null (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)
|
||||
(should (eq (map-elt map 2) 'hello)))
|
||||
(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))))
|
||||
|
||||
(ert-deftest test-map-put-return-value ()
|
||||
(let ((ht (make-hash-table)))
|
||||
(should (eq (map-put ht 'a 'hello) ht))))
|
||||
|
||||
(ert-deftest test-map-delete ()
|
||||
(with-maps-do map
|
||||
(map-delete map 1)
|
||||
(should (null (map-elt map 1))))
|
||||
(with-maps-do map
|
||||
(map-delete map -2)
|
||||
(should (null (map-elt map -2)))))
|
||||
|
||||
(ert-deftest test-map-delete-return-value ()
|
||||
(let ((ht (make-hash-table)))
|
||||
(should (eq (map-delete ht 'a) ht))))
|
||||
|
||||
(ert-deftest test-map-nested-elt ()
|
||||
(let ((vec [a b [c d [e f]]]))
|
||||
(should (eq (map-nested-elt vec '(2 2 0)) 'e)))
|
||||
(let ((alist '((a . 1)
|
||||
(b . ((c . 2)
|
||||
(d . 3)
|
||||
(e . ((f . 4)
|
||||
(g . 5))))))))
|
||||
(should (eq (map-nested-elt alist '(b e f))
|
||||
4)))
|
||||
(let ((ht (make-hash-table)))
|
||||
(setf (map-elt ht 'a) 1)
|
||||
(setf (map-elt ht 'b) (make-hash-table))
|
||||
(setf (map-elt (map-elt ht 'b) 'c) 2)
|
||||
(should (eq (map-nested-elt ht '(b c))
|
||||
2))))
|
||||
|
||||
(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 (= 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)))
|
||||
(should (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 []))))
|
||||
|
||||
(ert-deftest test-map-values ()
|
||||
(with-maps-do map
|
||||
(should (equal (map-values map) '(3 4 5)))))
|
||||
|
||||
(ert-deftest test-map-pairs ()
|
||||
(with-maps-do map
|
||||
(should (equal (map-pairs map) '((0 . 3)
|
||||
(1 . 4)
|
||||
(2 . 5))))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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))))))
|
||||
|
||||
(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))))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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")))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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]))))
|
||||
|
||||
(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 "")))
|
||||
|
||||
(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))))
|
||||
|
||||
(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))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(ert-deftest test-map-into ()
|
||||
(let* ((alist '((a . 1) (b . 2)))
|
||||
(ht (map-into alist 'hash-table)))
|
||||
(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 (null (map-into nil 'list)))
|
||||
(should (map-empty-p (map-into nil 'hash-table)))
|
||||
(should-error (map-into [1 2 3] 'string))))
|
||||
|
||||
(ert-deftest test-map-let ()
|
||||
(map-let (foo bar baz) '((foo . 1) (bar . 2))
|
||||
(should (= foo 1))
|
||||
(should (= bar 2))
|
||||
(should (null baz)))
|
||||
(map-let (('foo a)
|
||||
('bar b)
|
||||
('baz c))
|
||||
'((foo . 1) (bar . 2))
|
||||
(should (= a 1))
|
||||
(should (= b 2))
|
||||
(should (null c))))
|
||||
|
||||
(ert-deftest test-map-merge-with ()
|
||||
(should (equal (map-merge-with 'list #'+
|
||||
'((1 . 2))
|
||||
'((1 . 3) (2 . 4))
|
||||
'((1 . 1) (2 . 5) (3 . 0)))
|
||||
'((3 . 0) (2 . 9) (1 . 6)))))
|
||||
|
||||
(provide 'map-tests)
|
||||
;;; map-tests.el ends here
|
||||
211
test/lisp/emacs-lisp/nadvice-tests.el
Normal file
211
test/lisp/emacs-lisp/nadvice-tests.el
Normal file
|
|
@ -0,0 +1,211 @@
|
|||
;;; advice-tests.el --- Test suite for the new advice thingy.
|
||||
|
||||
;; Copyright (C) 2012-2015 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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
|
||||
(ert-deftest advice-tests-nadvice ()
|
||||
"Test nadvice code."
|
||||
(advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5)))
|
||||
(advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 2)))
|
||||
(advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
|
||||
(defun sm-test1 (x) (+ x 4))
|
||||
(should (equal (sm-test1 6) 20))
|
||||
(advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 2)))
|
||||
(should (equal (sm-test1 6) 10))
|
||||
(advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5)))
|
||||
(should (equal (sm-test1 6) 50))
|
||||
(defun sm-test1 (x) (+ x 14))
|
||||
(should (equal (sm-test1 6) 100))
|
||||
(should (equal (null (get 'sm-test1 'defalias-fset-function)) nil))
|
||||
(advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
|
||||
(should (equal (sm-test1 6) 20))
|
||||
(should (equal (get 'sm-test1 'defalias-fset-function) nil))
|
||||
|
||||
(advice-add 'sm-test3 :around
|
||||
(lambda (f &rest args) `(toto ,(apply f args)))
|
||||
'((name . wrap-with-toto)))
|
||||
(defmacro sm-test3 (x) `(call-test3 ,x))
|
||||
(should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56)))))
|
||||
|
||||
(ert-deftest advice-tests-macroaliases ()
|
||||
"Test nadvice code on aliases to macros."
|
||||
(defmacro sm-test1 (a) `(list ',a))
|
||||
(defalias 'sm-test1-alias 'sm-test1)
|
||||
(should (equal (macroexpand '(sm-test1-alias 5)) '(list '5)))
|
||||
(advice-add 'sm-test1-alias :around
|
||||
(lambda (f &rest args) `(cons 1 ,(apply f args))))
|
||||
(should (equal (macroexpand '(sm-test1-alias 5)) '(cons 1 (list '5))))
|
||||
(defmacro sm-test1 (a) `(list 0 ',a))
|
||||
(should (equal (macroexpand '(sm-test1-alias 5)) '(cons 1 (list 0 '5)))))
|
||||
|
||||
|
||||
(ert-deftest advice-tests-advice ()
|
||||
"Test advice code."
|
||||
(defun sm-test2 (x) (+ x 4))
|
||||
(should (equal (sm-test2 6) 10))
|
||||
(defadvice sm-test2 (around sm-test activate)
|
||||
ad-do-it (setq ad-return-value (* ad-return-value 5)))
|
||||
(should (equal (sm-test2 6) 50))
|
||||
(ad-deactivate 'sm-test2)
|
||||
(should (equal (sm-test2 6) 10))
|
||||
(ad-activate 'sm-test2)
|
||||
(should (equal (sm-test2 6) 50))
|
||||
(defun sm-test2 (x) (+ x 14))
|
||||
(should (equal (sm-test2 6) 100))
|
||||
(should (equal (null (get 'sm-test2 'defalias-fset-function)) nil))
|
||||
(ad-remove-advice 'sm-test2 'around 'sm-test)
|
||||
(should (equal (sm-test2 6) 100))
|
||||
(ad-activate 'sm-test2)
|
||||
(should (equal (sm-test2 6) 20))
|
||||
(should (equal (null (get 'sm-test2 'defalias-fset-function)) t))
|
||||
|
||||
(defadvice sm-test4 (around wrap-with-toto activate)
|
||||
ad-do-it (setq ad-return-value `(toto ,ad-return-value)))
|
||||
(defmacro sm-test4 (x) `(call-test4 ,x))
|
||||
(should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56))))
|
||||
(defmacro sm-test4 (x) `(call-testq ,x))
|
||||
(should (equal (macroexpand '(sm-test4 56)) '(toto (call-testq 56))))
|
||||
|
||||
;; This used to signal an error (bug#12858).
|
||||
(autoload 'sm-test6 "foo")
|
||||
(defadvice sm-test6 (around test activate)
|
||||
ad-do-it))
|
||||
|
||||
(ert-deftest advice-tests-combination ()
|
||||
"Combining old style and new style advices."
|
||||
(defun sm-test5 (x) (+ x 4))
|
||||
(should (equal (sm-test5 6) 10))
|
||||
(advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5)))
|
||||
(should (equal (sm-test5 6) 50))
|
||||
(defadvice sm-test5 (around test activate)
|
||||
ad-do-it (setq ad-return-value (+ ad-return-value 0.1)))
|
||||
(should (equal (sm-test5 5) 45.1))
|
||||
(ad-deactivate 'sm-test5)
|
||||
(should (equal (sm-test5 6) 50))
|
||||
(ad-activate 'sm-test5)
|
||||
(should (equal (sm-test5 6) 50.1))
|
||||
(defun sm-test5 (x) (+ x 14))
|
||||
(should (equal (sm-test5 6) 100.1))
|
||||
(advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5)))
|
||||
(should (equal (sm-test5 6) 20.1)))
|
||||
|
||||
(ert-deftest advice-test-called-interactively-p ()
|
||||
"Check interaction between advice and called-interactively-p."
|
||||
(defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4))
|
||||
(advice-add 'sm-test7 :around
|
||||
(lambda (f &rest args)
|
||||
(list (cons 1 (called-interactively-p)) (apply f args))))
|
||||
(should (equal (sm-test7) '((1 . nil) 11)))
|
||||
(should (equal (call-interactively 'sm-test7) '((1 . t) 11)))
|
||||
(let ((smi 7))
|
||||
(advice-add 'sm-test7 :before
|
||||
(lambda (&rest args)
|
||||
(setq smi (called-interactively-p))))
|
||||
(should (equal (list (sm-test7) smi)
|
||||
'(((1 . nil) 11) nil)))
|
||||
(should (equal (list (call-interactively 'sm-test7) smi)
|
||||
'(((1 . t) 11) t))))
|
||||
(advice-add 'sm-test7 :around
|
||||
(lambda (f &rest args)
|
||||
(cons (cons 2 (called-interactively-p)) (apply f args))))
|
||||
(should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11))))
|
||||
|
||||
(ert-deftest advice-test-called-interactively-p-around ()
|
||||
"Check interaction between around advice and called-interactively-p.
|
||||
|
||||
This tests the currently broken case of the innermost advice to a
|
||||
function being an around advice."
|
||||
:expected-result :failed
|
||||
(defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p)))
|
||||
(advice-add 'sm-test7.2 :around
|
||||
(lambda (f &rest args)
|
||||
(list (cons 1 (called-interactively-p)) (apply f args))))
|
||||
(should (equal (sm-test7.2) '((1 . nil) (1 . nil))))
|
||||
(should (equal (call-interactively 'sm-test7.2) '((1 . t) (1 . t)))))
|
||||
|
||||
(ert-deftest advice-test-called-interactively-p-filter-args ()
|
||||
"Check interaction between filter-args advice and called-interactively-p."
|
||||
:expected-result :failed
|
||||
(defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p)))
|
||||
(advice-add 'sm-test7.3 :filter-args #'list)
|
||||
(should (equal (sm-test7.3) '(1 . nil)))
|
||||
(should (equal (call-interactively 'sm-test7.3) '(1 . t))))
|
||||
|
||||
(ert-deftest advice-test-call-interactively ()
|
||||
"Check interaction between advice on call-interactively and called-interactively-p."
|
||||
(defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p)))
|
||||
(let ((old (symbol-function 'call-interactively)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(advice-add 'call-interactively :before #'ignore)
|
||||
(should (equal (sm-test7.4) '(1 . nil)))
|
||||
(should (equal (call-interactively 'sm-test7.4) '(1 . t))))
|
||||
(advice-remove 'call-interactively #'ignore)
|
||||
(should (eq (symbol-function 'call-interactively) old)))))
|
||||
|
||||
(ert-deftest advice-test-interactive ()
|
||||
"Check handling of interactive spec."
|
||||
(defun sm-test8 (a) (interactive "p") a)
|
||||
(defadvice sm-test8 (before adv1 activate) nil)
|
||||
(defadvice sm-test8 (before adv2 activate) (interactive "P") nil)
|
||||
(should (equal (interactive-form 'sm-test8) '(interactive "P"))))
|
||||
|
||||
(ert-deftest advice-test-preactivate ()
|
||||
(should (equal (null (get 'sm-test9 'defalias-fset-function)) t))
|
||||
(defun sm-test9 (a) (interactive "p") a)
|
||||
(should (equal (null (get 'sm-test9 'defalias-fset-function)) t))
|
||||
(defadvice sm-test9 (before adv1 pre act protect compile) nil)
|
||||
(should (equal (null (get 'sm-test9 'defalias-fset-function)) nil))
|
||||
(defadvice sm-test9 (before adv2 pre act protect compile)
|
||||
(interactive "P") nil)
|
||||
(should (equal (interactive-form 'sm-test9) '(interactive "P"))))
|
||||
|
||||
(ert-deftest advice-test-multiples ()
|
||||
(let ((sm-test10 (lambda (a) (+ a 10)))
|
||||
(sm-advice (lambda (x) (if (consp x) (list (* 5 (car x))) (* 4 x)))))
|
||||
(should (equal (funcall sm-test10 5) 15))
|
||||
(add-function :filter-args (var sm-test10) sm-advice)
|
||||
(should (advice-function-member-p sm-advice sm-test10))
|
||||
(should (equal (funcall sm-test10 5) 35))
|
||||
(add-function :filter-return (var sm-test10) sm-advice)
|
||||
(should (equal (funcall sm-test10 5) 60))
|
||||
;; Make sure we can add multiple times the same function, under the
|
||||
;; condition that they have different `name' properties.
|
||||
(add-function :filter-args (var sm-test10) sm-advice '((name . "args")))
|
||||
(should (equal (funcall sm-test10 5) 140))
|
||||
(remove-function (var sm-test10) "args")
|
||||
(should (equal (funcall sm-test10 5) 60))
|
||||
(add-function :filter-args (var sm-test10) sm-advice '((name . "args")))
|
||||
(add-function :filter-return (var sm-test10) sm-advice '((name . "ret")))
|
||||
(should (equal (funcall sm-test10 5) 560))
|
||||
;; Make sure that if we specify to remove a function that was added
|
||||
;; multiple times, they are all removed, rather than removing only some
|
||||
;; arbitrary subset of them.
|
||||
(remove-function (var sm-test10) sm-advice)
|
||||
(should (equal (funcall sm-test10 5) 15))))
|
||||
|
||||
;; Local Variables:
|
||||
;; no-byte-compile: t
|
||||
;; End:
|
||||
|
||||
;;; advice-tests.el ends here.
|
||||
611
test/lisp/emacs-lisp/package-tests.el
Normal file
611
test/lisp/emacs-lisp/package-tests.el
Normal file
|
|
@ -0,0 +1,611 @@
|
|||
;;; package-test.el --- Tests for the Emacs package system
|
||||
|
||||
;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Daniel Hackney <dan@haxney.org>
|
||||
;; Version: 1.0
|
||||
|
||||
;; 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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; You may want to run this from a separate Emacs instance from your
|
||||
;; main one, because a bug in the code below could mess with your
|
||||
;; installed packages.
|
||||
|
||||
;; Run this in a clean Emacs session using:
|
||||
;;
|
||||
;; $ emacs -Q --batch -L . -l package-test.el -l ert -f ert-run-tests-batch-and-exit
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'package)
|
||||
(require 'ert)
|
||||
(require 'cl-lib)
|
||||
|
||||
(setq package-menu-async nil)
|
||||
|
||||
(defvar package-test-user-dir nil
|
||||
"Directory to use for installing packages during testing.")
|
||||
|
||||
(defvar package-test-file-dir (file-name-directory (or load-file-name
|
||||
buffer-file-name))
|
||||
"Directory of the actual \"package-test.el\" file.")
|
||||
|
||||
(defvar simple-single-desc
|
||||
(package-desc-create :name 'simple-single
|
||||
:version '(1 3)
|
||||
:summary "A single-file package with no dependencies"
|
||||
:kind 'single
|
||||
:extras '((:authors ("J. R. Hacker" . "jrh@example.com"))
|
||||
(:maintainer "J. R. Hacker" . "jrh@example.com")
|
||||
(:url . "http://doodles.au")))
|
||||
"Expected `package-desc' parsed from simple-single-1.3.el.")
|
||||
|
||||
(defvar simple-depend-desc
|
||||
(package-desc-create :name 'simple-depend
|
||||
:version '(1 0)
|
||||
:summary "A single-file package with a dependency."
|
||||
:kind 'single
|
||||
:reqs '((simple-single (1 3)))
|
||||
:extras '((:authors ("J. R. Hacker" . "jrh@example.com"))
|
||||
(:maintainer "J. R. Hacker" . "jrh@example.com")))
|
||||
"Expected `package-desc' parsed from simple-depend-1.0.el.")
|
||||
|
||||
(defvar multi-file-desc
|
||||
(package-desc-create :name 'multi-file
|
||||
:version '(0 2 3)
|
||||
:summary "Example of a multi-file tar package"
|
||||
:kind 'tar
|
||||
:extras '((:url . "http://puddles.li")))
|
||||
"Expected `package-desc' from \"multi-file-0.2.3.tar\".")
|
||||
|
||||
(defvar new-pkg-desc
|
||||
(package-desc-create :name 'new-pkg
|
||||
:version '(1 0)
|
||||
:kind 'single)
|
||||
"Expected `package-desc' parsed from new-pkg-1.0.el.")
|
||||
|
||||
(defvar simple-depend-desc-1
|
||||
(package-desc-create :name 'simple-depend-1
|
||||
:version '(1 0)
|
||||
:summary "A single-file package with a dependency."
|
||||
:kind 'single
|
||||
:reqs '((simple-depend (1 0))
|
||||
(multi-file (0 1))))
|
||||
"`package-desc' used for testing dependencies.")
|
||||
|
||||
(defvar simple-depend-desc-2
|
||||
(package-desc-create :name 'simple-depend-2
|
||||
:version '(1 0)
|
||||
:summary "A single-file package with a dependency."
|
||||
:kind 'single
|
||||
:reqs '((simple-depend-1 (1 0))
|
||||
(multi-file (0 1))))
|
||||
"`package-desc' used for testing dependencies.")
|
||||
|
||||
(defvar package-test-data-dir (expand-file-name "data/package" package-test-file-dir)
|
||||
"Base directory of package test files.")
|
||||
|
||||
(defvar package-test-fake-contents-file
|
||||
(expand-file-name "archive-contents" package-test-data-dir)
|
||||
"Path to a static copy of \"archive-contents\".")
|
||||
|
||||
(cl-defmacro with-package-test ((&optional &key file
|
||||
basedir
|
||||
install
|
||||
location
|
||||
update-news
|
||||
upload-base)
|
||||
&rest body)
|
||||
"Set up temporary locations and variables for testing."
|
||||
(declare (indent 1))
|
||||
`(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t))
|
||||
(process-environment (cons (format "HOME=%s" package-test-user-dir)
|
||||
process-environment))
|
||||
(package-user-dir package-test-user-dir)
|
||||
(package-archives `(("gnu" . ,(or ,location package-test-data-dir))))
|
||||
(default-directory package-test-file-dir)
|
||||
abbreviated-home-dir
|
||||
package--initialized
|
||||
package-alist
|
||||
,@(if update-news
|
||||
'(package-update-news-on-upload t)
|
||||
(list (cl-gensym)))
|
||||
,@(if upload-base
|
||||
'((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t))
|
||||
(package-archive-upload-base package-test-archive-upload-base))
|
||||
(list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil
|
||||
(let ((buf (get-buffer "*Packages*")))
|
||||
(when (buffer-live-p buf)
|
||||
(kill-buffer buf)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
,(if basedir `(cd ,basedir))
|
||||
(unless (file-directory-p package-user-dir)
|
||||
(mkdir package-user-dir))
|
||||
(cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest r) t))
|
||||
((symbol-function 'y-or-n-p) (lambda (&rest r) t)))
|
||||
,@(when install
|
||||
`((package-initialize)
|
||||
(package-refresh-contents)
|
||||
(mapc 'package-install ,install)))
|
||||
(with-temp-buffer
|
||||
,(if file
|
||||
`(insert-file-contents ,file))
|
||||
,@body)))
|
||||
|
||||
(when (file-directory-p package-test-user-dir)
|
||||
(delete-directory package-test-user-dir t))
|
||||
|
||||
(when (and (boundp 'package-test-archive-upload-base)
|
||||
(file-directory-p package-test-archive-upload-base))
|
||||
(delete-directory package-test-archive-upload-base t)))))
|
||||
|
||||
(defmacro with-fake-help-buffer (&rest body)
|
||||
"Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer."
|
||||
`(with-temp-buffer
|
||||
(help-mode)
|
||||
;; Trick `help-buffer' into using the temp buffer.
|
||||
(let ((help-xref-following t))
|
||||
,@body)))
|
||||
|
||||
(defun package-test-strip-version (dir)
|
||||
(replace-regexp-in-string "-pkg\\.el\\'" "" (package--description-file dir)))
|
||||
|
||||
(defun package-test-suffix-matches (base suffix-list)
|
||||
"Return file names matching BASE concatenated with each item in SUFFIX-LIST"
|
||||
(cl-mapcan
|
||||
'(lambda (item) (file-expand-wildcards (concat base item)))
|
||||
suffix-list))
|
||||
|
||||
(defvar tar-parse-info)
|
||||
(declare-function tar-header-name "tar-mode" (cl-x) t) ; defstruct
|
||||
|
||||
(defun package-test-search-tar-file (filename)
|
||||
"Search the current buffer's `tar-parse-info' variable for FILENAME.
|
||||
|
||||
Must called from within a `tar-mode' buffer."
|
||||
(cl-dolist (header tar-parse-info)
|
||||
(let ((tar-name (tar-header-name header)))
|
||||
(when (string= tar-name filename)
|
||||
(cl-return t)))))
|
||||
|
||||
(defun package-test-desc-version-string (desc)
|
||||
"Return the package version as a string."
|
||||
(package-version-join (package-desc-version desc)))
|
||||
|
||||
(ert-deftest package-test-desc-from-buffer ()
|
||||
"Parse an elisp buffer to get a `package-desc' object."
|
||||
(with-package-test (:basedir "data/package" :file "simple-single-1.3.el")
|
||||
(should (equal (package-buffer-info) simple-single-desc)))
|
||||
(with-package-test (:basedir "data/package" :file "simple-depend-1.0.el")
|
||||
(should (equal (package-buffer-info) simple-depend-desc)))
|
||||
(with-package-test (:basedir "data/package"
|
||||
:file "multi-file-0.2.3.tar")
|
||||
(tar-mode)
|
||||
(should (equal (package-tar-file-info) multi-file-desc))))
|
||||
|
||||
(ert-deftest package-test-install-single ()
|
||||
"Install a single file without using an archive."
|
||||
(with-package-test (:basedir "data/package" :file "simple-single-1.3.el")
|
||||
(should (package-install-from-buffer))
|
||||
(package-initialize)
|
||||
(should (package-installed-p 'simple-single))
|
||||
;; Check if we properly report an "already installed".
|
||||
(package-install 'simple-single)
|
||||
(with-current-buffer "*Messages*"
|
||||
(should (string-match "^[`‘']simple-single[’'] is already installed\n?\\'"
|
||||
(buffer-string))))
|
||||
(should (package-installed-p 'simple-single))
|
||||
(let* ((simple-pkg-dir (file-name-as-directory
|
||||
(expand-file-name
|
||||
"simple-single-1.3"
|
||||
package-test-user-dir)))
|
||||
(autoloads-file (expand-file-name "simple-single-autoloads.el"
|
||||
simple-pkg-dir)))
|
||||
(should (file-directory-p simple-pkg-dir))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents (expand-file-name "simple-single-pkg.el"
|
||||
simple-pkg-dir))
|
||||
(should (string= (buffer-string)
|
||||
(concat ";;; -*- no-byte-compile: t -*-\n"
|
||||
"(define-package \"simple-single\" \"1.3\" "
|
||||
"\"A single-file package "
|
||||
"with no dependencies\" 'nil "
|
||||
":authors '((\"J. R. Hacker\" . \"jrh@example.com\")) "
|
||||
":maintainer '(\"J. R. Hacker\" . \"jrh@example.com\") "
|
||||
":url \"http://doodles.au\""
|
||||
")\n"))))
|
||||
(should (file-exists-p autoloads-file))
|
||||
(should-not (get-file-buffer autoloads-file)))))
|
||||
|
||||
(ert-deftest package-test-install-dependency ()
|
||||
"Install a package which includes a dependency."
|
||||
(with-package-test ()
|
||||
(package-initialize)
|
||||
(package-refresh-contents)
|
||||
(package-install 'simple-depend)
|
||||
(should (package-installed-p 'simple-single))
|
||||
(should (package-installed-p 'simple-depend))))
|
||||
|
||||
(ert-deftest package-test-install-two-dependencies ()
|
||||
"Install a package which includes a dependency."
|
||||
(with-package-test ()
|
||||
(package-initialize)
|
||||
(package-refresh-contents)
|
||||
(package-install 'simple-two-depend)
|
||||
(should (package-installed-p 'simple-single))
|
||||
(should (package-installed-p 'simple-depend))
|
||||
(should (package-installed-p 'simple-two-depend))))
|
||||
|
||||
(ert-deftest package-test-refresh-contents ()
|
||||
"Parse an \"archive-contents\" file."
|
||||
(with-package-test ()
|
||||
(package-initialize)
|
||||
(package-refresh-contents)
|
||||
(should (eq 4 (length package-archive-contents)))))
|
||||
|
||||
(ert-deftest package-test-install-single-from-archive ()
|
||||
"Install a single package from a package archive."
|
||||
(with-package-test ()
|
||||
(package-initialize)
|
||||
(package-refresh-contents)
|
||||
(package-install 'simple-single)))
|
||||
|
||||
(ert-deftest package-test-install-prioritized ()
|
||||
"Install a lower version from a higher-prioritized archive."
|
||||
(with-package-test ()
|
||||
(let* ((newer-version (expand-file-name "data/package/newer-versions"
|
||||
package-test-file-dir))
|
||||
(package-archives `(("older" . ,package-test-data-dir)
|
||||
("newer" . ,newer-version)))
|
||||
(package-archive-priorities '(("older" . 100))))
|
||||
|
||||
(package-initialize)
|
||||
(package-refresh-contents)
|
||||
(package-install 'simple-single)
|
||||
|
||||
(let ((installed (cadr (assq 'simple-single package-alist))))
|
||||
(should (version-list-= '(1 3)
|
||||
(package-desc-version installed)))))))
|
||||
|
||||
(ert-deftest package-test-install-multifile ()
|
||||
"Check properties of the installed multi-file package."
|
||||
(with-package-test (:basedir "data/package" :install '(multi-file))
|
||||
(let ((autoload-file
|
||||
(expand-file-name "multi-file-autoloads.el"
|
||||
(expand-file-name
|
||||
"multi-file-0.2.3"
|
||||
package-test-user-dir)))
|
||||
(installed-files '("dir" "multi-file.info" "multi-file-sub.elc"
|
||||
"multi-file-autoloads.el" "multi-file.elc"))
|
||||
(autoload-forms '("^(defvar multi-file-custom-var"
|
||||
"^(custom-autoload 'multi-file-custom-var"
|
||||
"^(autoload 'multi-file-mode"))
|
||||
(pkg-dir (file-name-as-directory
|
||||
(expand-file-name
|
||||
"multi-file-0.2.3"
|
||||
package-test-user-dir))))
|
||||
(package-refresh-contents)
|
||||
(should (package-installed-p 'multi-file))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents-literally autoload-file)
|
||||
(dolist (fn installed-files)
|
||||
(should (file-exists-p (expand-file-name fn pkg-dir))))
|
||||
(dolist (re autoload-forms)
|
||||
(goto-char (point-min))
|
||||
(should (re-search-forward re nil t)))))))
|
||||
|
||||
(ert-deftest package-test-update-listing ()
|
||||
"Ensure installed package status is updated."
|
||||
(with-package-test ()
|
||||
(let ((buf (package-list-packages)))
|
||||
(search-forward-regexp "^ +simple-single")
|
||||
(package-menu-mark-install)
|
||||
(package-menu-execute)
|
||||
(run-hooks 'post-command-hook)
|
||||
(should (package-installed-p 'simple-single))
|
||||
(switch-to-buffer "*Packages*")
|
||||
(goto-char (point-min))
|
||||
(should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t))
|
||||
(goto-char (point-min))
|
||||
(should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t))
|
||||
(kill-buffer buf))))
|
||||
|
||||
(ert-deftest package-test-update-archives ()
|
||||
"Test updating package archives."
|
||||
(with-package-test ()
|
||||
(let ((buf (package-list-packages)))
|
||||
(package-menu-refresh)
|
||||
(search-forward-regexp "^ +simple-single")
|
||||
(package-menu-mark-install)
|
||||
(package-menu-execute)
|
||||
(should (package-installed-p 'simple-single))
|
||||
(let ((package-test-data-dir
|
||||
(expand-file-name "data/package/newer-versions" package-test-file-dir)))
|
||||
(setq package-archives `(("gnu" . ,package-test-data-dir)))
|
||||
(package-menu-refresh)
|
||||
|
||||
;; New version should be available and old version should be installed
|
||||
(goto-char (point-min))
|
||||
(should (re-search-forward "^\\s-+simple-single\\s-+1.4\\s-+available" nil t))
|
||||
(should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t))
|
||||
|
||||
(goto-char (point-min))
|
||||
(should (re-search-forward "^\\s-+new-pkg\\s-+1.0\\s-+\\(available\\|new\\)" nil t))
|
||||
|
||||
(package-menu-mark-upgrades)
|
||||
(package-menu-execute)
|
||||
(package-menu-refresh)
|
||||
(should (package-installed-p 'simple-single '(1 4)))))))
|
||||
|
||||
(ert-deftest package-test-update-archives-async ()
|
||||
"Test updating package archives asynchronously."
|
||||
(skip-unless (executable-find "python2"))
|
||||
;; For some reason this test doesn't work reliably on hydra.nixos.org.
|
||||
(skip-unless (not (getenv "NIX_STORE")))
|
||||
(with-package-test (:basedir
|
||||
package-test-data-dir
|
||||
:location "http://0.0.0.0:8000/")
|
||||
(let* ((package-menu-async t)
|
||||
(process (start-process
|
||||
"package-server" "package-server-buffer"
|
||||
(executable-find "python2")
|
||||
(expand-file-name "package-test-server.py"))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(list-packages)
|
||||
(should package--downloads-in-progress)
|
||||
(should mode-line-process)
|
||||
(should-not
|
||||
(with-timeout (10 'timeout)
|
||||
(while package--downloads-in-progress
|
||||
(accept-process-output nil 1))
|
||||
nil))
|
||||
;; If the server process died, there's some non-Emacs problem.
|
||||
;; Eg maybe the port was already in use.
|
||||
(skip-unless (process-live-p process))
|
||||
(goto-char (point-min))
|
||||
(should
|
||||
(search-forward-regexp "^ +simple-single" nil t)))
|
||||
(if (process-live-p process) (kill-process process))))))
|
||||
|
||||
(ert-deftest package-test-describe-package ()
|
||||
"Test displaying help for a package."
|
||||
|
||||
(require 'finder-inf)
|
||||
;; Built-in
|
||||
(with-fake-help-buffer
|
||||
(describe-package '5x5)
|
||||
(goto-char (point-min))
|
||||
(should (search-forward "5x5 is a built-in package." nil t))
|
||||
;; Don't assume the descriptions are in any particular order.
|
||||
(save-excursion (should (search-forward "Status: Built-in." nil t)))
|
||||
(save-excursion (should (search-forward "Summary: simple little puzzle game" nil t)))
|
||||
(should (search-forward "The aim of 5x5" nil t)))
|
||||
|
||||
;; Installed
|
||||
(with-package-test ()
|
||||
(package-initialize)
|
||||
(package-refresh-contents)
|
||||
(package-install 'simple-single)
|
||||
(with-fake-help-buffer
|
||||
(describe-package 'simple-single)
|
||||
(goto-char (point-min))
|
||||
(should (search-forward "simple-single is an installed package." nil t))
|
||||
(save-excursion (should (re-search-forward "Status: Installed in ['`‘]simple-single-1.3/['’] (unsigned)." nil t)))
|
||||
(save-excursion (should (search-forward "Version: 1.3" nil t)))
|
||||
(save-excursion (should (search-forward "Summary: A single-file package with no dependencies" nil t)))
|
||||
(save-excursion (should (search-forward "Homepage: http://doodles.au" nil t)))
|
||||
(save-excursion (should (re-search-forward "Keywords: \\[?frobnicate\\]?" nil t)))
|
||||
;; No description, though. Because at this point we don't know
|
||||
;; what archive the package originated from, and we don't have
|
||||
;; its readme file saved.
|
||||
)))
|
||||
|
||||
(ert-deftest package-test-describe-non-installed-package ()
|
||||
"Test displaying of the readme for non-installed package."
|
||||
|
||||
(with-package-test ()
|
||||
(package-initialize)
|
||||
(package-refresh-contents)
|
||||
(with-fake-help-buffer
|
||||
(describe-package 'simple-single)
|
||||
(goto-char (point-min))
|
||||
(should (search-forward "Homepage: http://doodles.au" nil t))
|
||||
(should (search-forward "This package provides a minor mode to frobnicate"
|
||||
nil t)))))
|
||||
|
||||
(ert-deftest package-test-describe-non-installed-multi-file-package ()
|
||||
"Test displaying of the readme for non-installed multi-file package."
|
||||
|
||||
(with-package-test ()
|
||||
(package-initialize)
|
||||
(package-refresh-contents)
|
||||
(with-fake-help-buffer
|
||||
(describe-package 'multi-file)
|
||||
(goto-char (point-min))
|
||||
(should (search-forward "Homepage: http://puddles.li" nil t))
|
||||
(should (search-forward "This is a bare-bones readme file for the multi-file"
|
||||
nil t)))))
|
||||
|
||||
(ert-deftest package-test-signed ()
|
||||
"Test verifying package signature."
|
||||
(skip-unless (ignore-errors
|
||||
(let ((homedir (make-temp-file "package-test" t)))
|
||||
(unwind-protect
|
||||
(let ((process-environment
|
||||
(cons (format "HOME=%s" homedir)
|
||||
process-environment)))
|
||||
(epg-check-configuration (epg-configuration))
|
||||
t)
|
||||
(delete-directory homedir t)))))
|
||||
(let* ((keyring (expand-file-name "key.pub" package-test-data-dir))
|
||||
(package-test-data-dir
|
||||
(expand-file-name "data/package/signed" package-test-file-dir)))
|
||||
(with-package-test ()
|
||||
(package-initialize)
|
||||
(package-import-keyring keyring)
|
||||
(package-refresh-contents)
|
||||
(should (package-install 'signed-good))
|
||||
(should-error (package-install 'signed-bad))
|
||||
;; Check if the installed package status is updated.
|
||||
(let ((buf (package-list-packages)))
|
||||
(package-menu-refresh)
|
||||
(should (re-search-forward
|
||||
"^\\s-+signed-good\\s-+\\(\\S-+\\)\\s-+\\(\\S-+\\)\\s-"
|
||||
nil t))
|
||||
(should (string-equal (match-string-no-properties 1) "1.0"))
|
||||
(should (string-equal (match-string-no-properties 2) "installed")))
|
||||
;; Check if the package description is updated.
|
||||
(with-fake-help-buffer
|
||||
(describe-package 'signed-good)
|
||||
(goto-char (point-min))
|
||||
(should (re-search-forward "signed-good is an? \\(\\S-+\\) package." nil t))
|
||||
(should (string-equal (match-string-no-properties 1) "installed"))
|
||||
(should (re-search-forward
|
||||
"Status: Installed in ['`‘]signed-good-1.0/['’]."
|
||||
nil t))))))
|
||||
|
||||
|
||||
|
||||
;;; Tests for package-x features.
|
||||
|
||||
(require 'package-x)
|
||||
|
||||
(defvar package-x-test--single-archive-entry-1-3
|
||||
(cons 'simple-single
|
||||
(package-make-ac-desc '(1 3) nil
|
||||
"A single-file package with no dependencies"
|
||||
'single
|
||||
'((:authors ("J. R. Hacker" . "jrh@example.com"))
|
||||
(:maintainer "J. R. Hacker" . "jrh@example.com")
|
||||
(:url . "http://doodles.au"))))
|
||||
"Expected contents of the archive entry from the \"simple-single\" package.")
|
||||
|
||||
(defvar package-x-test--single-archive-entry-1-4
|
||||
(cons 'simple-single
|
||||
(package-make-ac-desc '(1 4) nil
|
||||
"A single-file package with no dependencies"
|
||||
'single
|
||||
'((:authors ("J. R. Hacker" . "jrh@example.com"))
|
||||
(:maintainer "J. R. Hacker" . "jrh@example.com"))))
|
||||
"Expected contents of the archive entry from the updated \"simple-single\" package.")
|
||||
|
||||
(ert-deftest package-x-test-upload-buffer ()
|
||||
"Test creating an \"archive-contents\" file"
|
||||
(with-package-test (:basedir "data/package"
|
||||
:file "simple-single-1.3.el"
|
||||
:upload-base t)
|
||||
(package-upload-buffer)
|
||||
(should (file-exists-p (expand-file-name "archive-contents"
|
||||
package-archive-upload-base)))
|
||||
(should (file-exists-p (expand-file-name "simple-single-1.3.el"
|
||||
package-archive-upload-base)))
|
||||
(should (file-exists-p (expand-file-name "simple-single-readme.txt"
|
||||
package-archive-upload-base)))
|
||||
|
||||
(let (archive-contents)
|
||||
(with-temp-buffer
|
||||
(insert-file-contents
|
||||
(expand-file-name "archive-contents"
|
||||
package-archive-upload-base))
|
||||
(setq archive-contents
|
||||
(package-read-from-string
|
||||
(buffer-substring (point-min) (point-max)))))
|
||||
(should (equal archive-contents
|
||||
(list 1 package-x-test--single-archive-entry-1-3))))))
|
||||
|
||||
(ert-deftest package-x-test-upload-new-version ()
|
||||
"Test uploading a new version of a package"
|
||||
(with-package-test (:basedir "data/package"
|
||||
:file "simple-single-1.3.el"
|
||||
:upload-base t)
|
||||
(package-upload-buffer)
|
||||
(with-temp-buffer
|
||||
(insert-file-contents "newer-versions/simple-single-1.4.el")
|
||||
(package-upload-buffer))
|
||||
|
||||
(let (archive-contents)
|
||||
(with-temp-buffer
|
||||
(insert-file-contents
|
||||
(expand-file-name "archive-contents"
|
||||
package-archive-upload-base))
|
||||
(setq archive-contents
|
||||
(package-read-from-string
|
||||
(buffer-substring (point-min) (point-max)))))
|
||||
(should (equal archive-contents
|
||||
(list 1 package-x-test--single-archive-entry-1-4))))))
|
||||
|
||||
(ert-deftest package-test-get-deps ()
|
||||
"Test `package--get-deps' with complex structures."
|
||||
(let ((package-alist
|
||||
(mapcar (lambda (p) (list (package-desc-name p) p))
|
||||
(list simple-single-desc
|
||||
simple-depend-desc
|
||||
multi-file-desc
|
||||
new-pkg-desc
|
||||
simple-depend-desc-1
|
||||
simple-depend-desc-2))))
|
||||
(should
|
||||
(equal (package--get-deps 'simple-depend)
|
||||
'(simple-single)))
|
||||
(should
|
||||
(equal (package--get-deps 'simple-depend 'indirect)
|
||||
nil))
|
||||
(should
|
||||
(equal (package--get-deps 'simple-depend 'direct)
|
||||
'(simple-single)))
|
||||
(should
|
||||
(equal (package--get-deps 'simple-depend-2)
|
||||
'(simple-depend-1 multi-file simple-depend simple-single)))
|
||||
(should
|
||||
(equal (package--get-deps 'simple-depend-2 'indirect)
|
||||
'(simple-depend multi-file simple-single)))
|
||||
(should
|
||||
(equal (package--get-deps 'simple-depend-2 'direct)
|
||||
'(simple-depend-1 multi-file)))))
|
||||
|
||||
(ert-deftest package-test-sort-by-dependence ()
|
||||
"Test `package--sort-by-dependence' with complex structures."
|
||||
(let ((package-alist
|
||||
(mapcar (lambda (p) (list (package-desc-name p) p))
|
||||
(list simple-single-desc
|
||||
simple-depend-desc
|
||||
multi-file-desc
|
||||
new-pkg-desc
|
||||
simple-depend-desc-1
|
||||
simple-depend-desc-2)))
|
||||
(delete-list
|
||||
(list simple-single-desc
|
||||
simple-depend-desc
|
||||
multi-file-desc
|
||||
new-pkg-desc
|
||||
simple-depend-desc-1
|
||||
simple-depend-desc-2)))
|
||||
(should
|
||||
(equal (package--sort-by-dependence delete-list)
|
||||
(list simple-depend-desc-2 simple-depend-desc-1 new-pkg-desc
|
||||
multi-file-desc simple-depend-desc simple-single-desc)))
|
||||
(should
|
||||
(equal (package--sort-by-dependence (reverse delete-list))
|
||||
(list new-pkg-desc simple-depend-desc-2 simple-depend-desc-1
|
||||
multi-file-desc simple-depend-desc simple-single-desc)))))
|
||||
|
||||
(provide 'package-test)
|
||||
|
||||
;;; package-test.el ends here
|
||||
74
test/lisp/emacs-lisp/pcase-tests.el
Normal file
74
test/lisp/emacs-lisp/pcase-tests.el
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
;;; pcase-tests.el --- Test suite for pcase macro.
|
||||
|
||||
;; Copyright (C) 2012-2015 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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'cl-lib)
|
||||
|
||||
(ert-deftest pcase-tests-base ()
|
||||
"Test pcase code."
|
||||
(should (equal (pcase '(1 . 2) ((app car '2) 6) ((app car '1) 5)) 5)))
|
||||
|
||||
(ert-deftest pcase-tests-bugs ()
|
||||
(should (equal (pcase '(2 . 3) ;bug#18554
|
||||
(`(,hd . ,(and (pred atom) tl)) (list hd tl))
|
||||
((pred consp) nil))
|
||||
'(2 3))))
|
||||
|
||||
(pcase-defmacro pcase-tests-plus (pat n)
|
||||
`(app (lambda (v) (- v ,n)) ,pat))
|
||||
|
||||
(ert-deftest pcase-tests-macro ()
|
||||
(should (equal (pcase 5 ((pcase-tests-plus x 3) x)) 2)))
|
||||
|
||||
(defun pcase-tests-grep (fname exp)
|
||||
(when (consp exp)
|
||||
(or (eq fname (car exp))
|
||||
(cl-some (lambda (exp) (pcase-tests-grep fname exp)) (cdr exp)))))
|
||||
|
||||
(ert-deftest pcase-tests-tests ()
|
||||
(should (pcase-tests-grep 'memq '(or (+ 2 3) (memq x y))))
|
||||
(should-not (pcase-tests-grep 'memq '(or (+ 2 3) (- x y)))))
|
||||
|
||||
(ert-deftest pcase-tests-member ()
|
||||
(should (pcase-tests-grep
|
||||
'memq (macroexpand-all '(pcase x ((or 1 2 3) body)))))
|
||||
(should (pcase-tests-grep
|
||||
'member (macroexpand-all '(pcase x ((or '"a" '2 '3) body)))))
|
||||
(should-not (pcase-tests-grep
|
||||
'memq (macroexpand-all '(pcase x ((or "a" 2 3) body)))))
|
||||
(let ((exp (macroexpand-all
|
||||
'(pcase x
|
||||
("a" body1)
|
||||
(2 body2)
|
||||
((or "a" 2 3) body)))))
|
||||
(should-not (pcase-tests-grep 'memq exp))
|
||||
(should-not (pcase-tests-grep 'member exp))))
|
||||
|
||||
(ert-deftest pcase-tests-vectors ()
|
||||
(should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3)))
|
||||
|
||||
;; Local Variables:
|
||||
;; no-byte-compile: t
|
||||
;; End:
|
||||
|
||||
;;; pcase-tests.el ends here.
|
||||
33
test/lisp/emacs-lisp/regexp-opt-tests.el
Normal file
33
test/lisp/emacs-lisp/regexp-opt-tests.el
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
;;; regexp-tests.el --- Test suite for regular expression handling.
|
||||
|
||||
;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
;; Keywords: internal
|
||||
;; Human-Keywords: internal
|
||||
|
||||
;; 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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'regexp-opt)
|
||||
|
||||
(ert-deftest regexp-test-regexp-opt ()
|
||||
"Test the `compilation-error-regexp-alist' regexps.
|
||||
The test data is in `compile-tests--test-regexps-data'."
|
||||
(should (string-match (regexp-opt-charset '(?^)) "a^b")))
|
||||
|
||||
;;; regexp-tests.el ends here.
|
||||
341
test/lisp/emacs-lisp/seq-tests.el
Normal file
341
test/lisp/emacs-lisp/seq-tests.el
Normal file
|
|
@ -0,0 +1,341 @@
|
|||
;;; seq-tests.el --- Tests for sequences.el
|
||||
|
||||
;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Nicolas Petton <nicolas@petton.fr>
|
||||
;; Maintainer: emacs-devel@gnu.org
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Tests for sequences.el
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'seq)
|
||||
|
||||
(defmacro with-test-sequences (spec &rest body)
|
||||
"Successively bind VAR to a list, vector, and string built from SEQ.
|
||||
Evaluate BODY for each created sequence.
|
||||
|
||||
\(fn (var seq) body)"
|
||||
(declare (indent 1) (debug ((symbolp form) body)))
|
||||
(let ((initial-seq (make-symbol "initial-seq")))
|
||||
`(let ((,initial-seq ,(cadr spec)))
|
||||
,@(mapcar (lambda (s)
|
||||
`(let ((,(car spec) (apply (function ,s) ,initial-seq)))
|
||||
,@body))
|
||||
'(list vector string)))))
|
||||
|
||||
(defun same-contents-p (seq1 seq2)
|
||||
"Return t if SEQ1 and SEQ2 have the same contents, nil otherwise."
|
||||
(equal (append seq1 '()) (append seq2 '())))
|
||||
|
||||
(defun test-sequences-evenp (integer)
|
||||
"Return t if INTEGER is even."
|
||||
(eq (logand integer 1) 0))
|
||||
|
||||
(defun test-sequences-oddp (integer)
|
||||
"Return t if INTEGER is odd."
|
||||
(not (test-sequences-evenp integer)))
|
||||
|
||||
(ert-deftest test-setf-seq-elt ()
|
||||
(with-test-sequences (seq '(1 2 3))
|
||||
(setf (seq-elt seq 1) 4)
|
||||
(should (= 4 (seq-elt seq 1)))))
|
||||
|
||||
(ert-deftest test-seq-drop ()
|
||||
(with-test-sequences (seq '(1 2 3 4))
|
||||
(should (equal (seq-drop seq 0) seq))
|
||||
(should (equal (seq-drop seq 1) (seq-subseq seq 1)))
|
||||
(should (equal (seq-drop seq 2) (seq-subseq seq 2)))
|
||||
(should (seq-empty-p (seq-drop seq 4)))
|
||||
(should (seq-empty-p (seq-drop seq 10))))
|
||||
(with-test-sequences (seq '())
|
||||
(should (seq-empty-p (seq-drop seq 0)))
|
||||
(should (seq-empty-p (seq-drop seq 1)))))
|
||||
|
||||
(ert-deftest test-seq-take ()
|
||||
(with-test-sequences (seq '(2 3 4 5))
|
||||
(should (seq-empty-p (seq-take seq 0)))
|
||||
(should (= (seq-length (seq-take seq 1)) 1))
|
||||
(should (= (seq-elt (seq-take seq 1) 0) 2))
|
||||
(should (same-contents-p (seq-take seq 3) '(2 3 4)))
|
||||
(should (equal (seq-take seq 10) seq))))
|
||||
|
||||
(ert-deftest test-seq-drop-while ()
|
||||
(with-test-sequences (seq '(1 3 2 4))
|
||||
(should (equal (seq-drop-while #'test-sequences-oddp seq)
|
||||
(seq-drop seq 2)))
|
||||
(should (equal (seq-drop-while #'test-sequences-evenp seq)
|
||||
seq))
|
||||
(should (seq-empty-p (seq-drop-while #'numberp seq))))
|
||||
(with-test-sequences (seq '())
|
||||
(should (seq-empty-p (seq-drop-while #'test-sequences-oddp seq)))))
|
||||
|
||||
(ert-deftest test-seq-take-while ()
|
||||
(with-test-sequences (seq '(1 3 2 4))
|
||||
(should (equal (seq-take-while #'test-sequences-oddp seq)
|
||||
(seq-take seq 2)))
|
||||
(should (seq-empty-p (seq-take-while #'test-sequences-evenp seq)))
|
||||
(should (equal (seq-take-while #'numberp seq) seq)))
|
||||
(with-test-sequences (seq '())
|
||||
(should (seq-empty-p (seq-take-while #'test-sequences-oddp seq)))))
|
||||
|
||||
(ert-deftest test-seq-filter ()
|
||||
(with-test-sequences (seq '(6 7 8 9 10))
|
||||
(should (equal (seq-filter #'test-sequences-evenp seq) '(6 8 10)))
|
||||
(should (equal (seq-filter #'test-sequences-oddp seq) '(7 9)))
|
||||
(should (equal (seq-filter (lambda (elt) nil) seq) '())))
|
||||
(with-test-sequences (seq '())
|
||||
(should (equal (seq-filter #'test-sequences-evenp seq) '()))))
|
||||
|
||||
(ert-deftest test-seq-remove ()
|
||||
(with-test-sequences (seq '(6 7 8 9 10))
|
||||
(should (equal (seq-remove #'test-sequences-evenp seq) '(7 9)))
|
||||
(should (equal (seq-remove #'test-sequences-oddp seq) '(6 8 10)))
|
||||
(should (same-contents-p (seq-remove (lambda (elt) nil) seq) seq)))
|
||||
(with-test-sequences (seq '())
|
||||
(should (equal (seq-remove #'test-sequences-evenp seq) '()))))
|
||||
|
||||
(ert-deftest test-seq-count ()
|
||||
(with-test-sequences (seq '(6 7 8 9 10))
|
||||
(should (equal (seq-count #'test-sequences-evenp seq) 3))
|
||||
(should (equal (seq-count #'test-sequences-oddp seq) 2))
|
||||
(should (equal (seq-count (lambda (elt) nil) seq) 0)))
|
||||
(with-test-sequences (seq '())
|
||||
(should (equal (seq-count #'test-sequences-evenp seq) 0))))
|
||||
|
||||
(ert-deftest test-seq-reduce ()
|
||||
(with-test-sequences (seq '(1 2 3 4))
|
||||
(should (= (seq-reduce #'+ seq 0) 10))
|
||||
(should (= (seq-reduce #'+ seq 5) 15)))
|
||||
(with-test-sequences (seq '())
|
||||
(should (eq (seq-reduce #'+ seq 0) 0))
|
||||
(should (eq (seq-reduce #'+ seq 7) 7))))
|
||||
|
||||
(ert-deftest test-seq-some ()
|
||||
(with-test-sequences (seq '(4 3 2 1))
|
||||
(should (seq-some #'test-sequences-evenp seq))
|
||||
(should (seq-some #'test-sequences-oddp seq))
|
||||
(should-not (seq-some (lambda (elt) (> elt 10)) seq)))
|
||||
(with-test-sequences (seq '())
|
||||
(should-not (seq-some #'test-sequences-oddp seq)))
|
||||
(should (seq-some #'null '(1 nil 2))))
|
||||
|
||||
(ert-deftest test-seq-find ()
|
||||
(with-test-sequences (seq '(4 3 2 1))
|
||||
(should (= 4 (seq-find #'test-sequences-evenp seq)))
|
||||
(should (= 3 (seq-find #'test-sequences-oddp seq)))
|
||||
(should-not (seq-find (lambda (elt) (> elt 10)) seq)))
|
||||
(should-not (seq-find #'null '(1 nil 2)))
|
||||
(should-not (seq-find #'null '(1 nil 2) t))
|
||||
(should-not (seq-find #'null '(1 2 3)))
|
||||
(should (seq-find #'null '(1 2 3) 'sentinel)))
|
||||
|
||||
(ert-deftest test-seq-contains ()
|
||||
(with-test-sequences (seq '(3 4 5 6))
|
||||
(should (seq-contains seq 3))
|
||||
(should-not (seq-contains seq 7)))
|
||||
(with-test-sequences (seq '())
|
||||
(should-not (seq-contains seq 3))
|
||||
(should-not (seq-contains seq nil))))
|
||||
|
||||
(ert-deftest test-seq-every-p ()
|
||||
(with-test-sequences (seq '(43 54 22 1))
|
||||
(should (seq-every-p (lambda (elt) t) seq))
|
||||
(should-not (seq-every-p #'test-sequences-oddp seq))
|
||||
(should-not (seq-every-p #'test-sequences-evenp seq)))
|
||||
(with-test-sequences (seq '(42 54 22 2))
|
||||
(should (seq-every-p #'test-sequences-evenp seq))
|
||||
(should-not (seq-every-p #'test-sequences-oddp seq)))
|
||||
(with-test-sequences (seq '())
|
||||
(should (seq-every-p #'identity seq))
|
||||
(should (seq-every-p #'test-sequences-evenp seq))))
|
||||
|
||||
(ert-deftest test-seq-empty-p ()
|
||||
(with-test-sequences (seq '(0))
|
||||
(should-not (seq-empty-p seq)))
|
||||
(with-test-sequences (seq '(0 1 2))
|
||||
(should-not (seq-empty-p seq)))
|
||||
(with-test-sequences (seq '())
|
||||
(should (seq-empty-p seq))))
|
||||
|
||||
(ert-deftest test-seq-sort ()
|
||||
(should (equal (seq-sort #'< "cbaf") "abcf"))
|
||||
(should (equal (seq-sort #'< '(2 1 9 4)) '(1 2 4 9)))
|
||||
(should (equal (seq-sort #'< [2 1 9 4]) [1 2 4 9]))
|
||||
(should (equal (seq-sort #'< "") "")))
|
||||
|
||||
(ert-deftest test-seq-uniq ()
|
||||
(with-test-sequences (seq '(2 4 6 8 6 4 3))
|
||||
(should (equal (seq-uniq seq) '(2 4 6 8 3))))
|
||||
(with-test-sequences (seq '(3 3 3 3 3))
|
||||
(should (equal (seq-uniq seq) '(3))))
|
||||
(with-test-sequences (seq '())
|
||||
(should (equal (seq-uniq seq) '()))))
|
||||
|
||||
(ert-deftest test-seq-subseq ()
|
||||
(with-test-sequences (seq '(2 3 4 5))
|
||||
(should (equal (seq-subseq seq 0 4) seq))
|
||||
(should (same-contents-p (seq-subseq seq 2 4) '(4 5)))
|
||||
(should (same-contents-p (seq-subseq seq 1 3) '(3 4)))
|
||||
(should (same-contents-p (seq-subseq seq 1 -1) '(3 4))))
|
||||
(should (vectorp (seq-subseq [2 3 4 5] 2)))
|
||||
(should (stringp (seq-subseq "foo" 2 3)))
|
||||
(should (listp (seq-subseq '(2 3 4 4) 2 3)))
|
||||
(should-error (seq-subseq '(1 2 3) 4))
|
||||
(should-not (seq-subseq '(1 2 3) 3))
|
||||
(should (seq-subseq '(1 2 3) -3))
|
||||
(should-error (seq-subseq '(1 2 3) 1 4))
|
||||
(should (seq-subseq '(1 2 3) 1 3))
|
||||
(should-error (seq-subseq '() -1))
|
||||
(should-error (seq-subseq [] -1))
|
||||
(should-error (seq-subseq "" -1))
|
||||
(should-not (seq-subseq '() 0))
|
||||
(should-error (seq-subseq '() 0 -1)))
|
||||
|
||||
(ert-deftest test-seq-concatenate ()
|
||||
(with-test-sequences (seq '(2 4 6))
|
||||
(should (equal (seq-concatenate 'string seq [8]) (string 2 4 6 8)))
|
||||
(should (equal (seq-concatenate 'list seq '(8 10)) '(2 4 6 8 10)))
|
||||
(should (equal (seq-concatenate 'vector seq '(8 10)) [2 4 6 8 10]))
|
||||
(should (equal (seq-concatenate 'vector nil '(8 10)) [8 10]))
|
||||
(should (equal (seq-concatenate 'vector seq nil) [2 4 6]))))
|
||||
|
||||
(ert-deftest test-seq-mapcat ()
|
||||
(should (equal (seq-mapcat #'seq-reverse '((3 2 1) (6 5 4)))
|
||||
'(1 2 3 4 5 6)))
|
||||
(should (equal (seq-mapcat #'seq-reverse '[(3 2 1) (6 5 4)])
|
||||
'(1 2 3 4 5 6)))
|
||||
(should (equal (seq-mapcat #'seq-reverse '((3 2 1) (6 5 4)) 'vector)
|
||||
'[1 2 3 4 5 6])))
|
||||
|
||||
(ert-deftest test-seq-partition ()
|
||||
(should (same-contents-p (seq-partition '(0 1 2 3 4 5 6 7) 3)
|
||||
'((0 1 2) (3 4 5) (6 7))))
|
||||
(should (same-contents-p (seq-partition '[0 1 2 3 4 5 6 7] 3)
|
||||
'([0 1 2] [3 4 5] [6 7])))
|
||||
(should (same-contents-p (seq-partition "Hello world" 2)
|
||||
'("He" "ll" "o " "wo" "rl" "d")))
|
||||
(should (equal (seq-partition '() 2) '()))
|
||||
(should (equal (seq-partition '(1 2 3) -1) '())))
|
||||
|
||||
(ert-deftest test-seq-group-by ()
|
||||
(with-test-sequences (seq '(1 2 3 4))
|
||||
(should (equal (seq-group-by #'test-sequences-oddp seq)
|
||||
'((t 1 3) (nil 2 4)))))
|
||||
(should (equal (seq-group-by #'car '((a 1) (b 3) (c 4) (a 2)))
|
||||
'((b (b 3)) (c (c 4)) (a (a 1) (a 2))))))
|
||||
|
||||
(ert-deftest test-seq-reverse ()
|
||||
(with-test-sequences (seq '(1 2 3 4))
|
||||
(should (same-contents-p (seq-reverse seq) '(4 3 2 1)))
|
||||
(should (equal (type-of (seq-reverse seq))
|
||||
(type-of seq)))))
|
||||
|
||||
(ert-deftest test-seq-into ()
|
||||
(let* ((vector [1 2 3])
|
||||
(list (seq-into vector 'list)))
|
||||
(should (same-contents-p vector list))
|
||||
(should (listp list)))
|
||||
(let* ((list '(hello world))
|
||||
(vector (seq-into list 'vector)))
|
||||
(should (same-contents-p vector list))
|
||||
(should (vectorp vector)))
|
||||
(let* ((string "hello")
|
||||
(list (seq-into string 'list)))
|
||||
(should (same-contents-p string list))
|
||||
(should (stringp string)))
|
||||
(let* ((string "hello")
|
||||
(vector (seq-into string 'vector)))
|
||||
(should (same-contents-p string vector))
|
||||
(should (stringp string)))
|
||||
(let* ((list nil)
|
||||
(vector (seq-into list 'vector)))
|
||||
(should (same-contents-p list vector))
|
||||
(should (vectorp vector))))
|
||||
|
||||
(ert-deftest test-seq-intersection ()
|
||||
(let ((v1 [2 3 4 5])
|
||||
(v2 [1 3 5 6 7]))
|
||||
(should (same-contents-p (seq-intersection v1 v2)
|
||||
'(3 5))))
|
||||
(let ((l1 '(2 3 4 5))
|
||||
(l2 '(1 3 5 6 7)))
|
||||
(should (same-contents-p (seq-intersection l1 l2)
|
||||
'(3 5))))
|
||||
(let ((v1 [2 4 6])
|
||||
(v2 [1 3 5]))
|
||||
(should (seq-empty-p (seq-intersection v1 v2)))))
|
||||
|
||||
(ert-deftest test-seq-difference ()
|
||||
(let ((v1 [2 3 4 5])
|
||||
(v2 [1 3 5 6 7]))
|
||||
(should (same-contents-p (seq-difference v1 v2)
|
||||
'(2 4))))
|
||||
(let ((l1 '(2 3 4 5))
|
||||
(l2 '(1 3 5 6 7)))
|
||||
(should (same-contents-p (seq-difference l1 l2)
|
||||
'(2 4))))
|
||||
(let ((v1 [2 4 6])
|
||||
(v2 [2 4 6]))
|
||||
(should (seq-empty-p (seq-difference v1 v2)))))
|
||||
|
||||
(ert-deftest test-seq-let ()
|
||||
(with-test-sequences (seq '(1 2 3 4))
|
||||
(seq-let (a b c d e) seq
|
||||
(should (= a 1))
|
||||
(should (= b 2))
|
||||
(should (= c 3))
|
||||
(should (= d 4))
|
||||
(should (null e)))
|
||||
(seq-let (a b &rest others) seq
|
||||
(should (= a 1))
|
||||
(should (= b 2))
|
||||
(should (same-contents-p others (seq-drop seq 2)))))
|
||||
(let ((seq '(1 (2 (3 (4))))))
|
||||
(seq-let (_ (_ (_ (a)))) seq
|
||||
(should (= a 4))))
|
||||
(let (seq)
|
||||
(seq-let (a b c) seq
|
||||
(should (null a))
|
||||
(should (null b))
|
||||
(should (null c)))))
|
||||
|
||||
(ert-deftest test-seq-min-max ()
|
||||
(with-test-sequences (seq '(4 5 3 2 0 4))
|
||||
(should (= (seq-min seq) 0))
|
||||
(should (= (seq-max seq) 5))))
|
||||
|
||||
(ert-deftest test-seq-into-sequence ()
|
||||
(with-test-sequences (seq '(1 2 3))
|
||||
(should (eq seq (seq-into-sequence seq)))
|
||||
(should-error (seq-into-sequence 2))))
|
||||
|
||||
(ert-deftest test-seq-position ()
|
||||
(with-test-sequences (seq '(2 4 6))
|
||||
(should (null (seq-position seq 1)))
|
||||
(should (= (seq-position seq 4) 1)))
|
||||
(let ((seq '(a b c)))
|
||||
(should (null (seq-position seq 'd #'eq)))
|
||||
(should (= (seq-position seq 'a #'eq) 0))
|
||||
(should (null (seq-position seq (make-symbol "a") #'eq)))))
|
||||
|
||||
(provide 'seq-tests)
|
||||
;;; seq-tests.el ends here
|
||||
526
test/lisp/emacs-lisp/subr-x-tests.el
Normal file
526
test/lisp/emacs-lisp/subr-x-tests.el
Normal file
|
|
@ -0,0 +1,526 @@
|
|||
;;; subr-x-tests.el --- Testing the extended lisp routines
|
||||
|
||||
;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Fabián E. Gallina <fgallina@gnu.org>
|
||||
;; Keywords:
|
||||
|
||||
;; 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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'subr-x)
|
||||
|
||||
|
||||
;; if-let tests
|
||||
|
||||
(ert-deftest subr-x-test-if-let-single-binding-expansion ()
|
||||
"Test single bindings are expanded properly."
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(if-let (a 1)
|
||||
(- a)
|
||||
"no"))
|
||||
'(let* ((a (and t 1)))
|
||||
(if a
|
||||
(- a)
|
||||
"no"))))
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(if-let (a)
|
||||
(- a)
|
||||
"no"))
|
||||
'(let* ((a (and t nil)))
|
||||
(if a
|
||||
(- a)
|
||||
"no")))))
|
||||
|
||||
(ert-deftest subr-x-test-if-let-single-symbol-expansion ()
|
||||
"Test single symbol bindings are expanded properly."
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(if-let (a)
|
||||
(- a)
|
||||
"no"))
|
||||
'(let* ((a (and t nil)))
|
||||
(if a
|
||||
(- a)
|
||||
"no"))))
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(if-let (a b c)
|
||||
(- a)
|
||||
"no"))
|
||||
'(let* ((a (and t nil))
|
||||
(b (and a nil))
|
||||
(c (and b nil)))
|
||||
(if c
|
||||
(- a)
|
||||
"no"))))
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(if-let (a (b 2) c)
|
||||
(- a)
|
||||
"no"))
|
||||
'(let* ((a (and t nil))
|
||||
(b (and a 2))
|
||||
(c (and b nil)))
|
||||
(if c
|
||||
(- a)
|
||||
"no")))))
|
||||
|
||||
(ert-deftest subr-x-test-if-let-nil-related-expansion ()
|
||||
"Test nil is processed properly."
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(if-let (nil)
|
||||
(- a)
|
||||
"no"))
|
||||
'(let* ((nil (and t nil)))
|
||||
(if nil
|
||||
(- a)
|
||||
"no"))))
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(if-let ((nil))
|
||||
(- a)
|
||||
"no"))
|
||||
'(let* ((nil (and t nil)))
|
||||
(if nil
|
||||
(- a)
|
||||
"no"))))
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(if-let ((a 1) (nil) (b 2))
|
||||
(- a)
|
||||
"no"))
|
||||
'(let* ((a (and t 1))
|
||||
(nil (and a nil))
|
||||
(b (and nil 2)))
|
||||
(if b
|
||||
(- a)
|
||||
"no"))))
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(if-let ((a 1) nil (b 2))
|
||||
(- a)
|
||||
"no"))
|
||||
'(let* ((a (and t 1))
|
||||
(nil (and a nil))
|
||||
(b (and nil 2)))
|
||||
(if b
|
||||
(- a)
|
||||
"no")))))
|
||||
|
||||
(ert-deftest subr-x-test-if-let-malformed-binding ()
|
||||
"Test malformed bindings trigger errors."
|
||||
(should-error (macroexpand
|
||||
'(if-let (_ (a 1 1) (b 2) (c 3) d)
|
||||
(- a)
|
||||
"no"))
|
||||
:type 'error)
|
||||
(should-error (macroexpand
|
||||
'(if-let (_ (a 1) (b 2 2) (c 3) d)
|
||||
(- a)
|
||||
"no"))
|
||||
:type 'error)
|
||||
(should-error (macroexpand
|
||||
'(if-let (_ (a 1) (b 2) (c 3 3) d)
|
||||
(- a)
|
||||
"no"))
|
||||
:type 'error)
|
||||
(should-error (macroexpand
|
||||
'(if-let ((a 1 1))
|
||||
(- a)
|
||||
"no"))
|
||||
:type 'error))
|
||||
|
||||
(ert-deftest subr-x-test-if-let-true ()
|
||||
"Test `if-let' with truthy bindings."
|
||||
(should (equal
|
||||
(if-let (a 1)
|
||||
a
|
||||
"no")
|
||||
1))
|
||||
(should (equal
|
||||
(if-let ((a 1) (b 2) (c 3))
|
||||
(list a b c)
|
||||
"no")
|
||||
(list 1 2 3))))
|
||||
|
||||
(ert-deftest subr-x-test-if-let-false ()
|
||||
"Test `if-let' with falsie bindings."
|
||||
(should (equal
|
||||
(if-let (a nil)
|
||||
(list a b c)
|
||||
"no")
|
||||
"no"))
|
||||
(should (equal
|
||||
(if-let ((a nil) (b 2) (c 3))
|
||||
(list a b c)
|
||||
"no")
|
||||
"no"))
|
||||
(should (equal
|
||||
(if-let ((a 1) (b nil) (c 3))
|
||||
(list a b c)
|
||||
"no")
|
||||
"no"))
|
||||
(should (equal
|
||||
(if-let ((a 1) (b 2) (c nil))
|
||||
(list a b c)
|
||||
"no")
|
||||
"no"))
|
||||
(should (equal
|
||||
(if-let (z (a 1) (b 2) (c 3))
|
||||
(list a b c)
|
||||
"no")
|
||||
"no"))
|
||||
(should (equal
|
||||
(if-let ((a 1) (b 2) (c 3) d)
|
||||
(list a b c)
|
||||
"no")
|
||||
"no")))
|
||||
|
||||
(ert-deftest subr-x-test-if-let-bound-references ()
|
||||
"Test `if-let' bindings can refer to already bound symbols."
|
||||
(should (equal
|
||||
(if-let ((a (1+ 0)) (b (1+ a)) (c (1+ b)))
|
||||
(list a b c)
|
||||
"no")
|
||||
(list 1 2 3))))
|
||||
|
||||
(ert-deftest subr-x-test-if-let-and-laziness-is-preserved ()
|
||||
"Test `if-let' respects `and' laziness."
|
||||
(let (a-called b-called c-called)
|
||||
(should (equal
|
||||
(if-let ((a nil)
|
||||
(b (setq b-called t))
|
||||
(c (setq c-called t)))
|
||||
"yes"
|
||||
(list a-called b-called c-called))
|
||||
(list nil nil nil))))
|
||||
(let (a-called b-called c-called)
|
||||
(should (equal
|
||||
(if-let ((a (setq a-called t))
|
||||
(b nil)
|
||||
(c (setq c-called t)))
|
||||
"yes"
|
||||
(list a-called b-called c-called))
|
||||
(list t nil nil))))
|
||||
(let (a-called b-called c-called)
|
||||
(should (equal
|
||||
(if-let ((a (setq a-called t))
|
||||
(b (setq b-called t))
|
||||
(c nil)
|
||||
(d (setq c-called t)))
|
||||
"yes"
|
||||
(list a-called b-called c-called))
|
||||
(list t t nil)))))
|
||||
|
||||
|
||||
;; when-let tests
|
||||
|
||||
(ert-deftest subr-x-test-when-let-body-expansion ()
|
||||
"Test body allows for multiple sexps wrapping with progn."
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(when-let (a 1)
|
||||
(message "opposite")
|
||||
(- a)))
|
||||
'(let* ((a (and t 1)))
|
||||
(if a
|
||||
(progn
|
||||
(message "opposite")
|
||||
(- a)))))))
|
||||
|
||||
(ert-deftest subr-x-test-when-let-single-binding-expansion ()
|
||||
"Test single bindings are expanded properly."
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(when-let (a 1)
|
||||
(- a)))
|
||||
'(let* ((a (and t 1)))
|
||||
(if a
|
||||
(- a)))))
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(when-let (a)
|
||||
(- a)))
|
||||
'(let* ((a (and t nil)))
|
||||
(if a
|
||||
(- a))))))
|
||||
|
||||
(ert-deftest subr-x-test-when-let-single-symbol-expansion ()
|
||||
"Test single symbol bindings are expanded properly."
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(when-let (a)
|
||||
(- a)))
|
||||
'(let* ((a (and t nil)))
|
||||
(if a
|
||||
(- a)))))
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(when-let (a b c)
|
||||
(- a)))
|
||||
'(let* ((a (and t nil))
|
||||
(b (and a nil))
|
||||
(c (and b nil)))
|
||||
(if c
|
||||
(- a)))))
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(when-let (a (b 2) c)
|
||||
(- a)))
|
||||
'(let* ((a (and t nil))
|
||||
(b (and a 2))
|
||||
(c (and b nil)))
|
||||
(if c
|
||||
(- a))))))
|
||||
|
||||
(ert-deftest subr-x-test-when-let-nil-related-expansion ()
|
||||
"Test nil is processed properly."
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(when-let (nil)
|
||||
(- a)))
|
||||
'(let* ((nil (and t nil)))
|
||||
(if nil
|
||||
(- a)))))
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(when-let ((nil))
|
||||
(- a)))
|
||||
'(let* ((nil (and t nil)))
|
||||
(if nil
|
||||
(- a)))))
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(when-let ((a 1) (nil) (b 2))
|
||||
(- a)))
|
||||
'(let* ((a (and t 1))
|
||||
(nil (and a nil))
|
||||
(b (and nil 2)))
|
||||
(if b
|
||||
(- a)))))
|
||||
(should (equal
|
||||
(macroexpand
|
||||
'(when-let ((a 1) nil (b 2))
|
||||
(- a)))
|
||||
'(let* ((a (and t 1))
|
||||
(nil (and a nil))
|
||||
(b (and nil 2)))
|
||||
(if b
|
||||
(- a))))))
|
||||
|
||||
(ert-deftest subr-x-test-when-let-malformed-binding ()
|
||||
"Test malformed bindings trigger errors."
|
||||
(should-error (macroexpand
|
||||
'(when-let (_ (a 1 1) (b 2) (c 3) d)
|
||||
(- a)))
|
||||
:type 'error)
|
||||
(should-error (macroexpand
|
||||
'(when-let (_ (a 1) (b 2 2) (c 3) d)
|
||||
(- a)))
|
||||
:type 'error)
|
||||
(should-error (macroexpand
|
||||
'(when-let (_ (a 1) (b 2) (c 3 3) d)
|
||||
(- a)))
|
||||
:type 'error)
|
||||
(should-error (macroexpand
|
||||
'(when-let ((a 1 1))
|
||||
(- a)))
|
||||
:type 'error))
|
||||
|
||||
(ert-deftest subr-x-test-when-let-true ()
|
||||
"Test `when-let' with truthy bindings."
|
||||
(should (equal
|
||||
(when-let (a 1)
|
||||
a)
|
||||
1))
|
||||
(should (equal
|
||||
(when-let ((a 1) (b 2) (c 3))
|
||||
(list a b c))
|
||||
(list 1 2 3))))
|
||||
|
||||
(ert-deftest subr-x-test-when-let-false ()
|
||||
"Test `when-let' with falsie bindings."
|
||||
(should (equal
|
||||
(when-let (a nil)
|
||||
(list a b c)
|
||||
"no")
|
||||
nil))
|
||||
(should (equal
|
||||
(when-let ((a nil) (b 2) (c 3))
|
||||
(list a b c)
|
||||
"no")
|
||||
nil))
|
||||
(should (equal
|
||||
(when-let ((a 1) (b nil) (c 3))
|
||||
(list a b c)
|
||||
"no")
|
||||
nil))
|
||||
(should (equal
|
||||
(when-let ((a 1) (b 2) (c nil))
|
||||
(list a b c)
|
||||
"no")
|
||||
nil))
|
||||
(should (equal
|
||||
(when-let (z (a 1) (b 2) (c 3))
|
||||
(list a b c)
|
||||
"no")
|
||||
nil))
|
||||
(should (equal
|
||||
(when-let ((a 1) (b 2) (c 3) d)
|
||||
(list a b c)
|
||||
"no")
|
||||
nil)))
|
||||
|
||||
(ert-deftest subr-x-test-when-let-bound-references ()
|
||||
"Test `when-let' bindings can refer to already bound symbols."
|
||||
(should (equal
|
||||
(when-let ((a (1+ 0)) (b (1+ a)) (c (1+ b)))
|
||||
(list a b c))
|
||||
(list 1 2 3))))
|
||||
|
||||
(ert-deftest subr-x-test-when-let-and-laziness-is-preserved ()
|
||||
"Test `when-let' respects `and' laziness."
|
||||
(let (a-called b-called c-called)
|
||||
(should (equal
|
||||
(progn
|
||||
(when-let ((a nil)
|
||||
(b (setq b-called t))
|
||||
(c (setq c-called t)))
|
||||
"yes")
|
||||
(list a-called b-called c-called))
|
||||
(list nil nil nil))))
|
||||
(let (a-called b-called c-called)
|
||||
(should (equal
|
||||
(progn
|
||||
(when-let ((a (setq a-called t))
|
||||
(b nil)
|
||||
(c (setq c-called t)))
|
||||
"yes")
|
||||
(list a-called b-called c-called))
|
||||
(list t nil nil))))
|
||||
(let (a-called b-called c-called)
|
||||
(should (equal
|
||||
(progn
|
||||
(when-let ((a (setq a-called t))
|
||||
(b (setq b-called t))
|
||||
(c nil)
|
||||
(d (setq c-called t)))
|
||||
"yes")
|
||||
(list a-called b-called c-called))
|
||||
(list t t nil)))))
|
||||
|
||||
|
||||
;; Thread first tests
|
||||
|
||||
(ert-deftest subr-x-test-thread-first-no-forms ()
|
||||
"Test `thread-first' with no forms expands to the first form."
|
||||
(should (equal (macroexpand '(thread-first 5)) 5))
|
||||
(should (equal (macroexpand '(thread-first (+ 1 2))) '(+ 1 2))))
|
||||
|
||||
(ert-deftest subr-x-test-thread-first-function-names-are-threaded ()
|
||||
"Test `thread-first' wraps single function names."
|
||||
(should (equal (macroexpand
|
||||
'(thread-first 5
|
||||
-))
|
||||
'(- 5)))
|
||||
(should (equal (macroexpand
|
||||
'(thread-first (+ 1 2)
|
||||
-))
|
||||
'(- (+ 1 2)))))
|
||||
|
||||
(ert-deftest subr-x-test-thread-first-expansion ()
|
||||
"Test `thread-first' expands correctly."
|
||||
(should (equal
|
||||
(macroexpand '(thread-first
|
||||
5
|
||||
(+ 20)
|
||||
(/ 25)
|
||||
-
|
||||
(+ 40)))
|
||||
'(+ (- (/ (+ 5 20) 25)) 40))))
|
||||
|
||||
(ert-deftest subr-x-test-thread-first-examples ()
|
||||
"Test several `thread-first' examples."
|
||||
(should (equal (thread-first (+ 40 2)) 42))
|
||||
(should (equal (thread-first
|
||||
5
|
||||
(+ 20)
|
||||
(/ 25)
|
||||
-
|
||||
(+ 40)) 39))
|
||||
(should (equal (thread-first
|
||||
"this-is-a-string"
|
||||
(split-string "-")
|
||||
(nbutlast 2)
|
||||
(append (list "good")))
|
||||
(list "this" "is" "good"))))
|
||||
|
||||
;; Thread last tests
|
||||
|
||||
(ert-deftest subr-x-test-thread-last-no-forms ()
|
||||
"Test `thread-last' with no forms expands to the first form."
|
||||
(should (equal (macroexpand '(thread-last 5)) 5))
|
||||
(should (equal (macroexpand '(thread-last (+ 1 2))) '(+ 1 2))))
|
||||
|
||||
(ert-deftest subr-x-test-thread-last-function-names-are-threaded ()
|
||||
"Test `thread-last' wraps single function names."
|
||||
(should (equal (macroexpand
|
||||
'(thread-last 5
|
||||
-))
|
||||
'(- 5)))
|
||||
(should (equal (macroexpand
|
||||
'(thread-last (+ 1 2)
|
||||
-))
|
||||
'(- (+ 1 2)))))
|
||||
|
||||
(ert-deftest subr-x-test-thread-last-expansion ()
|
||||
"Test `thread-last' expands correctly."
|
||||
(should (equal
|
||||
(macroexpand '(thread-last
|
||||
5
|
||||
(+ 20)
|
||||
(/ 25)
|
||||
-
|
||||
(+ 40)))
|
||||
'(+ 40 (- (/ 25 (+ 20 5)))))))
|
||||
|
||||
(ert-deftest subr-x-test-thread-last-examples ()
|
||||
"Test several `thread-last' examples."
|
||||
(should (equal (thread-last (+ 40 2)) 42))
|
||||
(should (equal (thread-last
|
||||
5
|
||||
(+ 20)
|
||||
(/ 25)
|
||||
-
|
||||
(+ 40)) 39))
|
||||
(should (equal (thread-last
|
||||
(list 1 -2 3 -4 5)
|
||||
(mapcar #'abs)
|
||||
(cl-reduce #'+)
|
||||
(format "abs sum is: %s"))
|
||||
"abs sum is: 15")))
|
||||
|
||||
|
||||
(provide 'subr-x-tests)
|
||||
;;; subr-x-tests.el ends here
|
||||
118
test/lisp/emacs-lisp/tabulated-list-test.el
Normal file
118
test/lisp/emacs-lisp/tabulated-list-test.el
Normal file
|
|
@ -0,0 +1,118 @@
|
|||
;;; tabulated-list-test.el --- Tests for emacs-lisp/tabulated-list.el -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'tabulated-list)
|
||||
(require 'ert)
|
||||
|
||||
(defconst tabulated-list--test-entries
|
||||
'(("zzzz-game" ["zzzz-game" "zzzz-game" "2113" "installed" " play zzzz in Emacs"])
|
||||
("4clojure" ["4clojure" "4clojure" "1507" "obsolete" " Open and evaluate 4clojure.com questions"])
|
||||
("abc-mode" ["abc-mode" "abc-mode" "944" "available" " Major mode for editing abc music files"])
|
||||
("mode" ["mode" "mode" "1128" "installed" " A simple mode for editing Actionscript 3 files"])))
|
||||
|
||||
(defun tabulated-list--test-sort-car (a b)
|
||||
(string< (car a) (car b)))
|
||||
|
||||
(defconst tabulated-list--test-format
|
||||
[("name" 10 tabulated-list--test-sort-car)
|
||||
("name-2" 10 t)
|
||||
("Version" 9 nil)
|
||||
("Status" 10 )
|
||||
("Description" 0 nil)])
|
||||
|
||||
(defmacro tabulated-list--test-with-buffer (&rest body)
|
||||
`(with-temp-buffer
|
||||
(tabulated-list-mode)
|
||||
(setq tabulated-list-entries (copy-alist tabulated-list--test-entries))
|
||||
(setq tabulated-list-format tabulated-list--test-format)
|
||||
(setq tabulated-list-padding 7)
|
||||
(tabulated-list-init-header)
|
||||
(tabulated-list-print)
|
||||
,@body))
|
||||
|
||||
|
||||
;;; Tests
|
||||
(ert-deftest tabulated-list-print ()
|
||||
(tabulated-list--test-with-buffer
|
||||
;; Basic printing.
|
||||
(should (string= (buffer-substring-no-properties (point-min) (point-max))
|
||||
" zzzz-game zzzz-game 2113 installed play zzzz in Emacs
|
||||
4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions
|
||||
abc-mode abc-mode 944 available Major mode for editing abc music files
|
||||
mode mode 1128 installed A simple mode for editing Actionscript 3 files\n"))
|
||||
;; Preserve position.
|
||||
(forward-line 3)
|
||||
(let ((pos (thing-at-point 'line)))
|
||||
(pop tabulated-list-entries)
|
||||
(tabulated-list-print t)
|
||||
(should (equal (thing-at-point 'line) pos))
|
||||
(should (string= (buffer-substring-no-properties (point-min) (point-max))
|
||||
" 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions
|
||||
abc-mode abc-mode 944 available Major mode for editing abc music files
|
||||
mode mode 1128 installed A simple mode for editing Actionscript 3 files\n"))
|
||||
;; Check the UPDATE argument
|
||||
(pop tabulated-list-entries)
|
||||
(setf (cdr (car tabulated-list-entries)) (list ["x" "x" "944" "available" " XX"]))
|
||||
(tabulated-list-print t t)
|
||||
(should (string= (buffer-substring-no-properties (point-min) (point-max))
|
||||
" x x 944 available XX
|
||||
mode mode 1128 installed A simple mode for editing Actionscript 3 files\n"))
|
||||
(should (equal (thing-at-point 'line) pos)))))
|
||||
|
||||
(ert-deftest tabulated-list-sort ()
|
||||
(tabulated-list--test-with-buffer
|
||||
;; Basic sorting
|
||||
(goto-char (point-min))
|
||||
(skip-chars-forward "[:blank:]")
|
||||
(tabulated-list-sort)
|
||||
(let ((text (buffer-substring-no-properties (point-min) (point-max))))
|
||||
(should (string= text " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions
|
||||
abc-mode abc-mode 944 available Major mode for editing abc music files
|
||||
mode mode 1128 installed A simple mode for editing Actionscript 3 files
|
||||
zzzz-game zzzz-game 2113 installed play zzzz in Emacs\n"))
|
||||
|
||||
(skip-chars-forward "^[:blank:]")
|
||||
(skip-chars-forward "[:blank:]")
|
||||
(should (equal (get-text-property (point) 'tabulated-list-column-name)
|
||||
"name-2"))
|
||||
(tabulated-list-sort)
|
||||
;; Check a `t' as the sorting predicate.
|
||||
(should (string= text (buffer-substring-no-properties (point-min) (point-max))))
|
||||
;; Invert.
|
||||
(tabulated-list-sort 1)
|
||||
(should (string= (buffer-substring-no-properties (point-min) (point-max))
|
||||
" zzzz-game zzzz-game 2113 installed play zzzz in Emacs
|
||||
mode mode 1128 installed A simple mode for editing Actionscript 3 files
|
||||
abc-mode abc-mode 944 available Major mode for editing abc music files
|
||||
4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions\n"))
|
||||
;; Again
|
||||
(tabulated-list-sort 1)
|
||||
(should (string= text (buffer-substring-no-properties (point-min) (point-max)))))
|
||||
;; Check that you can't sort some cols.
|
||||
(skip-chars-forward "^[:blank:]")
|
||||
(skip-chars-forward "[:blank:]")
|
||||
(should-error (tabulated-list-sort) :type 'user-error)
|
||||
(should-error (tabulated-list-sort 4) :type 'user-error)))
|
||||
|
||||
(provide 'tabulated-list-test)
|
||||
;;; tabulated-list-test.el ends here
|
||||
55
test/lisp/emacs-lisp/thunk-tests.el
Normal file
55
test/lisp/emacs-lisp/thunk-tests.el
Normal file
|
|
@ -0,0 +1,55 @@
|
|||
;;; thunk-tests.el --- Tests for thunk.el -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2015 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Nicolas Petton <nicolas@petton.fr>
|
||||
;; Maintainer: emacs-devel@gnu.org
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Tests for thunk.el
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'thunk)
|
||||
|
||||
(ert-deftest thunk-should-be-lazy ()
|
||||
(let (x)
|
||||
(thunk-delay (setq x t))
|
||||
(should (null x))))
|
||||
|
||||
(ert-deftest thunk-can-be-evaluated ()
|
||||
(let* (x
|
||||
(thunk (thunk-delay (setq x t))))
|
||||
(should-not (thunk-evaluated-p thunk))
|
||||
(should (null x))
|
||||
(thunk-force thunk)
|
||||
(should (thunk-evaluated-p thunk))
|
||||
(should x)))
|
||||
|
||||
(ert-deftest thunk-evaluation-is-cached ()
|
||||
(let* ((x 0)
|
||||
(thunk (thunk-delay (setq x (1+ x)))))
|
||||
(thunk-force thunk)
|
||||
(should (= x 1))
|
||||
(thunk-force thunk)
|
||||
(should (= x 1))))
|
||||
|
||||
(provide 'thunk-tests)
|
||||
;;; thunk-tests.el ends here
|
||||
42
test/lisp/emacs-lisp/timer-tests.el
Normal file
42
test/lisp/emacs-lisp/timer-tests.el
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
;;; timer-tests.el --- tests for timers -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 2013-2015 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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(ert-deftest timer-tests-sit-for ()
|
||||
(let ((timer-ran nil)
|
||||
;; Want sit-for behavior when interactive
|
||||
(noninteractive nil))
|
||||
(run-at-time '(0 0 0 0)
|
||||
nil
|
||||
(lambda () (setq timer-ran t)))
|
||||
;; The test assumes run-at-time didn't take the liberty of firing
|
||||
;; the timer, so assert the test's assumption
|
||||
(should (not timer-ran))
|
||||
(sit-for 0 t)
|
||||
(should timer-ran)))
|
||||
|
||||
(ert-deftest timer-tests-debug-timer-check ()
|
||||
;; This function exists only if --enable-checking.
|
||||
(if (fboundp 'debug-timer-check)
|
||||
(should (debug-timer-check)) t))
|
||||
|
||||
;;; timer-tests.el ends here
|
||||
Loading…
Add table
Add a link
Reference in a new issue