From: Stefan Kangas Date: Wed, 23 Sep 2020 16:14:54 +0000 (+0200) Subject: Convert allout unit tests to ERT X-Git-Tag: emacs-28.0.90~5919 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=610b771d4a7fcb9d704bbd31032dc51009670e8f;p=emacs.git Convert allout unit tests to ERT * test/lisp/allout-tests.el: New file. * lisp/allout.el (allout-run-unit-tests-on-load) (allout-run-unit-tests): Remove. (allout-tests-obliterate-variable) (allout-tests-globally-unbound, allout-tests-globally-true) (allout-tests-locally-true, allout-test-resumptions): Move to allout-tests.el * test/lisp/allout-widgets-tests.el: New file. * lisp/allout-widgets.el (allout-widgets-run-unit-tests-on-load) (allout-widgets-run-unit-tests): Remove. (allout-test-range-overlaps): Move to allout-widgets-tests.el. --- diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el index 03fc3e2f0e1..ac49d3bf068 100644 --- a/lisp/allout-widgets.el +++ b/lisp/allout-widgets.el @@ -209,21 +209,6 @@ See `allout-widgets-mode' for allout widgets mode features." :group 'allout-widgets) (make-obsolete-variable 'allout-widgets-item-image-properties-xemacs nil "28.1") ;;;_ . Developer -;;;_ = allout-widgets-run-unit-tests-on-load -(defcustom allout-widgets-run-unit-tests-on-load nil - "When non-nil, unit tests will be run at end of loading allout-widgets. - -Generally, allout widgets code developers are the only ones who'll want to -set this. - -\(If set, this makes it an even better practice to exercise changes by -doing byte-compilation with a repeat count, so the file is loaded after -compilation.) - -See `allout-widgets-run-unit-tests' to see what's run." - :version "24.1" - :type 'boolean - :group 'allout-widgets-developer) ;;;_ = allout-widgets-time-decoration-activity (defcustom allout-widgets-time-decoration-activity nil "Retain timing info of the last cooperative redecoration. @@ -1353,64 +1338,6 @@ FROM and TO must be in increasing order, as must be the pairs in RANGES." (setq new-ranges (nreverse new-ranges)) (if ranges (setq new-ranges (append new-ranges ranges))) (list (if included-from t) new-ranges))) -;;;_ > allout-test-range-overlaps () -(defun allout-test-range-overlaps () - "`allout-range-overlaps' unit tests." - (let* (ranges - got - (try (lambda (from to) - (setq got (allout-range-overlaps from to ranges)) - (setq ranges (cadr got)) - got))) -;; ;; biggie: -;; (setq ranges nil) -;; ;; ~ .02 to .1 seconds for just repeated listing args instead of funcall -;; ;; ~ 13 seconds for doing repeated funcall -;; (message "time-trial: %s, resulting size %s" -;; (time-trial -;; '(let ((size 10000) -;; doing) -;; (dotimes (count size) -;; (setq doing (random size)) -;; (funcall try doing (+ doing (random 5))) -;; ;;(list doing (+ doing (random 5))) -;; ))) -;; (length ranges)) -;; (sit-for 2) - - ;; fresh: - (setq ranges nil) - (cl-assert (equal (funcall try 3 5) '(nil ((3 5))))) - ;; add range at end: - (cl-assert (equal (funcall try 10 12) '(nil ((3 5) (10 12))))) - ;; add range at beginning: - (cl-assert (equal (funcall try 1 2) '(nil ((1 2) (3 5) (10 12))))) - ;; insert range somewhere in the middle: - (cl-assert (equal (funcall try 7 9) '(nil ((1 2) (3 5) (7 9) (10 12))))) - ;; consolidate some: - (cl-assert (equal (funcall try 5 8) '(t ((1 2) (3 9) (10 12))))) - ;; add more: - (cl-assert (equal (funcall try 15 17) '(nil ((1 2) (3 9) (10 12) (15 17))))) - ;; add more: - (cl-assert (equal (funcall try 20 22) - '(nil ((1 2) (3 9) (10 12) (15 17) (20 22))))) - ;; encompass more: - (cl-assert (equal (funcall try 4 11) '(t ((1 2) (3 12) (15 17) (20 22))))) - ;; encompass all: - (cl-assert (equal (funcall try 2 25) '(t ((1 25))))) - - ;; fresh slate: - (setq ranges nil) - (cl-assert (equal (funcall try 20 25) '(nil ((20 25))))) - (cl-assert (equal (funcall try 30 35) '(nil ((20 25) (30 35))))) - (cl-assert (equal (funcall try 26 28) '(nil ((20 25) (26 28) (30 35))))) - (cl-assert (equal (funcall try 15 20) '(t ((15 25) (26 28) (30 35))))) - (cl-assert (equal (funcall try 10 30) '(t ((10 35))))) - (cl-assert (equal (funcall try 5 6) '(nil ((5 6) (10 35))))) - (cl-assert (equal (funcall try 2 100) '(t ((2 100))))) - - (setq ranges nil) - )) ;;;_ > allout-widgetize-buffer (&optional doing) (defun allout-widgetize-buffer (&optional doing) "EXAMPLE FUNCTION. Widgetize items in buffer using allout-chart-subtree. @@ -2380,18 +2307,6 @@ The elements of LIST are not copied, just the list structure itself." (overlays-in start end))))) (length button-overlays))) -;;;_ : Run unit tests: -(defun allout-widgets-run-unit-tests () - (message "Running allout-widget tests...") - - (allout-test-range-overlaps) - - (message "Running allout-widget tests... Done.") - (sit-for .5)) - -(when allout-widgets-run-unit-tests-on-load - (allout-widgets-run-unit-tests)) - ;;;_ : provide (provide 'allout-widgets) diff --git a/lisp/allout.el b/lisp/allout.el index 955b7000cbf..044c82afb29 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -77,7 +77,6 @@ ;;;_* Dependency loads (require 'overlay) -(eval-when-compile (require 'cl-lib)) ;;;_* USER CUSTOMIZATION VARIABLES: @@ -840,20 +839,6 @@ for restoring when all encryptions are established.") (defgroup allout-developer nil "Allout settings developers care about, including topic encryption and more." :group 'allout) -;;;_ = allout-run-unit-tests-on-load -(defcustom allout-run-unit-tests-on-load nil - "When non-nil, unit tests will be run at end of loading the allout module. - -Generally, allout code developers are the only ones who'll want to set this. - -\(If set, this makes it an even better practice to exercise changes by -doing byte-compilation with a repeat count, so the file is loaded after -compilation.) - -See `allout-run-unit-tests' to see what's run." - :type 'boolean - :group 'allout-developer) - ;;;_ + Miscellaneous customization ;;;_ = allout-enable-file-variable-adjustment @@ -6518,136 +6503,7 @@ If BEG is bigger than END we return 0." (isearch-repeat 'forward) (isearch-mode t))) -;;;_ #11 Unit tests -- this should be last item before "Provide" -;;;_ > allout-run-unit-tests () -(defun allout-run-unit-tests () - "Run the various allout unit tests." - (message "Running allout tests...") - (allout-test-resumptions) - (message "Running allout tests... Done.") - (sit-for .5)) -;;;_ : test resumptions: -;;;_ > allout-tests-obliterate-variable (name) -(defun allout-tests-obliterate-variable (name) - "Completely unbind variable with NAME." - (if (local-variable-p name (current-buffer)) (kill-local-variable name)) - (while (boundp name) (makunbound name))) -;;;_ > allout-test-resumptions () -(defvar allout-tests-globally-unbound nil - "Fodder for allout resumptions tests -- defvar just for byte compiler.") -(defvar allout-tests-globally-true nil - "Fodder for allout resumptions tests -- defvar just for byte compiler.") -(defvar allout-tests-locally-true nil - "Fodder for allout resumptions tests -- defvar just for byte compiler.") -(defun allout-test-resumptions () - ;; FIXME: Use ERT. - "Exercise allout resumptions." - ;; for each resumption case, we also test that the right local/global - ;; scopes are affected during resumption effects: - - ;; ensure that previously unbound variables return to the unbound state. - (with-temp-buffer - (allout-tests-obliterate-variable 'allout-tests-globally-unbound) - (allout-add-resumptions '(allout-tests-globally-unbound t)) - (cl-assert (not (default-boundp 'allout-tests-globally-unbound))) - (cl-assert (local-variable-p 'allout-tests-globally-unbound (current-buffer))) - (cl-assert (boundp 'allout-tests-globally-unbound)) - (cl-assert (equal allout-tests-globally-unbound t)) - (allout-do-resumptions) - (cl-assert (not (local-variable-p 'allout-tests-globally-unbound - (current-buffer)))) - (cl-assert (not (boundp 'allout-tests-globally-unbound)))) - - ;; ensure that variable with prior global value is resumed - (with-temp-buffer - (allout-tests-obliterate-variable 'allout-tests-globally-true) - (setq allout-tests-globally-true t) - (allout-add-resumptions '(allout-tests-globally-true nil)) - (cl-assert (equal (default-value 'allout-tests-globally-true) t)) - (cl-assert (local-variable-p 'allout-tests-globally-true (current-buffer))) - (cl-assert (equal allout-tests-globally-true nil)) - (allout-do-resumptions) - (cl-assert (not (local-variable-p 'allout-tests-globally-true - (current-buffer)))) - (cl-assert (boundp 'allout-tests-globally-true)) - (cl-assert (equal allout-tests-globally-true t))) - - ;; ensure that prior local value is resumed - (with-temp-buffer - (allout-tests-obliterate-variable 'allout-tests-locally-true) - (set (make-local-variable 'allout-tests-locally-true) t) - (cl-assert (not (default-boundp 'allout-tests-locally-true)) - nil (concat "Test setup mistake -- variable supposed to" - " not have global binding, but it does.")) - (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)) - nil (concat "Test setup mistake -- variable supposed to have" - " local binding, but it lacks one.")) - (allout-add-resumptions '(allout-tests-locally-true nil)) - (cl-assert (not (default-boundp 'allout-tests-locally-true))) - (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))) - (cl-assert (equal allout-tests-locally-true nil)) - (allout-do-resumptions) - (cl-assert (boundp 'allout-tests-locally-true)) - (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))) - (cl-assert (equal allout-tests-locally-true t)) - (cl-assert (not (default-boundp 'allout-tests-locally-true)))) - - ;; ensure that last of multiple resumptions holds, for various scopes. - (with-temp-buffer - (allout-tests-obliterate-variable 'allout-tests-globally-unbound) - (allout-tests-obliterate-variable 'allout-tests-globally-true) - (setq allout-tests-globally-true t) - (allout-tests-obliterate-variable 'allout-tests-locally-true) - (set (make-local-variable 'allout-tests-locally-true) t) - (allout-add-resumptions '(allout-tests-globally-unbound t) - '(allout-tests-globally-true nil) - '(allout-tests-locally-true nil)) - (allout-add-resumptions '(allout-tests-globally-unbound 2) - '(allout-tests-globally-true 3) - '(allout-tests-locally-true 4)) - ;; reestablish many of the basic conditions are maintained after re-add: - (cl-assert (not (default-boundp 'allout-tests-globally-unbound))) - (cl-assert (local-variable-p 'allout-tests-globally-unbound (current-buffer))) - (cl-assert (equal allout-tests-globally-unbound 2)) - (cl-assert (default-boundp 'allout-tests-globally-true)) - (cl-assert (local-variable-p 'allout-tests-globally-true (current-buffer))) - (cl-assert (equal allout-tests-globally-true 3)) - (cl-assert (not (default-boundp 'allout-tests-locally-true))) - (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))) - (cl-assert (equal allout-tests-locally-true 4)) - (allout-do-resumptions) - (cl-assert (not (local-variable-p 'allout-tests-globally-unbound - (current-buffer)))) - (cl-assert (not (boundp 'allout-tests-globally-unbound))) - (cl-assert (not (local-variable-p 'allout-tests-globally-true - (current-buffer)))) - (cl-assert (boundp 'allout-tests-globally-true)) - (cl-assert (equal allout-tests-globally-true t)) - (cl-assert (boundp 'allout-tests-locally-true)) - (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))) - (cl-assert (equal allout-tests-locally-true t)) - (cl-assert (not (default-boundp 'allout-tests-locally-true)))) - - ;; ensure that deliberately unbinding registered variables doesn't foul things - (with-temp-buffer - (allout-tests-obliterate-variable 'allout-tests-globally-unbound) - (allout-tests-obliterate-variable 'allout-tests-globally-true) - (setq allout-tests-globally-true t) - (allout-tests-obliterate-variable 'allout-tests-locally-true) - (set (make-local-variable 'allout-tests-locally-true) t) - (allout-add-resumptions '(allout-tests-globally-unbound t) - '(allout-tests-globally-true nil) - '(allout-tests-locally-true nil)) - (allout-tests-obliterate-variable 'allout-tests-globally-unbound) - (allout-tests-obliterate-variable 'allout-tests-globally-true) - (allout-tests-obliterate-variable 'allout-tests-locally-true) - (allout-do-resumptions)) - ) -;;;_ % Run unit tests if `allout-run-unit-tests-after-load' is true: -(when allout-run-unit-tests-on-load - (allout-run-unit-tests)) - -;;;_ #12 Provide +;;;_ #11 Provide (provide 'allout) ;;;_* Local emacs vars. diff --git a/test/lisp/allout-tests.el b/test/lisp/allout-tests.el new file mode 100644 index 00000000000..f7cd6db9cd4 --- /dev/null +++ b/test/lisp/allout-tests.el @@ -0,0 +1,148 @@ +;;; allout-tests.el --- Tests for allout.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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 . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'allout) + +(require 'cl-lib) + +(defun allout-tests-obliterate-variable (name) + "Completely unbind variable with NAME." + (if (local-variable-p name (current-buffer)) (kill-local-variable name)) + (while (boundp name) (makunbound name))) + +(defvar allout-tests-globally-unbound nil + "Fodder for allout resumptions tests -- defvar just for byte compiler.") +(defvar allout-tests-globally-true nil + "Fodder for allout resumptions tests -- defvar just for byte compiler.") +(defvar allout-tests-locally-true nil + "Fodder for allout resumptions tests -- defvar just for byte compiler.") + +;; For each resumption case, we also test that the right local/global +;; scopes are affected during resumption effects. + +(ert-deftest allout-test-resumption-unbound-return-to-unbound () + "Previously unbound variables return to the unbound state." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-globally-unbound) + (allout-add-resumptions '(allout-tests-globally-unbound t)) + (should (not (default-boundp 'allout-tests-globally-unbound))) + (should (local-variable-p 'allout-tests-globally-unbound (current-buffer))) + (should (boundp 'allout-tests-globally-unbound)) + (should (equal allout-tests-globally-unbound t)) + (allout-do-resumptions) + (should (not (local-variable-p 'allout-tests-globally-unbound + (current-buffer)))) + (should (not (boundp 'allout-tests-globally-unbound))))) + +(ert-deftest allout-test-resumption-variable-resumed () + "Ensure that variable with prior global value is resumed." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-globally-true) + (setq allout-tests-globally-true t) + (allout-add-resumptions '(allout-tests-globally-true nil)) + (should (equal (default-value 'allout-tests-globally-true) t)) + (should (local-variable-p 'allout-tests-globally-true (current-buffer))) + (should (equal allout-tests-globally-true nil)) + (allout-do-resumptions) + (should (not (local-variable-p 'allout-tests-globally-true + (current-buffer)))) + (should (boundp 'allout-tests-globally-true)) + (should (equal allout-tests-globally-true t)))) + +(ert-deftest allout-test-resumption-prior-value-resumed () + "Ensure that prior local value is resumed." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-locally-true) + (set (make-local-variable 'allout-tests-locally-true) t) + (cl-assert (not (default-boundp 'allout-tests-locally-true)) + nil (concat "Test setup mistake -- variable supposed to" + " not have global binding, but it does.")) + (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)) + nil (concat "Test setup mistake -- variable supposed to have" + " local binding, but it lacks one.")) + (allout-add-resumptions '(allout-tests-locally-true nil)) + (should (not (default-boundp 'allout-tests-locally-true))) + (should (local-variable-p 'allout-tests-locally-true (current-buffer))) + (should (equal allout-tests-locally-true nil)) + (allout-do-resumptions) + (should (boundp 'allout-tests-locally-true)) + (should (local-variable-p 'allout-tests-locally-true (current-buffer))) + (should (equal allout-tests-locally-true t)) + (should (not (default-boundp 'allout-tests-locally-true))))) + +(ert-deftest allout-test-resumption-multiple-holds () + "Ensure that last of multiple resumptions holds, for various scopes." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-globally-unbound) + (allout-tests-obliterate-variable 'allout-tests-globally-true) + (setq allout-tests-globally-true t) + (allout-tests-obliterate-variable 'allout-tests-locally-true) + (set (make-local-variable 'allout-tests-locally-true) t) + (allout-add-resumptions '(allout-tests-globally-unbound t) + '(allout-tests-globally-true nil) + '(allout-tests-locally-true nil)) + (allout-add-resumptions '(allout-tests-globally-unbound 2) + '(allout-tests-globally-true 3) + '(allout-tests-locally-true 4)) + ;; reestablish many of the basic conditions are maintained after re-add: + (should (not (default-boundp 'allout-tests-globally-unbound))) + (should (local-variable-p 'allout-tests-globally-unbound (current-buffer))) + (should (equal allout-tests-globally-unbound 2)) + (should (default-boundp 'allout-tests-globally-true)) + (should (local-variable-p 'allout-tests-globally-true (current-buffer))) + (should (equal allout-tests-globally-true 3)) + (should (not (default-boundp 'allout-tests-locally-true))) + (should (local-variable-p 'allout-tests-locally-true (current-buffer))) + (should (equal allout-tests-locally-true 4)) + (allout-do-resumptions) + (should (not (local-variable-p 'allout-tests-globally-unbound + (current-buffer)))) + (should (not (boundp 'allout-tests-globally-unbound))) + (should (not (local-variable-p 'allout-tests-globally-true + (current-buffer)))) + (should (boundp 'allout-tests-globally-true)) + (should (equal allout-tests-globally-true t)) + (should (boundp 'allout-tests-locally-true)) + (should (local-variable-p 'allout-tests-locally-true (current-buffer))) + (should (equal allout-tests-locally-true t)) + (should (not (default-boundp 'allout-tests-locally-true))))) + +(ert-deftest allout-test-resumption-unbinding () + "Ensure that deliberately unbinding registered variables doesn't foul things." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-globally-unbound) + (allout-tests-obliterate-variable 'allout-tests-globally-true) + (setq allout-tests-globally-true t) + (allout-tests-obliterate-variable 'allout-tests-locally-true) + (set (make-local-variable 'allout-tests-locally-true) t) + (allout-add-resumptions '(allout-tests-globally-unbound t) + '(allout-tests-globally-true nil) + '(allout-tests-locally-true nil)) + (allout-tests-obliterate-variable 'allout-tests-globally-unbound) + (allout-tests-obliterate-variable 'allout-tests-globally-true) + (allout-tests-obliterate-variable 'allout-tests-locally-true) + (allout-do-resumptions))) + +(provide 'allout-tests) +;;; allout-tests.el ends here diff --git a/test/lisp/allout-widgets-tests.el b/test/lisp/allout-widgets-tests.el new file mode 100644 index 00000000000..2b1bcaa6de3 --- /dev/null +++ b/test/lisp/allout-widgets-tests.el @@ -0,0 +1,87 @@ +;;; allout-widgets-tests.el --- Tests for allout-widgets.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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 . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'allout-widgets) + +(require 'cl-lib) + +(ert-deftest allout-test-range-overlaps () + "`allout-range-overlaps' unit tests." + (let* (ranges + got + (try (lambda (from to) + (setq got (allout-range-overlaps from to ranges)) + (setq ranges (cadr got)) + got))) +;; ;; biggie: +;; (setq ranges nil) +;; ;; ~ .02 to .1 seconds for just repeated listing args instead of funcall +;; ;; ~ 13 seconds for doing repeated funcall +;; (message "time-trial: %s, resulting size %s" +;; (time-trial +;; '(let ((size 10000) +;; doing) +;; (dotimes (count size) +;; (setq doing (random size)) +;; (funcall try doing (+ doing (random 5))) +;; ;;(list doing (+ doing (random 5))) +;; ))) +;; (length ranges)) +;; (sit-for 2) + + ;; fresh: + (setq ranges nil) + (should (equal (funcall try 3 5) '(nil ((3 5))))) + ;; add range at end: + (should (equal (funcall try 10 12) '(nil ((3 5) (10 12))))) + ;; add range at beginning: + (should (equal (funcall try 1 2) '(nil ((1 2) (3 5) (10 12))))) + ;; insert range somewhere in the middle: + (should (equal (funcall try 7 9) '(nil ((1 2) (3 5) (7 9) (10 12))))) + ;; consolidate some: + (should (equal (funcall try 5 8) '(t ((1 2) (3 9) (10 12))))) + ;; add more: + (should (equal (funcall try 15 17) '(nil ((1 2) (3 9) (10 12) (15 17))))) + ;; add more: + (should (equal (funcall try 20 22) + '(nil ((1 2) (3 9) (10 12) (15 17) (20 22))))) + ;; encompass more: + (should (equal (funcall try 4 11) '(t ((1 2) (3 12) (15 17) (20 22))))) + ;; encompass all: + (should (equal (funcall try 2 25) '(t ((1 25))))) + + ;; fresh slate: + (setq ranges nil) + (should (equal (funcall try 20 25) '(nil ((20 25))))) + (should (equal (funcall try 30 35) '(nil ((20 25) (30 35))))) + (should (equal (funcall try 26 28) '(nil ((20 25) (26 28) (30 35))))) + (should (equal (funcall try 15 20) '(t ((15 25) (26 28) (30 35))))) + (should (equal (funcall try 10 30) '(t ((10 35))))) + (should (equal (funcall try 5 6) '(nil ((5 6) (10 35))))) + (should (equal (funcall try 2 100) '(t ((2 100))))) + + (setq ranges nil))) + +(provide 'allout-widgets-tests) +;;; allout-widgets-tests.el ends here