view test/cedet/semantic-ia-utest.el @ 105396:7f82f9367cd1

(rmail-generate-viewer-buffer): Be more careful about reusing existing buffers, in case we happen to visit two files with the same basename. (Bug#4593)

;;; semantic-ia-utest.el --- Analyzer unit tests

;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.

;; Author: Eric M. Ludlam <[e-mail]>

;; This file is part of GNU Emacs.

;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Use marked-up files in the test directory and run the analyzer
;; on them.  Make sure the answers are correct.
;;
;; Each file has cursor keys in them of the form:
;;   // -#- ("ans1" "ans2" )
;; where # is 1, 2, 3, etc, and some sort of answer list.

;;; Code:
(require 'semantic)
(require 'semantic/analyze)
(require 'semantic/analyze/refs)
(require 'semantic/symref)
(require 'semantic/symref/filter)

(load-file "cedet-utests.el")

(defvar semantic-ia-utest-file-list
  '(
    "tests/testdoublens.cpp"
    "tests/testsubclass.cpp"
    "tests/testtypedefs.cpp"
    "tests/teststruct.cpp"
    "tests/testtemplates.cpp"
    "tests/testfriends.cpp"
    "tests/testusing.cpp"
    "tests/testnsp.cpp"
    "tests/testsppcomplete.c"
    "tests/testvarnames.c"
    "tests/testjavacomp.java"
    )
  "List of files with analyzer completion test points.")

(defvar semantic-ia-utest-error-log-list nil
  "List of errors occuring during a run.")

;;;###autoload
(defun semantic-ia-utest (&optional arg)
  "Run the semantic ia unit test against stored sources.
Argument ARG specifies which set of tests to run.
 1 - ia utests
 2 - regs utests
 3 - symrefs utests
 4 - symref count utests"
  (interactive "P")
  (save-excursion

    (let ((fl semantic-ia-utest-file-list)
	  (semantic-ia-utest-error-log-list nil)
	  )

      (cedet-utest-log-setup "ANALYZER")

      (set-buffer (semantic-find-file-noselect
		   (or (locate-library "semantic-ia-utest.el")
		       "semantic-ia-utest.el")))

      (while fl

	;; Make sure we have the files we think we have.
	(when (not (file-exists-p (car fl)))
	  (error "Cannot find unit test file: %s" (car fl)))

	;; Run the tests.
	(let ((fb (find-buffer-visiting (car fl)))
	      (b (semantic-find-file-noselect (car fl) t)))

	  ;; Run the test on it.
	  (save-excursion
	    (set-buffer b)

	    ;; This line will also force the include, scope, and typecache.
	    (semantic-clear-toplevel-cache)
	    ;; Force tags to be parsed.
	    (semantic-fetch-tags)

	    (semantic-ia-utest-log "  ** Starting tests in %s"
				   (buffer-name))

	    (when (or (not arg) (= arg 1))
	      (semantic-ia-utest-buffer))

	    (when (or (not arg) (= arg 2))
	      (set-buffer b)
	      (semantic-ia-utest-buffer-refs))

	    (when (or (not arg) (= arg 3))
	      (set-buffer b)
	      (semantic-sr-utest-buffer-refs))

	    (when (or (not arg) (= arg 4))
	      (set-buffer b)
	      (semantic-src-utest-buffer-refs))

	    (semantic-ia-utest-log "  ** Completed tests in %s\n"
				   (buffer-name))
	    )

	  ;; If it wasn't already in memory, whack it.
	  (when (not fb)
	    (kill-buffer b))
	  )
	(setq fl (cdr fl)))

      (cedet-utest-log-shutdown
       "ANALYZER"
       (when semantic-ia-utest-error-log-list
	 (format "%s Failures found."
		 (length semantic-ia-utest-error-log-list))))
      (when semantic-ia-utest-error-log-list
	(error "Failures found during analyzer unit tests"))
      ))
  )

(defun semantic-ia-utest-buffer ()
  "Run analyzer completion unit-test pass in the current buffer."

  (let* ((idx 1)
	 (regex-p nil)
	 (regex-a nil)
	 (p nil)
	 (a nil)
	 (pass nil)
	 (fail nil)
	 (actual nil)
	 (desired nil)
	 ;; Exclude unpredictable system files in the
	 ;; header include list.
	 (semanticdb-find-default-throttle
	  (remq 'system semanticdb-find-default-throttle))
	 )
    ;; Keep looking for test points until we run out.
    (while (save-excursion
	     (setq regex-p (concat "//\\s-*-" (number-to-string idx) "-" )
		   regex-a (concat "//\\s-*#" (number-to-string idx) "#" ))
	     (goto-char (point-min))
	     (save-match-data
	       (when (re-search-forward regex-p nil t)
		 (setq p (match-beginning 0))))
	     (save-match-data
	       (when (re-search-forward regex-a nil t)
		 (setq a (match-end 0))))
	     (and p a))

      (save-excursion

	(goto-char p)

	(let* ((ctxt (semantic-analyze-current-context))
	       (acomp
		(condition-case nil
		    (semantic-analyze-possible-completions ctxt)
		  (error nil))))
	  (setq actual (mapcar 'semantic-tag-name acomp)))

	(goto-char a)

	(let ((bss (buffer-substring-no-properties (point) (point-at-eol))))
	  (condition-case nil
	      (setq desired (read bss))
	    (error (setq desired (format "  FAILED TO PARSE: %S"
					 bss)))))

	(if (equal actual desired)
	    (setq pass (cons idx pass))
	  (setq fail (cons idx fail))
	  (semantic-ia-utest-log
	   "    Failed %d.  Desired: %S Actual %S"
	   idx desired actual)
	  (add-to-list 'semantic-ia-utest-error-log-list
		       (list (buffer-name) idx desired actual)
		       )

	  )
	)

      (setq p nil a nil)
      (setq idx (1+ idx)))

    (if fail
	(progn
	  (semantic-ia-utest-log
	   "    Unit tests (completions) failed tests %S"
	   (reverse fail))
	  )
      (semantic-ia-utest-log "    Unit tests (completions) passed (%d total)"
			     (- idx 1)))

    ))

(defun semantic-ia-utest-buffer-refs ()
  "Run a analyze-refs unit-test pass in the current buffer."

  (let* ((idx 1)
	 (regex-p nil)
	 (p nil)
	 (pass nil)
	 (fail nil)
	 ;; Exclude unpredictable system files in the
	 ;; header include list.
	 (semanticdb-find-default-throttle
	  (remq 'system semanticdb-find-default-throttle))
	 )
    ;; Keep looking for test points until we run out.
    (while (save-excursion
	     (setq regex-p (concat "//\\s-*\\^" (number-to-string idx) "^" )
		   )
	     (goto-char (point-min))
	     (save-match-data
	       (when (re-search-forward regex-p nil t)
		 (setq p (match-beginning 0))))
	     p)

      (save-excursion

	(goto-char p)
	(forward-char -1)

	(let* ((ct (semantic-current-tag))
	       (refs (semantic-analyze-tag-references ct))
	       (impl (semantic-analyze-refs-impl refs t))
	       (proto (semantic-analyze-refs-proto refs t))
	       (pf nil)
	       )
	  (setq
	   pf
	   (catch 'failed
	     (if (and impl proto (car impl) (car proto))
		 (let (ct2 ref2 impl2 proto2
			   newstart)
		   (cond
		    ((semantic-equivalent-tag-p (car impl) ct)
		     ;; We are on an IMPL.  Go To the proto, and find matches.
		     (semantic-go-to-tag (car proto))
		     (setq newstart (car proto))
		     )
		    ((semantic-equivalent-tag-p (car proto) ct)
		     ;; We are on a PROTO.  Go to the imple, and find matches
		     (semantic-go-to-tag (car impl))
		     (setq newstart (car impl))
		     )
		    (t
		     ;; No matches is a fail.
		     (throw 'failed t)
		     ))
		   ;; Get the new tag, does it match?
		   (setq ct2 (semantic-current-tag))

		   ;; Does it match?
		   (when (not (semantic-equivalent-tag-p ct2 newstart))
		     (throw 'failed t))

		   ;; Can we double-jump?
		   (setq ref2 (semantic-analyze-tag-references ct)
			 impl2 (semantic-analyze-refs-impl ref2 t)
			 proto2 (semantic-analyze-refs-proto ref2 t))

		   (when (or (not (and impl2 proto2))
			     (not
			      (and (semantic-equivalent-tag-p
				    (car impl) (car impl2))
				   (semantic-equivalent-tag-p
				    (car proto) (car proto2)))))
		     (throw 'failed t))
		   )

	       ;; Else, no matches at all, so another fail.
	       (throw 'failed t)
	       )))

	   (if (not pf)
	      ;; We passed
	      (setq pass (cons idx pass))
	    ;; We failed.
	    (setq fail (cons idx fail))
	    (semantic-ia-utest-log
	     "    Failed %d.  For %s (Num impls %d) (Num protos %d)"
	     idx (if ct (semantic-tag-name ct) "<No tag found>")
	     (length impl) (length proto))
	    (add-to-list 'semantic-ia-utest-error-log-list
			 (list (buffer-name) idx)
			 )
	    ))

	(setq p nil)
	(setq idx (1+ idx))

	))

    (if fail
	(progn
	  (semantic-ia-utest-log
	   "    Unit tests (refs) failed tests")
	  )
      (semantic-ia-utest-log "    Unit tests (refs) passed (%d total)"
			     (- idx 1)))

    ))

(defun semantic-sr-utest-buffer-refs ()
  "Run a symref unit-test pass in the current buffer."

  ;; This line will also force the include, scope, and typecache.
  (semantic-clear-toplevel-cache)
  ;; Force tags to be parsed.
  (semantic-fetch-tags)

  (let* ((idx 1)
	 (tag nil)
	 (regex-p nil)
	 (desired nil)
	 (actual-result nil)
	 (actual nil)
	 (pass nil)
	 (fail nil)
	 (symref-tool-used nil)
	 ;; Exclude unpredictable system files in the
	 ;; header include list.
	 (semanticdb-find-default-throttle
	  (remq 'system semanticdb-find-default-throttle))
	 )
    ;; Keep looking for test points until we run out.
    (while (save-excursion
	     (setq regex-p (concat "//\\s-*\\%" (number-to-string idx) "%" )
		   )
	     (goto-char (point-min))
	     (save-match-data
	       (when (re-search-forward regex-p nil t)
		 (setq tag (semantic-current-tag))
		 (goto-char (match-end 0))
		 (setq desired (read (buffer-substring (point) (point-at-eol))))
		 ))
	     tag)

      (setq actual-result (semantic-symref-find-references-by-name
			   (semantic-tag-name tag) 'target
			   'symref-tool-used))

      (if (not actual-result)
	  (progn
	    (setq fail (cons idx fail))
	    (semantic-ia-utest-log
	     "  Failed FNames %d: No results." idx)
	    (semantic-ia-utest-log
	     "  Failed Tool: %s" (object-name symref-tool-used))

	    (add-to-list 'semantic-ia-utest-error-log-list
			 (list (buffer-name) idx)
			 )
	    )

	(setq actual (list (sort (mapcar
				  'file-name-nondirectory
				  (semantic-symref-result-get-files actual-result))
				 'string<)
			   (sort
			    (mapcar
			     'semantic-format-tag-canonical-name
			     (semantic-symref-result-get-tags actual-result))
			    'string<)))


	(if (equal desired actual)
	    ;; We passed
	    (setq pass (cons idx pass))
	  ;; We failed.
	  (setq fail (cons idx fail))
	  (when (not (equal (car actual) (car desired)))
	    (semantic-ia-utest-log
	     "  Failed FNames %d: Actual: %S Desired: %S"
	     idx (car actual) (car desired))
	    (semantic-ia-utest-log
	     "  Failed Tool: %s" (object-name symref-tool-used))
	    )
	  (when (not (equal (car (cdr actual)) (car (cdr desired))))
	    (semantic-ia-utest-log
	     "  Failed TNames %d: Actual: %S Desired: %S"
	     idx (car (cdr actual)) (car (cdr desired)))
	    (semantic-ia-utest-log
	     "  Failed Tool: %s" (object-name symref-tool-used))
	    )
	  (add-to-list 'semantic-ia-utest-error-log-list
		       (list (buffer-name) idx)
		       )
	  ))

      (setq idx (1+ idx))
      (setq tag nil))

    (if fail
	(progn
	  (semantic-ia-utest-log
	   "    Unit tests (symrefs) failed tests")
	  )
      (semantic-ia-utest-log "    Unit tests (symrefs) passed (%d total)"
			     (- idx 1)))

    ))

(defun semantic-src-utest-buffer-refs ()
  "Run a sym-ref counting unit-test pass in the current buffer."

  ;; This line will also force the include, scope, and typecache.
  (semantic-clear-toplevel-cache)
  ;; Force tags to be parsed.
  (semantic-fetch-tags)

  (let* ((idx 1)
	 (start nil)
	 (regex-p nil)
	 (desired nil)
	 (actual nil)
	 (pass nil)
	 (fail nil)
	 ;; Exclude unpredictable system files in the
	 ;; header include list.
	 (semanticdb-find-default-throttle
	  (remq 'system semanticdb-find-default-throttle))
	 )
    ;; Keep looking for test points until we run out.
    (while (save-excursion
	     (setq regex-p (concat "//\\s-*@"
				   (number-to-string idx)
				   "@\\s-+\\(\\w+\\)" ))
	     (goto-char (point-min))
	     (save-match-data
	       (when (re-search-forward regex-p nil t)
		 (goto-char (match-beginning 1))
		 (setq desired (read (buffer-substring (point) (point-at-eol))))
		 (setq start (match-beginning 0))
		 (goto-char start)
		 (setq actual (semantic-symref-test-count-hits-in-tag))
		 start)))

      (if (not actual)
	  (progn
	    (setq fail (cons idx fail))
	    (semantic-ia-utest-log
	     "  Failed symref count %d: No results." idx)

	    (add-to-list 'semantic-ia-utest-error-log-list
			 (list (buffer-name) idx)
			 )
	    )

	(if (equal desired actual)
	    ;; We passed
	    (setq pass (cons idx pass))
	  ;; We failed.
	  (setq fail (cons idx fail))
	  (when (not (equal actual desired))
	    (semantic-ia-utest-log
	     "  Failed symref count %d: Actual: %S Desired: %S"
	     idx actual desired)
	    )

	  (add-to-list 'semantic-ia-utest-error-log-list
		       (list (buffer-name) idx)
		       )
	  ))

      (setq idx (1+ idx))
      )

    (if fail
	(progn
	  (semantic-ia-utest-log
	   "    Unit tests (symrefs counter) failed tests")
	  )
      (semantic-ia-utest-log "    Unit tests (symrefs counter) passed (%d total)"
			     (- idx 1)))

    ))

(defun semantic-ia-utest-start-log ()
  "Start up a testlog for a run."
  ;; Redo w/ CEDET utest framework.
  (cedet-utest-log-start "semantic: analyzer tests"))

(defun semantic-ia-utest-log (&rest args)
  "Log some test results.
Pass ARGS to format to create the log message."
  ;; Forward to CEDET utest framework.
  (apply 'cedet-utest-log args))

(provide 'semantic-ia-utest)

;; arch-tag: 03ede3fb-7ef0-4500-a7c2-bbf647957310
;;; semantic-ia-utest.el ends here