319 lines
12 KiB
EmacsLisp
319 lines
12 KiB
EmacsLisp
;;; 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
|