emacs/nxhtml/tests/ert2.el

   1 ;;; ert2.el --- Additions to ert.el
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: 2008-09-02T11:46:03+0200 Tue
   5 ;; Version:
   6 ;; Last-Updated: 2009-01-06 Tue
   7 ;; URL:
   8 ;; Keywords:
   9 ;; Compatibility:
  10 ;;
  11 ;; Features that might be required by this library:
  12 ;;
  13 ;;   Cannot open load file: ert2.
  14 ;;
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;;
  17 ;;; Commentary:
  18 ;;
  19 ;;
  20 ;;
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;
  23 ;;; Change log:
  24 ;;
  25 ;;
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;;
  28 ;; This program is free software; you can redistribute it and/or
  29 ;; modify it under the terms of the GNU General Public License as
  30 ;; published by the Free Software Foundation; either version 2, or
  31 ;; (at your option) any later version.
  32 ;;
  33 ;; This program is distributed in the hope that it will be useful,
  34 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  35 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  36 ;; General Public License for more details.
  37 ;;
  38 ;; You should have received a copy of the GNU General Public License
  39 ;; along with this program; see the file COPYING.  If not, write to
  40 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  41 ;; Floor, Boston, MA 02110-1301, USA.
  42 ;;
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;
  45 ;;; Code:
  46
  47 (eval-when-compile (require 'cl))
  48 (eval-when-compile
  49   (let* ((this-file (or load-file-name
  50                         (when (boundp 'bytecomp-filename) bytecomp-filename)
  51                         buffer-file-name))
  52          (this-dir (file-name-directory this-file))
  53          (load-path (cons this-dir load-path)))
  54     (require 'ert)))
  55
  56 (let* ((this-dir
  57         (file-name-directory (if load-file-name load-file-name buffer-file-name)))
  58        ;;(load-path (copy-list load-path)))
  59        (load-path (copy-sequence load-path)))
  60   (add-to-list 'load-path this-dir)
  61   (require 'ert))
  62
  63
  64 (defvar ert-temp-test-buffer-test nil)
  65 (make-variable-buffer-local 'ert-temp-test-buffer-test)
  66 (put 'ert-temp-test-buffer-test 'permanent-local t)
  67
  68 (defvar ert-temp-test-buffer-file nil)
  69 (make-variable-buffer-local 'ert-temp-test-buffer-file)
  70 (put 'ert-temp-test-buffer-file 'permanent-local t)
  71
  72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73 ;;; Test buffers
  74
  75 (defvar ert-failed-tests-temp-buffers nil)
  76
  77 (defvar ert-list-failed-buffers-name "*Ert Failed Test Buffers*")
  78
  79 (defun ert-kill-temp-test-buffers ()
  80   "Delete test buffers from unsuccessful tests."
  81   (interactive)
  82   (let ((failed (get-buffer ert-list-failed-buffers-name)))
  83     (when failed (kill-buffer failed)))
  84   (dolist (buf ert-failed-tests-temp-buffers)
  85     (when (buffer-live-p buf)
  86       (kill-buffer buf)))
  87   (setq ert-failed-tests-temp-buffers nil))
  88
  89 (defun ert-list-temp-test-buffers ()
  90   "List test buffers from unsuccessful tests."
  91   (interactive)
  92   (setq ert-failed-tests-temp-buffers
  93         (delq nil
  94               (mapcar (lambda (buf)
  95                         (when (buffer-live-p buf)
  96                           buf))
  97                       ert-failed-tests-temp-buffers)))
  98   (let ((ert-buffer (get-buffer "*ert*"))
  99         (buffers ert-failed-tests-temp-buffers))
 100     (when ert-buffer (setq buffers (cons ert-buffer buffers)))
 101     (switch-to-buffer
 102      (let ((Buffer-menu-buffer+size-width 40))
 103        (list-buffers-noselect nil buffers)))
 104     (rename-buffer ert-list-failed-buffers-name t))
 105   (unless ert-failed-tests-temp-buffers
 106     (message "No test buffers from unsuccessful tests")))
 107
 108 (defvar ert-temp-test-buffer-minor-mode-map
 109   (let ((map (make-sparse-keymap)))
 110     ;; Add menu bar entries for test buffer and test function
 111     (define-key map [(control ?c) ?? ?t] 'ert-temp-test-buffer-go-test)
 112     (define-key map [(control ?c) ?? ?f] 'ert-temp-test-buffer-go-file)
 113     map))
 114 (defun ert-temp-test-buffer-go-test ()
 115   (interactive)
 116   (ert-find-test-other-window ert-temp-test-buffer-test))
 117 (defun ert-temp-test-buffer-go-file ()
 118   (interactive)
 119   (find-file-other-window ert-temp-test-buffer-file))
 120
 121 (define-minor-mode ert-temp-test-buffer-minor-mode
 122   "Helpers for those buffers ..."
 123   )
 124 (put 'ert-temp-test-buffer-minor-mode 'permanent-local t)
 125
 126 ;; Fix-me: doc
 127 (defvar ert-test-files-root nil)
 128 (defun ert-get-test-file-name (file-name)
 129   (unless ert-test-files-root
 130     (error "Please set ert-test-files-root for your tests"))
 131   (unless (file-directory-p ert-test-files-root)
 132     (error "Can't find directory %s" ert-test-files-root))
 133   (expand-file-name file-name ert-test-files-root))
 134
 135 (defmacro* ert-with-temp-buffer-include-file (file-name-form &body body)
 136   "Insert FILE-NAME-FORM in a temporary buffer and eval BODY.
 137 If success then delete the temporary buffer, otherwise keep it.
 138
 139 To access these temporary test buffers use
 140 - `ert-list-temp-test-buffers': list them
 141 - `ert-kill-temp-test-buffers': delete them"
 142   (declare (indent 1) (debug t))
 143   (let ((file-name (make-symbol "file-name-")))
 144     `(let* ((,file-name (ert-get-test-file-name ,file-name-form))
 145             (mode-line-buffer-identification (list (propertize "%b" 'face 'highlight)))
 146             ;; Give the buffer a name that allows us to switch to it
 147             ;; quickly when debugging a failure.
 148             (temp-buf
 149              (generate-new-buffer
 150               (format "%s" (ert-this-test)))))
 151        (unless (file-readable-p ,file-name)
 152          (if (file-exists-p ,file-name)
 153              (error "Can't read %s" ,file-name)
 154            (error "Can't find %s" ,file-name)))
 155        (message "Testing with file %s" ,file-name)
 156        (setq ert-failed-tests-temp-buffers (cons temp-buf ert-failed-tests-temp-buffers))
 157        (with-current-buffer temp-buf
 158          (ert-temp-test-buffer-minor-mode 1)
 159          (setq ert-temp-test-buffer-file ,file-name)
 160          (setq ert-temp-test-buffer-test (ert-this-test))
 161          ;; Avoid global font lock
 162          (let ((font-lock-global-modes nil))
 163            ;; Turn off font lock in buffer
 164            (font-lock-mode -1)
 165            (when (> emacs-major-version 22)
 166              (assert (not font-lock-mode) t "%s %s" "in ert-with-temp-buffer-include-file"))
 167            (insert-file-contents ,file-name)
 168            (save-window-excursion
 169              ;; Switch to buffer so it will show immediately when
 170              ;; debugging a failure.
 171              (switch-to-buffer-other-window (current-buffer))
 172              ,@body)
 173            ;; Fix-me: move to success list?
 174            (kill-buffer temp-buf))))))
 175
 176
 177 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 178 ;;; Simulate commands
 179
 180 (defvar ert-simulate-command-delay nil)
 181
 182 (defvar ert-simulate-command-post-hook nil
 183   "Normal hook to be run at end of `ert-simulate-command'.")
 184
 185 ;; Fix-me: use this in all tests where applicable.
 186 (defun ert-simulate-command (command run-idle-timers)
 187   ;; Fix-me: run-idle-timers - use seconds
 188   ;; Fix-me: add unread-events
 189   "Simulate calling command COMMAND as in Emacs command loop.
 190 If RUN-IDLE-TIMERS is non-nil then run the idle timers after
 191 calling everything involved with the command.
 192
 193 COMMAND should be a list where the car is the command symbol and
 194 the rest are arguments to the command.
 195
 196 NOTE: Since the command is not called by `call-interactively'
 197 test for `called-interactively' in the command will fail.
 198
 199 Return the value of calling the command, ie
 200
 201   (apply (car COMMAND) (cdr COMMAND)).
 202
 203 Run the hook `ert-simulate-command-post-hook' at the very end."
 204
 205   (message "command=%s" command)
 206   (ert-should (listp command))
 207   (ert-should (commandp (car command)))
 208   (ert-should (not unread-command-events))
 209   (let (return-value
 210         (font-lock-mode t))
 211     ;; For the order of things here see command_loop_1 in keyboard.c
 212     ;;
 213     ;; The command loop will reset the command related variables so
 214     ;; there is no reason to let bind them. They are set here however
 215     ;; to be able to test several commands in a row and how they
 216     ;; affect each other.
 217     (setq deactivate-mark nil)
 218     (setq this-original-command (car command))
 219     ;; remap through active keymaps
 220     (setq this-command (or (command-remapping this-original-command)
 221                            this-original-command))
 222     (run-hooks 'pre-command-hook)
 223     (setq return-value (apply (car command) (cdr command))) ;; <-----
 224     (message "post-command-hook=%s" post-command-hook)
 225     (run-hooks 'post-command-hook)
 226     (when deferred-action-list
 227       (run-hooks 'deferred_action_function))
 228     (setq real-last-command (car command))
 229     (setq last-repeatable-command real-last-command)
 230     (setq last-command this-command)
 231     (when (and deactivate-mark transient-mark-mode) (deactivate-mark))
 232     ;;(message "ert-simulate-command.before idle-timers, point=%s" (point))
 233     (when run-idle-timers
 234       ;;(dolist (timer (copy-list timer-idle-list))
 235       (dolist (timer (copy-sequence timer-idle-list))
 236         (timer-event-handler timer)
 237         ;;(message "   after timer=%s, point=%s" timer (point))
 238         )
 239       (redisplay t))
 240     ;;(message "ert-simulate-command.after  idle-timers, point=%s" (point))
 241     (when ert-simulate-command-delay
 242       ;; Show user
 243       ;;(message "After M-x %s" command)
 244       (let ((old-buffer-name (buffer-name)))
 245         (rename-buffer (propertize (format "After M-x %s" (car command))
 246                                    'face 'highlight)
 247                        t)
 248         (sit-for ert-simulate-command-delay)
 249         (rename-buffer old-buffer-name)))
 250     (ert-should (not unread-command-events))
 251     (run-hooks 'ert-simulate-command-post-hook)
 252     return-value))
 253
 254
 255 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 256 ;;; Misc
 257
 258 (defun ert-this-test ()
 259   "Return current `ert-deftest' function."
 260   (elt test 1))
 261
 262
 263 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 264 ;;; Self tests
 265
 266 (provide 'ert2)
 267 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 268 ;;; ert2.el ends here