269 lines
9.6 KiB
EmacsLisp
269 lines
9.6 KiB
EmacsLisp
|
;;; ert2.el --- Additions to ert.el
|
||
|
|
;;
|
||
|
|
;; Author: Lennart Borgman (lennart O borgman A gmail O com)
|
||
|
|
;; Created: 2008-09-02T11:46:03+0200 Tue
|
||
|
|
;; Version:
|
||
|
|
;; Last-Updated: 2009-01-06 Tue
|
||
|
|
;; URL:
|
||
|
|
;; Keywords:
|
||
|
|
;; Compatibility:
|
||
|
|
;;
|
||
|
|
;; Features that might be required by this library:
|
||
|
|
;;
|
||
|
|
;; Cannot open load file: ert2.
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Commentary:
|
||
|
|
;;
|
||
|
|
;;
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Change log:
|
||
|
|
;;
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;; 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 2, 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; see the file COPYING. If not, write to
|
||
|
|
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
|
||
|
|
;; Floor, Boston, MA 02110-1301, USA.
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(eval-when-compile (require 'cl))
|
||
|
|
(eval-when-compile
|
||
|
|
(let* ((this-file (or load-file-name
|
||
|
|
(when (boundp 'bytecomp-filename) bytecomp-filename)
|
||
|
|
buffer-file-name))
|
||
|
|
(this-dir (file-name-directory this-file))
|
||
|
|
(load-path (cons this-dir load-path)))
|
||
|
|
(require 'ert)))
|
||
|
|
|
||
|
|
(let* ((this-dir
|
||
|
|
(file-name-directory (if load-file-name load-file-name buffer-file-name)))
|
||
|
|
;;(load-path (copy-list load-path)))
|
||
|
|
(load-path (copy-sequence load-path)))
|
||
|
|
(add-to-list 'load-path this-dir)
|
||
|
|
(require 'ert))
|
||
|
|
|
||
|
|
|
||
|
|
(defvar ert-temp-test-buffer-test nil)
|
||
|
|
(make-variable-buffer-local 'ert-temp-test-buffer-test)
|
||
|
|
(put 'ert-temp-test-buffer-test 'permanent-local t)
|
||
|
|
|
||
|
|
(defvar ert-temp-test-buffer-file nil)
|
||
|
|
(make-variable-buffer-local 'ert-temp-test-buffer-file)
|
||
|
|
(put 'ert-temp-test-buffer-file 'permanent-local t)
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Test buffers
|
||
|
|
|
||
|
|
(defvar ert-failed-tests-temp-buffers nil)
|
||
|
|
|
||
|
|
(defvar ert-list-failed-buffers-name "*Ert Failed Test Buffers*")
|
||
|
|
|
||
|
|
(defun ert-kill-temp-test-buffers ()
|
||
|
|
"Delete test buffers from unsuccessful tests."
|
||
|
|
(interactive)
|
||
|
|
(let ((failed (get-buffer ert-list-failed-buffers-name)))
|
||
|
|
(when failed (kill-buffer failed)))
|
||
|
|
(dolist (buf ert-failed-tests-temp-buffers)
|
||
|
|
(when (buffer-live-p buf)
|
||
|
|
(kill-buffer buf)))
|
||
|
|
(setq ert-failed-tests-temp-buffers nil))
|
||
|
|
|
||
|
|
(defun ert-list-temp-test-buffers ()
|
||
|
|
"List test buffers from unsuccessful tests."
|
||
|
|
(interactive)
|
||
|
|
(setq ert-failed-tests-temp-buffers
|
||
|
|
(delq nil
|
||
|
|
(mapcar (lambda (buf)
|
||
|
|
(when (buffer-live-p buf)
|
||
|
|
buf))
|
||
|
|
ert-failed-tests-temp-buffers)))
|
||
|
|
(let ((ert-buffer (get-buffer "*ert*"))
|
||
|
|
(buffers ert-failed-tests-temp-buffers))
|
||
|
|
(when ert-buffer (setq buffers (cons ert-buffer buffers)))
|
||
|
|
(switch-to-buffer
|
||
|
|
(let ((Buffer-menu-buffer+size-width 40))
|
||
|
|
(list-buffers-noselect nil buffers)))
|
||
|
|
(rename-buffer ert-list-failed-buffers-name t))
|
||
|
|
(unless ert-failed-tests-temp-buffers
|
||
|
|
(message "No test buffers from unsuccessful tests")))
|
||
|
|
|
||
|
|
(defvar ert-temp-test-buffer-minor-mode-map
|
||
|
|
(let ((map (make-sparse-keymap)))
|
||
|
|
;; Add menu bar entries for test buffer and test function
|
||
|
|
(define-key map [(control ?c) ?? ?t] 'ert-temp-test-buffer-go-test)
|
||
|
|
(define-key map [(control ?c) ?? ?f] 'ert-temp-test-buffer-go-file)
|
||
|
|
map))
|
||
|
|
(defun ert-temp-test-buffer-go-test ()
|
||
|
|
(interactive)
|
||
|
|
(ert-find-test-other-window ert-temp-test-buffer-test))
|
||
|
|
(defun ert-temp-test-buffer-go-file ()
|
||
|
|
(interactive)
|
||
|
|
(find-file-other-window ert-temp-test-buffer-file))
|
||
|
|
|
||
|
|
(define-minor-mode ert-temp-test-buffer-minor-mode
|
||
|
|
"Helpers for those buffers ..."
|
||
|
|
)
|
||
|
|
(put 'ert-temp-test-buffer-minor-mode 'permanent-local t)
|
||
|
|
|
||
|
|
;; Fix-me: doc
|
||
|
|
(defvar ert-test-files-root nil)
|
||
|
|
(defun ert-get-test-file-name (file-name)
|
||
|
|
(unless ert-test-files-root
|
||
|
|
(error "Please set ert-test-files-root for your tests"))
|
||
|
|
(unless (file-directory-p ert-test-files-root)
|
||
|
|
(error "Can't find directory %s" ert-test-files-root))
|
||
|
|
(expand-file-name file-name ert-test-files-root))
|
||
|
|
|
||
|
|
(defmacro* ert-with-temp-buffer-include-file (file-name-form &body body)
|
||
|
|
"Insert FILE-NAME-FORM in a temporary buffer and eval BODY.
|
||
|
|
If success then delete the temporary buffer, otherwise keep it.
|
||
|
|
|
||
|
|
To access these temporary test buffers use
|
||
|
|
- `ert-list-temp-test-buffers': list them
|
||
|
|
- `ert-kill-temp-test-buffers': delete them"
|
||
|
|
(declare (indent 1) (debug t))
|
||
|
|
(let ((file-name (make-symbol "file-name-")))
|
||
|
|
`(let* ((,file-name (ert-get-test-file-name ,file-name-form))
|
||
|
|
(mode-line-buffer-identification (list (propertize "%b" 'face 'highlight)))
|
||
|
|
;; Give the buffer a name that allows us to switch to it
|
||
|
|
;; quickly when debugging a failure.
|
||
|
|
(temp-buf
|
||
|
|
(generate-new-buffer
|
||
|
|
(format "%s" (ert-this-test)))))
|
||
|
|
(unless (file-readable-p ,file-name)
|
||
|
|
(if (file-exists-p ,file-name)
|
||
|
|
(error "Can't read %s" ,file-name)
|
||
|
|
(error "Can't find %s" ,file-name)))
|
||
|
|
(message "Testing with file %s" ,file-name)
|
||
|
|
(setq ert-failed-tests-temp-buffers (cons temp-buf ert-failed-tests-temp-buffers))
|
||
|
|
(with-current-buffer temp-buf
|
||
|
|
(ert-temp-test-buffer-minor-mode 1)
|
||
|
|
(setq ert-temp-test-buffer-file ,file-name)
|
||
|
|
(setq ert-temp-test-buffer-test (ert-this-test))
|
||
|
|
;; Avoid global font lock
|
||
|
|
(let ((font-lock-global-modes nil))
|
||
|
|
;; Turn off font lock in buffer
|
||
|
|
(font-lock-mode -1)
|
||
|
|
(when (> emacs-major-version 22)
|
||
|
|
(assert (not font-lock-mode) t "%s %s" "in ert-with-temp-buffer-include-file"))
|
||
|
|
(insert-file-contents ,file-name)
|
||
|
|
(save-window-excursion
|
||
|
|
;; Switch to buffer so it will show immediately when
|
||
|
|
;; debugging a failure.
|
||
|
|
(switch-to-buffer-other-window (current-buffer))
|
||
|
|
,@body)
|
||
|
|
;; Fix-me: move to success list?
|
||
|
|
(kill-buffer temp-buf))))))
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Simulate commands
|
||
|
|
|
||
|
|
(defvar ert-simulate-command-delay nil)
|
||
|
|
|
||
|
|
(defvar ert-simulate-command-post-hook nil
|
||
|
|
"Normal hook to be run at end of `ert-simulate-command'.")
|
||
|
|
|
||
|
|
;; Fix-me: use this in all tests where applicable.
|
||
|
|
(defun ert-simulate-command (command run-idle-timers)
|
||
|
|
;; Fix-me: run-idle-timers - use seconds
|
||
|
|
;; Fix-me: add unread-events
|
||
|
|
"Simulate calling command COMMAND as in Emacs command loop.
|
||
|
|
If RUN-IDLE-TIMERS is non-nil then run the idle timers after
|
||
|
|
calling everything involved with the command.
|
||
|
|
|
||
|
|
COMMAND should be a list where the car is the command symbol and
|
||
|
|
the rest are arguments to the command.
|
||
|
|
|
||
|
|
NOTE: Since the command is not called by `call-interactively'
|
||
|
|
test for `called-interactively' in the command will fail.
|
||
|
|
|
||
|
|
Return the value of calling the command, ie
|
||
|
|
|
||
|
|
(apply (car COMMAND) (cdr COMMAND)).
|
||
|
|
|
||
|
|
Run the hook `ert-simulate-command-post-hook' at the very end."
|
||
|
|
|
||
|
|
(message "command=%s" command)
|
||
|
|
(ert-should (listp command))
|
||
|
|
(ert-should (commandp (car command)))
|
||
|
|
(ert-should (not unread-command-events))
|
||
|
|
(let (return-value
|
||
|
|
(font-lock-mode t))
|
||
|
|
;; For the order of things here see command_loop_1 in keyboard.c
|
||
|
|
;;
|
||
|
|
;; The command loop will reset the command related variables so
|
||
|
|
;; there is no reason to let bind them. They are set here however
|
||
|
|
;; to be able to test several commands in a row and how they
|
||
|
|
;; affect each other.
|
||
|
|
(setq deactivate-mark nil)
|
||
|
|
(setq this-original-command (car command))
|
||
|
|
;; remap through active keymaps
|
||
|
|
(setq this-command (or (command-remapping this-original-command)
|
||
|
|
this-original-command))
|
||
|
|
(run-hooks 'pre-command-hook)
|
||
|
|
(setq return-value (apply (car command) (cdr command))) ;; <-----
|
||
|
|
(message "post-command-hook=%s" post-command-hook)
|
||
|
|
(run-hooks 'post-command-hook)
|
||
|
|
(when deferred-action-list
|
||
|
|
(run-hooks 'deferred_action_function))
|
||
|
|
(setq real-last-command (car command))
|
||
|
|
(setq last-repeatable-command real-last-command)
|
||
|
|
(setq last-command this-command)
|
||
|
|
(when (and deactivate-mark transient-mark-mode) (deactivate-mark))
|
||
|
|
;;(message "ert-simulate-command.before idle-timers, point=%s" (point))
|
||
|
|
(when run-idle-timers
|
||
|
|
;;(dolist (timer (copy-list timer-idle-list))
|
||
|
|
(dolist (timer (copy-sequence timer-idle-list))
|
||
|
|
(timer-event-handler timer)
|
||
|
|
;;(message " after timer=%s, point=%s" timer (point))
|
||
|
|
)
|
||
|
|
(redisplay t))
|
||
|
|
;;(message "ert-simulate-command.after idle-timers, point=%s" (point))
|
||
|
|
(when ert-simulate-command-delay
|
||
|
|
;; Show user
|
||
|
|
;;(message "After M-x %s" command)
|
||
|
|
(let ((old-buffer-name (buffer-name)))
|
||
|
|
(rename-buffer (propertize (format "After M-x %s" (car command))
|
||
|
|
'face 'highlight)
|
||
|
|
t)
|
||
|
|
(sit-for ert-simulate-command-delay)
|
||
|
|
(rename-buffer old-buffer-name)))
|
||
|
|
(ert-should (not unread-command-events))
|
||
|
|
(run-hooks 'ert-simulate-command-post-hook)
|
||
|
|
return-value))
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Misc
|
||
|
|
|
||
|
|
(defun ert-this-test ()
|
||
|
|
"Return current `ert-deftest' function."
|
||
|
|
(elt test 1))
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Self tests
|
||
|
|
|
||
|
|
(provide 'ert2)
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; ert2.el ends here
|