code.delx.au - gnu-emacs/blob - test/cedet/semantic-ia-utest.el

   1 ;;; semantic-ia-utest.el --- Analyzer unit tests
   2
   3 ;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam <eric@siege-engine.com>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; Use marked-up files in the test directory and run the analyzer
  25 ;; on them.  Make sure the answers are correct.
  26 ;;
  27 ;; Each file has cursor keys in them of the form:
  28 ;;   // -#- ("ans1" "ans2" )
  29 ;; where # is 1, 2, 3, etc, and some sort of answer list.
  30
  31 ;;; Code:
  32 (require 'semantic)
  33 (require 'semantic/analyze)
  34 (require 'semantic/analyze/refs)
  35 (require 'semantic/symref)
  36 (require 'semantic/symref/filter)
  37
  38 (load-file "cedet-utests.el")
  39
  40 (defvar semantic-ia-utest-file-list
  41   '(
  42     "tests/testdoublens.cpp"
  43     "tests/testsubclass.cpp"
  44     "tests/testtypedefs.cpp"
  45     "tests/teststruct.cpp"
  46     "tests/testtemplates.cpp"
  47     "tests/testfriends.cpp"
  48     "tests/testusing.cpp"
  49     "tests/testnsp.cpp"
  50     "tests/testsppcomplete.c"
  51     "tests/testvarnames.c"
  52     "tests/testjavacomp.java"
  53     )
  54   "List of files with analyzer completion test points.")
  55
  56 (defvar semantic-ia-utest-error-log-list nil
  57   "List of errors occurring during a run.")
  58
  59 ;;;###autoload
  60 (defun semantic-ia-utest (&optional arg)
  61   "Run the semantic ia unit test against stored sources.
  62 Argument ARG specifies which set of tests to run.
  63  1 - ia utests
  64  2 - regs utests
  65  3 - symrefs utests
  66  4 - symref count utests"
  67   (interactive "P")
  68   (save-excursion
  69
  70     (let ((fl semantic-ia-utest-file-list)
  71           (semantic-ia-utest-error-log-list nil)
  72           )
  73
  74       (cedet-utest-log-setup "ANALYZER")
  75
  76       (set-buffer (semantic-find-file-noselect
  77                    (or (locate-library "semantic-ia-utest.el")
  78                        "semantic-ia-utest.el")))
  79
  80       (while fl
  81
  82         ;; Make sure we have the files we think we have.
  83         (when (not (file-exists-p (car fl)))
  84           (error "Cannot find unit test file: %s" (car fl)))
  85
  86         ;; Run the tests.
  87         (let ((fb (find-buffer-visiting (car fl)))
  88               (b (semantic-find-file-noselect (car fl) t)))
  89
  90           ;; Run the test on it.
  91           (save-excursion
  92             (set-buffer b)
  93
  94             ;; This line will also force the include, scope, and typecache.
  95             (semantic-clear-toplevel-cache)
  96             ;; Force tags to be parsed.
  97             (semantic-fetch-tags)
  98
  99             (semantic-ia-utest-log "  ** Starting tests in %s"
 100                                    (buffer-name))
 101
 102             (when (or (not arg) (= arg 1))
 103               (semantic-ia-utest-buffer))
 104
 105             (when (or (not arg) (= arg 2))
 106               (set-buffer b)
 107               (semantic-ia-utest-buffer-refs))
 108
 109             (when (or (not arg) (= arg 3))
 110               (set-buffer b)
 111               (semantic-sr-utest-buffer-refs))
 112
 113             (when (or (not arg) (= arg 4))
 114               (set-buffer b)
 115               (semantic-src-utest-buffer-refs))
 116
 117             (semantic-ia-utest-log "  ** Completed tests in %s\n"
 118                                    (buffer-name))
 119             )
 120
 121           ;; If it wasn't already in memory, whack it.
 122           (when (not fb)
 123             (kill-buffer b))
 124           )
 125         (setq fl (cdr fl)))
 126
 127       (cedet-utest-log-shutdown
 128        "ANALYZER"
 129        (when semantic-ia-utest-error-log-list
 130          (format "%s Failures found."
 131                  (length semantic-ia-utest-error-log-list))))
 132       (when semantic-ia-utest-error-log-list
 133         (error "Failures found during analyzer unit tests"))
 134       ))
 135   )
 136
 137 (defun semantic-ia-utest-buffer ()
 138   "Run analyzer completion unit-test pass in the current buffer."
 139
 140   (let* ((idx 1)
 141          (regex-p nil)
 142          (regex-a nil)
 143          (p nil)
 144          (a nil)
 145          (pass nil)
 146          (fail nil)
 147          (actual nil)
 148          (desired nil)
 149          ;; Exclude unpredictable system files in the
 150          ;; header include list.
 151          (semanticdb-find-default-throttle
 152           (remq 'system semanticdb-find-default-throttle))
 153          )
 154     ;; Keep looking for test points until we run out.
 155     (while (save-excursion
 156              (setq regex-p (concat "//\\s-*-" (number-to-string idx) "-" )
 157                    regex-a (concat "//\\s-*#" (number-to-string idx) "#" ))
 158              (goto-char (point-min))
 159              (save-match-data
 160                (when (re-search-forward regex-p nil t)
 161                  (setq p (match-beginning 0))))
 162              (save-match-data
 163                (when (re-search-forward regex-a nil t)
 164                  (setq a (match-end 0))))
 165              (and p a))
 166
 167       (save-excursion
 168
 169         (goto-char p)
 170
 171         (let* ((ctxt (semantic-analyze-current-context))
 172                (acomp
 173                 (condition-case nil
 174                     (semantic-analyze-possible-completions ctxt)
 175                   (error nil))))
 176           (setq actual (mapcar 'semantic-tag-name acomp)))
 177
 178         (goto-char a)
 179
 180         (let ((bss (buffer-substring-no-properties (point) (point-at-eol))))
 181           (condition-case nil
 182               (setq desired (read bss))
 183             (error (setq desired (format "  FAILED TO PARSE: %S"
 184                                          bss)))))
 185
 186         (if (equal actual desired)
 187             (setq pass (cons idx pass))
 188           (setq fail (cons idx fail))
 189           (semantic-ia-utest-log
 190            "    Failed %d.  Desired: %S Actual %S"
 191            idx desired actual)
 192           (add-to-list 'semantic-ia-utest-error-log-list
 193                        (list (buffer-name) idx desired actual)
 194                        )
 195
 196           )
 197         )
 198
 199       (setq p nil a nil)
 200       (setq idx (1+ idx)))
 201
 202     (if fail
 203         (progn
 204           (semantic-ia-utest-log
 205            "    Unit tests (completions) failed tests %S"
 206            (reverse fail))
 207           )
 208       (semantic-ia-utest-log "    Unit tests (completions) passed (%d total)"
 209                              (- idx 1)))
 210
 211     ))
 212
 213 (defun semantic-ia-utest-buffer-refs ()
 214   "Run an analyze-refs unit-test pass in the current buffer."
 215
 216   (let* ((idx 1)
 217          (regex-p nil)
 218          (p nil)
 219          (pass nil)
 220          (fail nil)
 221          ;; Exclude unpredictable system files in the
 222          ;; header include list.
 223          (semanticdb-find-default-throttle
 224           (remq 'system semanticdb-find-default-throttle))
 225          )
 226     ;; Keep looking for test points until we run out.
 227     (while (save-excursion
 228              (setq regex-p (concat "//\\s-*\\^" (number-to-string idx) "^" )
 229                    )
 230              (goto-char (point-min))
 231              (save-match-data
 232                (when (re-search-forward regex-p nil t)
 233                  (setq p (match-beginning 0))))
 234              p)
 235
 236       (save-excursion
 237
 238         (goto-char p)
 239         (forward-char -1)
 240
 241         (let* ((ct (semantic-current-tag))
 242                (refs (semantic-analyze-tag-references ct))
 243                (impl (semantic-analyze-refs-impl refs t))
 244                (proto (semantic-analyze-refs-proto refs t))
 245                (pf nil)
 246                )
 247           (setq
 248            pf
 249            (catch 'failed
 250              (if (and impl proto (car impl) (car proto))
 251                  (let (ct2 ref2 impl2 proto2
 252                            newstart)
 253                    (cond
 254                     ((semantic-equivalent-tag-p (car impl) ct)
 255                      ;; We are on an IMPL.  Go To the proto, and find matches.
 256                      (semantic-go-to-tag (car proto))
 257                      (setq newstart (car proto))
 258                      )
 259                     ((semantic-equivalent-tag-p (car proto) ct)
 260                      ;; We are on a PROTO.  Go to the imple, and find matches
 261                      (semantic-go-to-tag (car impl))
 262                      (setq newstart (car impl))
 263                      )
 264                     (t
 265                      ;; No matches is a fail.
 266                      (throw 'failed t)
 267                      ))
 268                    ;; Get the new tag, does it match?
 269                    (setq ct2 (semantic-current-tag))
 270
 271                    ;; Does it match?
 272                    (when (not (semantic-equivalent-tag-p ct2 newstart))
 273                      (throw 'failed t))
 274
 275                    ;; Can we double-jump?
 276                    (setq ref2 (semantic-analyze-tag-references ct)
 277                          impl2 (semantic-analyze-refs-impl ref2 t)
 278                          proto2 (semantic-analyze-refs-proto ref2 t))
 279
 280                    (when (or (not (and impl2 proto2))
 281                              (not
 282                               (and (semantic-equivalent-tag-p
 283                                     (car impl) (car impl2))
 284                                    (semantic-equivalent-tag-p
 285                                     (car proto) (car proto2)))))
 286                      (throw 'failed t))
 287                    )
 288
 289                ;; Else, no matches at all, so another fail.
 290                (throw 'failed t)
 291                )))
 292
 293            (if (not pf)
 294               ;; We passed
 295               (setq pass (cons idx pass))
 296             ;; We failed.
 297             (setq fail (cons idx fail))
 298             (semantic-ia-utest-log
 299              "    Failed %d.  For %s (Num impls %d) (Num protos %d)"
 300              idx (if ct (semantic-tag-name ct) "<No tag found>")
 301              (length impl) (length proto))
 302             (add-to-list 'semantic-ia-utest-error-log-list
 303                          (list (buffer-name) idx)
 304                          )
 305             ))
 306
 307         (setq p nil)
 308         (setq idx (1+ idx))
 309
 310         ))
 311
 312     (if fail
 313         (progn
 314           (semantic-ia-utest-log
 315            "    Unit tests (refs) failed tests")
 316           )
 317       (semantic-ia-utest-log "    Unit tests (refs) passed (%d total)"
 318                              (- idx 1)))
 319
 320     ))
 321
 322 (defun semantic-sr-utest-buffer-refs ()
 323   "Run a symref unit-test pass in the current buffer."
 324
 325   ;; This line will also force the include, scope, and typecache.
 326   (semantic-clear-toplevel-cache)
 327   ;; Force tags to be parsed.
 328   (semantic-fetch-tags)
 329
 330   (let* ((idx 1)
 331          (tag nil)
 332          (regex-p nil)
 333          (desired nil)
 334          (actual-result nil)
 335          (actual nil)
 336          (pass nil)
 337          (fail nil)
 338          (symref-tool-used nil)
 339          ;; Exclude unpredictable system files in the
 340          ;; header include list.
 341          (semanticdb-find-default-throttle
 342           (remq 'system semanticdb-find-default-throttle))
 343          )
 344     ;; Keep looking for test points until we run out.
 345     (while (save-excursion
 346              (setq regex-p (concat "//\\s-*\\%" (number-to-string idx) "%" )
 347                    )
 348              (goto-char (point-min))
 349              (save-match-data
 350                (when (re-search-forward regex-p nil t)
 351                  (setq tag (semantic-current-tag))
 352                  (goto-char (match-end 0))
 353                  (setq desired (read (buffer-substring (point) (point-at-eol))))
 354                  ))
 355              tag)
 356
 357       (setq actual-result (semantic-symref-find-references-by-name
 358                            (semantic-tag-name tag) 'target
 359                            'symref-tool-used))
 360
 361       (if (not actual-result)
 362           (progn
 363             (setq fail (cons idx fail))
 364             (semantic-ia-utest-log
 365              "  Failed FNames %d: No results." idx)
 366             (semantic-ia-utest-log
 367              "  Failed Tool: %s" (object-name symref-tool-used))
 368
 369             (add-to-list 'semantic-ia-utest-error-log-list
 370                          (list (buffer-name) idx)
 371                          )
 372             )
 373
 374         (setq actual (list (sort (mapcar
 375                                   'file-name-nondirectory
 376                                   (semantic-symref-result-get-files actual-result))
 377                                  'string<)
 378                            (sort
 379                             (mapcar
 380                              'semantic-format-tag-canonical-name
 381                              (semantic-symref-result-get-tags actual-result))
 382                             'string<)))
 383
 384
 385         (if (equal desired actual)
 386             ;; We passed
 387             (setq pass (cons idx pass))
 388           ;; We failed.
 389           (setq fail (cons idx fail))
 390           (when (not (equal (car actual) (car desired)))
 391             (semantic-ia-utest-log
 392              "  Failed FNames %d: Actual: %S Desired: %S"
 393              idx (car actual) (car desired))
 394             (semantic-ia-utest-log
 395              "  Failed Tool: %s" (object-name symref-tool-used))
 396             )
 397           (when (not (equal (car (cdr actual)) (car (cdr desired))))
 398             (semantic-ia-utest-log
 399              "  Failed TNames %d: Actual: %S Desired: %S"
 400              idx (car (cdr actual)) (car (cdr desired)))
 401             (semantic-ia-utest-log
 402              "  Failed Tool: %s" (object-name symref-tool-used))
 403             )
 404           (add-to-list 'semantic-ia-utest-error-log-list
 405                        (list (buffer-name) idx)
 406                        )
 407           ))
 408
 409       (setq idx (1+ idx))
 410       (setq tag nil))
 411
 412     (if fail
 413         (progn
 414           (semantic-ia-utest-log
 415            "    Unit tests (symrefs) failed tests")
 416           )
 417       (semantic-ia-utest-log "    Unit tests (symrefs) passed (%d total)"
 418                              (- idx 1)))
 419
 420     ))
 421
 422 (defun semantic-src-utest-buffer-refs ()
 423   "Run a sym-ref counting unit-test pass in the current buffer."
 424
 425   ;; This line will also force the include, scope, and typecache.
 426   (semantic-clear-toplevel-cache)
 427   ;; Force tags to be parsed.
 428   (semantic-fetch-tags)
 429
 430   (let* ((idx 1)
 431          (start nil)
 432          (regex-p nil)
 433          (desired nil)
 434          (actual nil)
 435          (pass nil)
 436          (fail nil)
 437          ;; Exclude unpredictable system files in the
 438          ;; header include list.
 439          (semanticdb-find-default-throttle
 440           (remq 'system semanticdb-find-default-throttle))
 441          )
 442     ;; Keep looking for test points until we run out.
 443     (while (save-excursion
 444              (setq regex-p (concat "//\\s-*@"
 445                                    (number-to-string idx)
 446                                    "@\\s-+\\(\\w+\\)" ))
 447              (goto-char (point-min))
 448              (save-match-data
 449                (when (re-search-forward regex-p nil t)
 450                  (goto-char (match-beginning 1))
 451                  (setq desired (read (buffer-substring (point) (point-at-eol))))
 452                  (setq start (match-beginning 0))
 453                  (goto-char start)
 454                  (setq actual (semantic-symref-test-count-hits-in-tag))
 455                  start)))
 456
 457       (if (not actual)
 458           (progn
 459             (setq fail (cons idx fail))
 460             (semantic-ia-utest-log
 461              "  Failed symref count %d: No results." idx)
 462
 463             (add-to-list 'semantic-ia-utest-error-log-list
 464                          (list (buffer-name) idx)
 465                          )
 466             )
 467
 468         (if (equal desired actual)
 469             ;; We passed
 470             (setq pass (cons idx pass))
 471           ;; We failed.
 472           (setq fail (cons idx fail))
 473           (when (not (equal actual desired))
 474             (semantic-ia-utest-log
 475              "  Failed symref count %d: Actual: %S Desired: %S"
 476              idx actual desired)
 477             )
 478
 479           (add-to-list 'semantic-ia-utest-error-log-list
 480                        (list (buffer-name) idx)
 481                        )
 482           ))
 483
 484       (setq idx (1+ idx))
 485       )
 486
 487     (if fail
 488         (progn
 489           (semantic-ia-utest-log
 490            "    Unit tests (symrefs counter) failed tests")
 491           )
 492       (semantic-ia-utest-log "    Unit tests (symrefs counter) passed (%d total)"
 493                              (- idx 1)))
 494
 495     ))
 496
 497 (defun semantic-ia-utest-start-log ()
 498   "Start up a testlog for a run."
 499   ;; Redo w/ CEDET utest framework.
 500   (cedet-utest-log-start "semantic: analyzer tests"))
 501
 502 (defun semantic-ia-utest-log (&rest args)
 503   "Log some test results.
 504 Pass ARGS to format to create the log message."
 505   ;; Forward to CEDET utest framework.
 506   (apply 'cedet-utest-log args))
 507
 508 (provide 'semantic-ia-utest)
 509
 510 ;; arch-tag: 03ede3fb-7ef0-4500-a7c2-bbf647957310
 511 ;;; semantic-ia-utest.el ends here