testing/org-test.el

   1 ;;;; org-test.el --- Tests for Org
   2
   3 ;; Copyright (c) 2010-2015 Sebastian Rose, Eric Schulte
   4 ;; Authors:
   5 ;;     Sebastian Rose, Hannover, Germany, sebastian_rose gmx de
   6 ;;     Eric Schulte, Santa Fe, New Mexico, USA, schulte.eric gmail com
   7 ;;     David Maus, Brunswick, Germany, dmaus ictsoc de
   8
   9 ;; Released under the GNU General Public License version 3
  10 ;; see: http://www.gnu.org/licenses/gpl-3.0.html
  11
  12 ;; Definition of `special-mode' copied from Emacs23's simple.el to be
  13 ;; provide a testing environment for Emacs22.
  14
  15 ;;;; Comments:
  16
  17 ;; Interactive testing for Org mode.
  18
  19 ;; The heart of all this is the commands `org-test-current-defun'.  If
  20 ;; called while in a `defun' all ert tests with names matching the
  21 ;; name of the function are run.
  22
  23 ;;; Test Development
  24 ;; For test development purposes a number of navigation and test
  25 ;; function construction routines are available as a git submodule
  26 ;; (jump.el)
  27 ;; Install with...
  28 ;; $ git submodule init
  29 ;; $ git submodule update
  30
  31 \f
  32 ;;;; Code:
  33
  34 ;;; Ob constants
  35
  36 (defconst org-test-file-ob-anchor
  37   "94839181-184f-4ff4-a72f-94214df6f5ba")
  38
  39 (defconst org-test-link-in-heading-file-ob-anchor
  40   "a8b1d111-eca8-49f0-8930-56d4f0875155")
  41
  42 (unless (and (boundp 'org-batch-test) org-batch-test)
  43   (let* ((org-test-dir (expand-file-name
  44                         (file-name-directory
  45                          (or load-file-name buffer-file-name))))
  46          (org-lisp-dir (expand-file-name
  47                         (concat org-test-dir "../lisp"))))
  48
  49     (unless (featurep 'org)
  50       (setq load-path (cons org-lisp-dir load-path))
  51       (require 'org)
  52       (require 'org-id)
  53       (require 'ox)
  54       (org-babel-do-load-languages
  55        'org-babel-load-languages '((shell . t) (org . t))))
  56
  57     (let ((load-path (cons org-test-dir
  58                            (cons (expand-file-name "jump" org-test-dir)
  59                                  load-path))))
  60       (require 'cl-lib)
  61       (require 'ert)
  62       (require 'ert-x)
  63       (when (file-exists-p (expand-file-name "jump/jump.el" org-test-dir))
  64         (require 'jump)
  65         (require 'which-func)))))
  66
  67 (defconst org-test-default-test-file-name "tests.el"
  68   "For each defun a separate file with tests may be defined.
  69 tests.el is the fallback or default if you like.")
  70
  71 (defconst org-test-default-directory-name "testing"
  72   "Basename or the directory where the tests live.
  73 org-test searches this directory up the directory tree.")
  74
  75 (defconst org-test-dir
  76   (expand-file-name (file-name-directory (or load-file-name buffer-file-name))))
  77
  78 (defconst org-base-dir
  79   (expand-file-name ".." org-test-dir))
  80
  81 (defconst org-test-example-dir
  82   (expand-file-name "examples" org-test-dir))
  83
  84 (defconst org-test-file
  85   (expand-file-name "normal.org" org-test-example-dir))
  86
  87 (defconst org-test-no-heading-file
  88   (expand-file-name "no-heading.org" org-test-example-dir))
  89
  90 (defconst org-test-link-in-heading-file
  91   (expand-file-name "link-in-heading.org" org-test-dir))
  92
  93 (defconst org-id-locations-file
  94   (expand-file-name ".test-org-id-locations" org-test-dir))
  95
  96 \f
  97 ;;; Functions for writing tests
  98 (put 'missing-test-dependency
  99      'error-conditions
 100      '(error missing-test-dependency))
 101
 102 (defun org-test-for-executable (exe)
 103   "Throw an error if EXE is not available.
 104 This can be used at the top of code-block-language specific test
 105 files to avoid loading the file on systems without the
 106 executable."
 107   (unless (cl-reduce
 108            (lambda (acc dir)
 109              (or acc (file-exists-p (expand-file-name exe dir))))
 110            exec-path :initial-value nil)
 111     (signal 'missing-test-dependency (list exe))))
 112
 113 (defun org-test-buffer (&optional file)
 114   "TODO:  Setup and return a buffer to work with.
 115 If file is non-nil insert its contents in there.")
 116
 117 (defun org-test-compare-with-file (&optional file)
 118   "TODO:  Compare the contents of the test buffer with FILE.
 119 If file is not given, search for a file named after the test
 120 currently executed.")
 121
 122 (defmacro org-test-at-id (id &rest body)
 123   "Run body after placing the point in the headline identified by ID."
 124   (declare (indent 1))
 125   `(let* ((id-location (org-id-find ,id))
 126           (id-file (car id-location))
 127           (visited-p (get-file-buffer id-file))
 128           to-be-removed)
 129      (unwind-protect
 130          (save-window-excursion
 131            (save-match-data
 132              (org-id-goto ,id)
 133              (setq to-be-removed (current-buffer))
 134              (condition-case nil
 135                  (progn
 136                    (org-show-subtree)
 137                    (org-show-all '(blocks)))
 138                (error nil))
 139              (save-restriction ,@body)))
 140        (unless (or visited-p (not to-be-removed))
 141          (kill-buffer to-be-removed)))))
 142 (def-edebug-spec org-test-at-id (form body))
 143
 144 (defmacro org-test-in-example-file (file &rest body)
 145   "Execute body in the Org example file."
 146   (declare (indent 1))
 147   `(let* ((my-file (or ,file org-test-file))
 148           (visited-p (get-file-buffer my-file))
 149           to-be-removed)
 150      (save-window-excursion
 151        (save-match-data
 152          (find-file my-file)
 153          (unless (eq major-mode 'org-mode)
 154            (org-mode))
 155          (setq to-be-removed (current-buffer))
 156          (goto-char (point-min))
 157          (condition-case nil
 158              (progn
 159                (outline-next-visible-heading 1)
 160                (org-show-subtree)
 161                (org-show-all '(blocks)))
 162            (error nil))
 163          (save-restriction ,@body)))
 164      (unless visited-p
 165        (kill-buffer to-be-removed))))
 166 (def-edebug-spec org-test-in-example-file (form body))
 167
 168 (defmacro org-test-at-marker (file marker &rest body)
 169   "Run body after placing the point at MARKER in FILE.
 170 Note the uuidgen command-line command can be useful for
 171 generating unique markers for insertion as anchors into org
 172 files."
 173   (declare (indent 2))
 174   `(org-test-in-example-file ,file
 175      (goto-char (point-min))
 176      (re-search-forward (regexp-quote ,marker))
 177      ,@body))
 178 (def-edebug-spec org-test-at-marker (form form body))
 179
 180 (defmacro org-test-with-temp-text (text &rest body)
 181   "Run body in a temporary buffer with Org mode as the active
 182 mode holding TEXT.  If the string \"<point>\" appears in TEXT
 183 then remove it and place the point there before running BODY,
 184 otherwise place the point at the beginning of the inserted text."
 185   (declare (indent 1))
 186   `(let ((inside-text (if (stringp ,text) ,text (eval ,text)))
 187          (org-mode-hook nil))
 188      (with-temp-buffer
 189        (org-mode)
 190        (let ((point (string-match "<point>" inside-text)))
 191          (if point
 192              (progn
 193                (insert (replace-match "" nil nil inside-text))
 194                (goto-char (1+ (match-beginning 0))))
 195            (insert inside-text)
 196            (goto-char (point-min))))
 197        ,@body)))
 198 (def-edebug-spec org-test-with-temp-text (form body))
 199
 200 (defmacro org-test-with-temp-text-in-file (text &rest body)
 201   "Run body in a temporary file buffer with Org mode as the active mode."
 202   (declare (indent 1))
 203   (let ((results (cl-gensym)))
 204     `(let ((file (make-temp-file "org-test"))
 205            (kill-buffer-query-functions nil)
 206            (inside-text (if (stringp ,text) ,text (eval ,text)))
 207            ,results)
 208        (with-temp-file file (insert inside-text))
 209        (find-file file)
 210        (org-mode)
 211        (setq ,results (progn ,@body))
 212        (save-buffer) (kill-buffer (current-buffer))
 213        (delete-file file)
 214        ,results)))
 215 (def-edebug-spec org-test-with-temp-text-in-file (form body))
 216
 217 (defun org-test-table-target-expect (target &optional expect laps
 218 &rest tblfm)
 219   "For all TBLFM: Apply the formula to TARGET, compare EXPECT with result.
 220 Either LAPS and TBLFM are nil and the table will only be aligned
 221 or LAPS is the count of recalculations that should be made on
 222 each TBLFM.  To save ERT run time keep LAPS as low as possible to
 223 get the table stable.  Anyhow, if LAPS is 'iterate then iterate,
 224 but this will run one recalculation longer.  When EXPECT is nil
 225 it will be set to TARGET.
 226
 227 When running a test interactively in ERT is not enough and you
 228 need to examine the target table with e. g. the Org formula
 229 debugger or an Emacs Lisp debugger (e. g. with point in a data
 230 field and calling the instrumented `org-table-eval-formula') then
 231 copy and paste the table with formula from the ERT results buffer
 232 or temporarily substitute the `org-test-with-temp-text' of this
 233 function with `org-test-with-temp-text-in-file'.  Also consider
 234 setting `pp-escape-newlines' to nil manually."
 235   (require 'pp)
 236   (require 'ert)
 237   (let ((back pp-escape-newlines) (current-tblfm))
 238     (unless tblfm
 239       (should-not laps)
 240       (push "" tblfm))  ; Dummy formula.
 241     (unless expect (setq expect target))
 242     (while (setq current-tblfm (pop tblfm))
 243       (org-test-with-temp-text (concat target current-tblfm)
 244         ;; Search the last of possibly several tables, let the ERT
 245         ;; test fail if not found.
 246         (goto-char (point-max))
 247         (while (not (org-at-table-p))
 248           (should (eq 0 (forward-line -1))))
 249         (when laps
 250           (if (and (symbolp laps) (eq laps 'iterate))
 251               (should (org-table-recalculate 'iterate t))
 252             (should (integerp laps))
 253             (should (< 0 laps))
 254             (let ((cnt laps))
 255               (while (< 0 cnt)
 256                 (should (org-table-recalculate 'all t))
 257                 (setq cnt (1- cnt))))))
 258         (org-table-align)
 259         (setq pp-escape-newlines nil)
 260         ;; Declutter the ERT results buffer by giving only variables
 261         ;; and not directly the forms to `should'.
 262         (let ((expect (concat expect current-tblfm))
 263               (result (buffer-substring-no-properties
 264                        (point-min) (point-max))))
 265           (should (equal expect result)))
 266         ;; If `should' passed then set back `pp-escape-newlines' here,
 267         ;; else leave it nil as a side effect to see the failed table
 268         ;; on multiple lines in the ERT results buffer.
 269         (setq pp-escape-newlines back)))))
 270
 271 \f
 272 ;;; Navigation Functions
 273 (when (featurep 'jump)
 274   (defjump org-test-jump
 275     (("lisp/\\1.el" . "testing/lisp/test-\\1.el")
 276      ("lisp/\\1.el" . "testing/lisp/\\1.el/test.*.el")
 277      ("testing/lisp/test-\\1.el" . "lisp/\\1.el")
 278      ("testing/lisp/\\1.el" . "lisp/\\1.el/test.*.el"))
 279     (concat org-base-dir "/")
 280     "Jump between Org files and their tests."
 281     (lambda (path)
 282       (let* ((full-path (expand-file-name path org-base-dir))
 283              (file-name (file-name-nondirectory path))
 284              (name (file-name-sans-extension file-name)))
 285         (find-file full-path)
 286         (insert
 287          ";;; " file-name "\n\n"
 288          ";; Copyright (c) " (nth 5 (decode-time (current-time)))
 289          " " user-full-name "\n"
 290          ";; Authors: " user-full-name "\n\n"
 291          ";; Released under the GNU General Public License version 3\n"
 292          ";; see: http://www.gnu.org/licenses/gpl-3.0.html\n\n"
 293          ";;;; Comments:\n\n"
 294          ";; Template test file for Org tests\n\n"
 295          "\f\n"
 296          ";;; Code:\n"
 297          "(let ((load-path (cons (expand-file-name\n"
 298          "                      \"..\" (file-name-directory\n"
 299          "                            (or load-file-name buffer-file-name)))\n"
 300          "                     load-path)))\n"
 301          "  (require 'org-test)\n\n"
 302          "\f\n"
 303          ";;; Tests\n"
 304          "(ert-deftest " name "/example-test ()\n"
 305          "  \"Just an example to get you started.\"\n"
 306          "  (should t)\n"
 307          "  (should-not nil)\n"
 308          "  (should-error (error \"errr...\")))\n\n\n"
 309          "(provide '" name ")\n\n"
 310          ";;; " file-name " ends here\n") full-path))
 311     (lambda () ((lambda (res) (if (listp res) (car res) res)) (which-function)))))
 312
 313 (define-key emacs-lisp-mode-map "\M-\C-j" 'org-test-jump)
 314
 315 \f
 316 ;;; Miscellaneous helper functions
 317 (defun org-test-strip-text-props (s)
 318   "Return S without any text properties."
 319   (let ((noprop (copy-sequence s)))
 320     (set-text-properties 0 (length noprop) nil noprop)
 321     noprop))
 322 \f
 323
 324 (defun org-test-string-exact-match (regex string &optional start)
 325   "Case sensitive string-match"
 326   (let ((case-fold-search nil)
 327         (case-replace nil))
 328     (if(and (equal regex "")
 329             (not(equal string "")))
 330         nil
 331       (if (equal 0 (string-match regex string start))
 332           t
 333         nil))))
 334
 335 ;;; Load and Run tests
 336 (defun org-test-load ()
 337   "Load up the Org test suite."
 338   (interactive)
 339   (cl-flet ((rld (base)
 340               ;; Recursively load all files, if files throw errors
 341               ;; then silently ignore the error and continue to the
 342               ;; next file.  This allows files to error out if
 343               ;; required executables aren't available.
 344               (mapc
 345                (lambda (path)
 346                  (if (file-directory-p path)
 347                      (rld path)
 348                    (condition-case err
 349                        (when (string-match "^[A-Za-z].*\\.el$"
 350                                            (file-name-nondirectory path))
 351                          (load-file path))
 352                      (missing-test-dependency
 353                       (let ((name (intern
 354                                    (concat "org-missing-dependency/"
 355                                            (file-name-nondirectory
 356                                             (file-name-sans-extension path))))))
 357                         (eval `(ert-deftest ,name ()
 358                                  :expected-result :failed (should nil))))))))
 359                (directory-files base 'full
 360                                 "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*\\.el$"))))
 361     (rld (expand-file-name "lisp" org-test-dir))))
 362
 363 (defun org-test-current-defun ()
 364   "Test the current function."
 365   (interactive)
 366   (ert (which-function)))
 367
 368 (defun org-test-current-file ()
 369   "Run all tests for current file."
 370   (interactive)
 371   (ert (concat "test-"
 372                (file-name-sans-extension
 373                 (file-name-nondirectory (buffer-file-name)))
 374                "/")))
 375
 376 (defvar org-test-buffers nil
 377   "Hold buffers open for running Org tests.")
 378
 379 (defun org-test-touch-all-examples ()
 380   (dolist (file (directory-files
 381                  org-test-example-dir 'full
 382                  "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*\\.org$"))
 383     (unless (get-file-buffer file)
 384       (add-to-list 'org-test-buffers (find-file file)))))
 385
 386 (defun org-test-kill-all-examples ()
 387   (while org-test-buffers
 388     (let ((b (pop org-test-buffers)))
 389       (when (buffer-live-p b) (kill-buffer b)))))
 390
 391 (defun org-test-update-id-locations ()
 392   (org-id-update-id-locations
 393    (directory-files
 394     org-test-example-dir 'full
 395     "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*\\.org$")))
 396
 397 (defun org-test-run-batch-tests (&optional org-test-selector)
 398   "Run all tests matching an optional regex which defaults to \"\\(org\\|ob\\)\".
 399 Load all test files first."
 400   (interactive)
 401   (let ((org-id-track-globally t)
 402         (org-test-selector
 403          (if org-test-selector org-test-selector "\\(org\\|ob\\)"))
 404         org-confirm-babel-evaluate org-startup-folded vc-handled-backends)
 405     (org-test-touch-all-examples)
 406     (org-test-update-id-locations)
 407     (org-test-load)
 408     (message "selected tests: %s" org-test-selector)
 409     (ert-run-tests-batch-and-exit org-test-selector)))
 410
 411 (defun org-test-run-all-tests ()
 412   "Run all defined tests matching \"\\(org\\|ob\\)\".
 413 Load all test files first."
 414   (interactive)
 415   (org-test-touch-all-examples)
 416   (org-test-update-id-locations)
 417   (org-test-load)
 418   (ert "\\(org\\|ob\\)")
 419   (org-test-kill-all-examples))
 420
 421 (defmacro org-test-at-time (time &rest body)
 422   "Run body while pretending that the current time is TIME.
 423 TIME can be a non-nil Lisp time value, or a string specifying a date and time."
 424   (declare (indent 1))
 425   (let ((tm (cl-gensym))
 426         (at (cl-gensym)))
 427     `(let* ((,tm ,time)
 428             (,at (if (stringp ,tm)
 429                      (apply #'encode-time (org-parse-time-string ,tm))
 430                    ,tm)))
 431        (cl-letf
 432            ;; Wrap builtins whose behavior can depend on the current time.
 433            (((symbol-function 'current-time)
 434              (lambda () ,at))
 435             ((symbol-function 'current-time-string)
 436              (lambda (&optional time &rest args)
 437                (apply ,(symbol-function 'current-time-string)
 438                       (or time ,at) args)))
 439             ((symbol-function 'current-time-zone)
 440              (lambda (&optional time &rest args)
 441                (apply ,(symbol-function 'current-time-zone)
 442                       (or time ,at) args)))
 443             ((symbol-function 'decode-time)
 444              (lambda (&optional time) (funcall ,(symbol-function 'decode-time)
 445                                                (or time ,at))))
 446             ((symbol-function 'encode-time)
 447              (lambda (time &rest args)
 448                (apply ,(symbol-function 'encode-time) (or time ,at) args)))
 449             ((symbol-function 'float-time)
 450              (lambda (&optional time)
 451                (funcall ,(symbol-function 'float-time) (or time ,at))))
 452             ((symbol-function 'format-time-string)
 453              (lambda (format &optional time &rest args)
 454                (apply ,(symbol-function 'format-time-string)
 455                       format (or time ,at) args)))
 456             ((symbol-function 'set-file-times)
 457              (lambda (file &optional time)
 458                (funcall ,(symbol-function 'set-file-times) file (or time ,at))))
 459             ((symbol-function 'time-add)
 460              (lambda (a b) (funcall ,(symbol-function 'time-add)
 461                                     (or a ,at) (or b ,at))))
 462             ((symbol-function 'time-equal-p)
 463              (lambda (a b) (funcall ,(symbol-function 'time-equal-p)
 464                                     (or a ,at) (or b ,at))))
 465             ((symbol-function 'time-less-p)
 466              (lambda (a b) (funcall ,(symbol-function 'time-less-p)
 467                                     (or a ,at) (or b ,at))))
 468             ((symbol-function 'time-subtract)
 469              (lambda (a b) (funcall ,(symbol-function 'time-subtract)
 470                                     (or a ,at) (or b ,at)))))
 471          ,@body))))
 472
 473 (provide 'org-test)
 474
 475 ;;; org-test.el ends here