procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add Speedbar tests (bug#73533)

Browse source 
Add Speedbar tests which test the operation of
'speedbar-expand-line-descendants'.
* test/lisp/speedbar-tests.el (speedbar-tests-container)
(eieio-speedbar-object-children, speedbar-tests-item)
(speedbar-tests--make-object, speedbar-tests--setup-strings)
(speedbar-tests--object-hierarchy, speedbar-tests--base-items)
(speedbar-tests--clean-up, speedbar-tests--initialize)
(speedbar-tests--object-name-expanded)
(speedbar-tests--object-name-function)
(speedbar-tests--objects-as-strings)
(speedbar-tests--state-test)
(speedbar-tests--expand-descendants-single)
(speedbar-tests--expand-descendants-nested)
(speedbar-tests--expand-descendants-nested-wide)
(speedbar-tests--expand-descendants-of-first)
(speedbar-tests--expand-descendants-of-first-expanded)
(speedbar-tests--expand-descendants-of-last)
(speedbar-tests--expand-descendants-of-last-expanded)
(speedbar-tests--expand-descendants-of-middle)
(speedbar-tests--expand-descendants-of-middle-expanded):
New tests, test 'speedbar-expand-line-descendants'.
This commit is contained in:
Morgan Willcock 2024-10-08 17:34:20 +01:00 • committed by Eli Zaretskii
parent b730c4acfc
commit 9dcc32f10c
1 changed files with 318 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

318
test/lisp/speedbar-tests.el Normal file
View file

@ -0,0 +1,318 @@
;;; speedbar-tests.el --- Tests for speedbar.el -*- lexical-binding: t -*-
;; Copyright (C) 2024 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'ert)
(require 'eieio-base)
(require 'eieio-speedbar)
(defclass speedbar-tests-container (eieio-named eieio-speedbar-file-button)
((child-items :initarg :child-items
:type list))
"An expandable Speedbar item which can contain other items.")
(cl-defmethod eieio-speedbar-object-children ((item speedbar-tests-container))
"Return the list of child items for ITEM."
(slot-value item 'child-items))
(defclass speedbar-tests-item (eieio-named eieio-speedbar)
nil
"A Speedbar item which cannot contain other items.")
(defun speedbar-tests--make-object (item-spec)
"Return an object representing a Speedbar item.
The object is constructed based on the specification ITEM-SPEC which
should be a cons pair of the form (NAME . CHILD-ITEMS). NAME is a
string which will be used for display purposes. CHILD-ITEMS is a list
of additional ITEM-SPEC values which will be referenced as children."
(let ((name (car item-spec))
(child-items (cdr item-spec)))
(unless (stringp name)
(error "Item name must be a string"))
(unless (listp child-items)
(error "Child-items must be a list"))
(if child-items
(speedbar-tests-container
:object-name name
:child-items (mapcar #'speedbar-tests--make-object
child-items))
(speedbar-tests-item
:object-name name))))
(defvar speedbar-tests--setup-strings nil
"An alist of strings which represents a hierarchy of Speedbar items.")
(defvar speedbar-tests--object-hierarchy nil
"The current object hierarchy for the Speedbar being tested.")
(defun speedbar-tests--base-items (_directory)
"Return the list of top-level objects for the Speedbar."
(setq speedbar-tests--object-hierarchy
(mapcar #'speedbar-tests--make-object
speedbar-tests--setup-strings)))
(eieio-speedbar-create #'eieio-speedbar-make-map
'eieio-speedbar-key-map
'eieio-speedbar-menu
"Test"
#'speedbar-tests--base-items)
(defun speedbar-tests--clean-up ()
"Clean-up after Speedbar test."
(when (framep speedbar-frame)
(delete-frame speedbar-frame)))
(defun speedbar-tests--initialize ()
"Initialize a Speedbar for testing."
(speedbar-get-focus)
(speedbar-change-initial-expansion-list "Test"))
(defun speedbar-tests--object-name-expanded (object)
"Return the string name of OBJECT when it is expanded."
(let ((name (eieio-speedbar-object-buttonname object)))
(if (slot-value object 'expanded)
(concat name "+")
name)))
(defvar speedbar-tests--object-name-function
#'eieio-speedbar-object-buttonname
"The function which returns the string representation of an object.")
(defun speedbar-tests--objects-as-strings (object-list)
"Return the object hierarchy OBJECT-LIST as an alist of strings.
The string used to represent the object is determined by the function
bound to `speedbar-tests--object-name-function' is a function, which
should accept the object as the only argument and return a string to use
as the name."
(mapcar (lambda (object)
(let ((name (funcall speedbar-tests--object-name-function
object))
(child-items (eieio-speedbar-object-children
object)))
(cons name (speedbar-tests--objects-as-strings
child-items))))
object-list))
(cl-defmacro speedbar-tests--state-test
((&optional &key setup final name-function) &rest body)
"Evaluate BODY and verify the Speedbar is in an expected state.
`:setup' specifies an alist of strings which will be used to create an
object hierarchy used for the Speedbar display.
`:final' specifies an alist of strings which should represent the final
Speedbar state once BODY has been evaluated and the object hierarchy has
been converted back to an alist of strings. `:name-function' specifies
the function to use to generate a string from an object, which should
accept the object as an argument and return a string which represents
the object as well as its state."
(declare (indent 1))
(let ((let-vars `((speedbar-tests--setup-strings ',setup))))
(when name-function
(push `(speedbar-tests--object-name-function #',name-function)
let-vars))
`(unwind-protect
(let ,let-vars
(speedbar-tests--initialize)
(should (equal (speedbar-tests--objects-as-strings
speedbar-tests--object-hierarchy)
',setup))
,@body
(should (equal (speedbar-tests--objects-as-strings
speedbar-tests--object-hierarchy)
',final)))
(speedbar-tests--clean-up))))
(ert-deftest speedbar-tests--expand-descendants-single ()
"Expand the first item."
(skip-when noninteractive)
(speedbar-tests--state-test
( :setup (("A" . (("A1"))))
:final (("A+" . (("A1"))))
:name-function speedbar-tests--object-name-expanded)
(with-current-buffer speedbar-buffer
(goto-char (point-min))
(should (string-equal "A" (speedbar-line-text)))
(speedbar-expand-line-descendants 'nocache))))
(ert-deftest speedbar-tests--expand-descendants-nested ()
"Expand the first item and its only child."
(skip-when noninteractive)
(speedbar-tests--state-test
( :setup (("A" . (("A1" . (("A1A"))))))
:final (("A+" . (("A1+" . (("A1A"))))))
:name-function speedbar-tests--object-name-expanded)
(with-current-buffer speedbar-buffer
(goto-char (point-min))
(should (string-equal "A" (speedbar-line-text)))
(speedbar-expand-line-descendants 'nocache))))
(ert-deftest speedbar-tests--expand-descendants-nested-wide ()
"Expand all descendants of first item which has multiple children."
(skip-when noninteractive)
(speedbar-tests--state-test
( :setup (("A" . (("A1" . (("A1A")))
("A2" . (("A2A"))))))
:final (("A+" . (("A1+" . (("A1A")))
("A2+" . (("A2A"))))))
:name-function speedbar-tests--object-name-expanded)
(with-current-buffer speedbar-buffer
(goto-char (point-min))
(should (string-equal "A" (speedbar-line-text)))
(speedbar-expand-line-descendants 'nocache))))
(ert-deftest speedbar-tests--expand-descendants-of-first ()
"Expand the first item and all descendants."
(skip-when noninteractive)
(speedbar-tests--state-test
( :setup (("A" . (("A1" . (("A1A")))
("A2" . (("A2A")))))
("B" . (("B1" . (("B1B")))
("B2" . (("B2B"))))))
:final (("A+" . (("A1+" . (("A1A")))
("A2+" . (("A2A")))))
("B" . (("B1" . (("B1B")))
("B2" . (("B2B"))))))
:name-function speedbar-tests--object-name-expanded)
(with-current-buffer speedbar-buffer
(goto-char (point-min))
(should (string-equal "A" (speedbar-line-text)))
(speedbar-expand-line-descendants 'nocache))))
(ert-deftest speedbar-tests--expand-descendants-of-first-expanded ()
"Expand the already expanded first item and all descendants."
(skip-when noninteractive)
(speedbar-tests--state-test
( :setup (("A" . (("A1" . (("A1A")))
("A2" . (("A2A")))))
("B" . (("B1" . (("B1B")))
("B2" . (("B2B"))))))
:final (("A+" . (("A1+" . (("A1A")))
("A2+" . (("A2A")))))
("B" . (("B1" . (("B1B")))
("B2" . (("B2B"))))))
:name-function speedbar-tests--object-name-expanded)
(with-current-buffer speedbar-buffer
(goto-char (point-min))
(should (string-equal "A" (speedbar-line-text)))
(speedbar-expand-line 'nocache)
(speedbar-expand-line-descendants 'nocache))))
(ert-deftest speedbar-tests--expand-descendants-of-last ()
"Expand the last item and all descendants."
(skip-when noninteractive)
(speedbar-tests--state-test
( :setup (("A" . (("A1" . (("A1A")))
("A2" . (("A2A")))))
("B" . (("B1" . (("B1B")))
("B2" . (("B2B"))))))
:final (("A" . (("A1" . (("A1A")))
("A2" . (("A2A")))))
("B+" . (("B1+" . (("B1B")))
("B2+" . (("B2B"))))))
:name-function speedbar-tests--object-name-expanded)
(with-current-buffer speedbar-buffer
(goto-char (point-min))
(forward-line)
(should (string-equal "B" (speedbar-line-text)))
(speedbar-expand-line-descendants 'nocache))))
(ert-deftest speedbar-tests--expand-descendants-of-last-expanded ()
"Expand the already expanded last item and all descendants."
(skip-when noninteractive)
(speedbar-tests--state-test
( :setup (("A" . (("A1" . (("A1A")))
("A2" . (("A2A")))))
("B" . (("B1" . (("B1B")))
("B2" . (("B2B"))))))
:final (("A" . (("A1" . (("A1A")))
("A2" . (("A2A")))))
("B+" . (("B1+" . (("B1B")))
("B2+" . (("B2B"))))))
:name-function speedbar-tests--object-name-expanded)
(with-current-buffer speedbar-buffer
(goto-char (point-min))
(save-excursion
(forward-line)
(should (string-equal "B" (speedbar-line-text)))
(speedbar-expand-line 'nocache))
(save-excursion
(forward-line)
(should (string-equal "B" (speedbar-line-text)))
(speedbar-expand-line-descendants 'nocache)))))
(ert-deftest speedbar-tests--expand-descendants-of-middle ()
"Expand the middle item and all descendants."
(skip-when noninteractive)
(speedbar-tests--state-test
( :setup (("A" . (("A1" . (("A1A")))
("A2" . (("A2A")))))
("B" . (("B1" . (("B1B")))
("B2" . (("B2B")))))
("C" . (("C1" . (("C1C")))
("C2" . (("C2C"))))))
:final (("A" . (("A1" . (("A1A")))
("A2" . (("A2A")))))
("B+" . (("B1+" . (("B1B")))
("B2+" . (("B2B")))))
("C" . (("C1" . (("C1C")))
("C2" . (("C2C"))))))
:name-function speedbar-tests--object-name-expanded)
(with-current-buffer speedbar-buffer
(goto-char (point-min))
(goto-char (point-min))
(forward-line)
(should (string-equal "B" (speedbar-line-text)))
(speedbar-expand-line-descendants 'nocache))))
(ert-deftest speedbar-tests--expand-descendants-of-middle-expanded ()
"Expand the already expanded middle item and all descendants."
(skip-when noninteractive)
(speedbar-tests--state-test
( :setup (("A" . (("A1" . (("A1A")))
("A2" . (("A2A")))))
("B" . (("B1" . (("B1B")))
("B2" . (("B2B")))))
("C" . (("C1" . (("C1C")))
("C2" . (("C2C"))))))
:final (("A" . (("A1" . (("A1A")))
("A2" . (("A2A")))))
("B+" . (("B1+" . (("B1B")))
("B2+" . (("B2B")))))
("C" . (("C1" . (("C1C")))
("C2" . (("C2C"))))))
:name-function speedbar-tests--object-name-expanded)
(with-current-buffer speedbar-buffer
(goto-char (point-min))
(save-excursion
(forward-line)
(should (string-equal "B" (speedbar-line-text)))
(speedbar-expand-line 'nocache))
(save-excursion
(forward-line)
(should (string-equal "B" (speedbar-line-text)))
(speedbar-expand-line-descendants 'nocache)))))
(provide 'speedbar-tests)
;;; speedbar-tests.el ends here