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