automated tests in test/lisp/cedet.
Author: Eric Ludlam <zappo@gnu.org>
--- /dev/null
+;;; semantic-utest-c.el --- C based parsing tests.
+
+;; Copyright (C) 2008-2019 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Run some C based parsing tests.
+
+(require 'ert)
+(require 'semantic)
+
+(defvar semantic-utest-c-comparisons
+ '( ("testsppreplace.c" . "testsppreplaced.c")
+ )
+ "List of files to parse and compare against each other.")
+
+(defvar cedet-utest-directory
+ (let* ((C (file-name-directory (locate-library "cedet")))
+ (D (expand-file-name "../../test/manual/cedet/" C)))
+ D)
+ "Location of test files for this test suite.")
+
+(defvar semantic-utest-c-test-directory (expand-file-name "tests" cedet-utest-directory)
+ "Location of test files.")
+
+;;; Code:
+;;;###autoload
+(ert-deftest semantic-test-c-preprocessor-simulation ()
+ "Run parsing test for C from the test directory."
+ (interactive)
+ (semantic-mode 1)
+ (dolist (fp semantic-utest-c-comparisons)
+ (let* ((semantic-lex-c-nested-namespace-ignore-second nil)
+ (tags-actual
+ (save-excursion
+ (set-buffer (find-file-noselect (expand-file-name (car fp) semantic-utest-c-test-directory)))
+ (semantic-clear-toplevel-cache)
+ (semantic-fetch-tags)))
+ (tags-expected
+ (save-excursion
+ (set-buffer (find-file-noselect (expand-file-name (cdr fp) semantic-utest-c-test-directory)))
+ (semantic-clear-toplevel-cache)
+ (semantic-fetch-tags))))
+ (when (or (not tags-expected) (not tags-actual))
+ (message "Tried to find test files in: %s" semantic-utest-c-test-directory)
+ (error "Failed: Disovered no tags in test files or test file not found."))
+
+ ;; Now that we have the tags, compare them for SPP accuracy.
+ (dolist (tag tags-actual)
+ (if (and (semantic-tag-of-class-p tag 'variable)
+ (semantic-tag-variable-constant-p tag))
+ nil ; skip the macros.
+
+ (if (semantic-tag-similar-with-subtags-p tag (car tags-expected))
+ (setq tags-expected (cdr tags-expected))
+ (with-mode-local c-mode
+ (should nil) ;; this is a fail condition
+ (message "Error: Found: >> %s << Expected: >> %s <<"
+ (semantic-format-tag-prototype tag nil t)
+ (semantic-format-tag-prototype (car tags-expected) nil t)
+ )))
+ ))
+ )))
+
+(require 'semantic/bovine/gcc)
+
+;; Example output of "gcc -v"
+(defvar semantic-gcc-test-strings
+ '(;; My old box:
+ "Reading specs from /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/specs
+Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --host=i386-redhat-linux
+Thread model: posix
+gcc version 3.2.2 20030222 (Red Hat Linux 3.2.2-5)"
+ ;; Alex Ott:
+ "Using built-in specs.
+Target: i486-linux-gnu
+Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.1-9ubuntu1' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu
+Thread model: posix
+gcc version 4.3.1 (Ubuntu 4.3.1-9ubuntu1)"
+ ;; My debian box:
+ "Using built-in specs.
+Target: x86_64-unknown-linux-gnu
+Configured with: ../../../sources/gcc/configure --prefix=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3 --with-gmp=/usr/local/gcc/gmp --with-mpfr=/usr/local/gcc/mpfr --enable-languages=c,c++,fortran --with-as=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/as --with-ld=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/ld --disable-multilib
+Thread model: posix
+gcc version 4.2.3"
+ ;; My mac:
+ "Using built-in specs.
+Target: i686-apple-darwin8
+Configured with: /private/var/tmp/gcc/gcc-5341.obj~1/src/configure --disable-checking -enable-werror --prefix=/usr --mandir=/share/man --enable-languages=c,objc,c++,obj-c++ --program-transform-name=/^[cg][^.-]*$/s/$/-4.0/ --with-gxx-include-dir=/include/c++/4.0.0 --with-slibdir=/usr/lib --build=powerpc-apple-darwin8 --with-arch=pentium-m --with-tune=prescott --program-prefix= --host=i686-apple-darwin8 --target=i686-apple-darwin8
+Thread model: posix
+gcc version 4.0.1 (Apple Computer, Inc. build 5341)"
+ ;; Ubuntu Intrepid
+ "Using built-in specs.
+Target: x86_64-linux-gnu
+Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-checking=release --build=x86_64-linux-gnu --host=x86_64-linux-gnu --target=x86_64-linux-gnu
+Thread model: posix
+gcc version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)"
+ ;; Red Hat EL4
+ "Reading specs from /usr/lib/gcc/x86_64-redhat-linux/3.4.6/specs
+Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-java-awt=gtk --host=x86_64-redhat-linux
+Thread model: posix
+gcc version 3.4.6 20060404 (Red Hat 3.4.6-10)"
+ ;; Red Hat EL5
+ "Using built-in specs.
+Target: x86_64-redhat-linux
+Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --enable-checking=release --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-libgcj-multifile --enable-languages=c,c++,objc,obj-c++,java,fortran,ada --enable-java-awt=gtk --disable-dssi --enable-plugin --with-java-home=/usr/lib/jvm/java-1.4.2-gcj-1.4.2.0/jre --with-cpu=generic --host=x86_64-redhat-linux
+Thread model: posix
+gcc version 4.1.2 20080704 (Red Hat 4.1.2-44)"
+ ;; David Engster's german gcc on ubuntu 4.3
+ "Es werden eingebaute Spezifikationen verwendet.
+Ziel: i486-linux-gnu
+Konfiguriert mit: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu
+Thread-Modell: posix
+gcc-Version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)"
+ ;; Damien Deville bsd
+ "Using built-in specs.
+Target: i386-undermydesk-freebsd
+Configured with: FreeBSD/i386 system compiler
+Thread model: posix
+gcc version 4.2.1 20070719 [FreeBSD]"
+ )
+ "A bunch of sample gcc -v outputs from different machines.")
+
+(defvar semantic-gcc-test-strings-fail
+ '(;; A really old solaris box I found
+ "Reading specs from /usr/local/gcc-2.95.2/lib/gcc-lib/sparc-sun-solaris2.6/2.95.2/specs
+gcc version 2.95.2 19991024 (release)"
+ )
+ "A bunch of sample gcc -v outputs that fail to provide the info we want.")
+
+(ert-deftest semantic-test-gcc-output-parser ()
+ "Test the output parser against some collected strings."
+ (let ((fail nil))
+ (dolist (S semantic-gcc-test-strings)
+ (let* ((fields (semantic-gcc-fields S))
+ (v (cdr (assoc 'version fields)))
+ (h (or (cdr (assoc 'target fields))
+ (cdr (assoc '--target fields))
+ (cdr (assoc '--host fields))))
+ (p (cdr (assoc '--prefix fields)))
+ )
+ ;; No longer test for prefixes.
+ (when (not (and v h))
+ (let ((strs (split-string S "\n")))
+ (message "Test failed on %S\nV H P:\n%S %S %S" (car strs) v h p)
+ ))
+ (should (and v h))
+ ))
+ (dolist (S semantic-gcc-test-strings-fail)
+ (let* ((fields (semantic-gcc-fields S))
+ (v (cdr (assoc 'version fields)))
+ (h (or (cdr (assoc '--host fields))
+ (cdr (assoc 'target fields))))
+ (p (cdr (assoc '--prefix fields)))
+ )
+ ;; negative test
+ (should-not (and v h p))
+ ))
+ ))
+
+
+(provide 'semantic-utest-c)
+
+;;; semantic-utest-c.el ends here
--- /dev/null
+;;; semantic-utest-ia.el --- Analyzer unit tests
+
+;; Copyright (C) 2008-2019 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+;; 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 <https://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)
+
+(defvar cedet-utest-directory
+ (let* ((C (file-name-directory (locate-library "cedet")))
+ (D (expand-file-name "../../test/manual/cedet/" C)))
+ D)
+ "Location of test files for this test suite.")
+
+(defvar semantic-utest-test-directory (expand-file-name "tests" cedet-utest-directory)
+ "Location of test files.")
+
+(ert-deftest semantic-utest-ia-doublens.cpp ()
+ (let ((tst (expand-file-name "testdoublens.cpp" semantic-utest-test-directory)))
+ (should (file-exists-p tst))
+ (should-not (semantic-ia-utest tst))))
+
+(ert-deftest semantic-utest-ia-subclass.cpp ()
+ (let ((tst (expand-file-name "testsubclass.cpp" semantic-utest-test-directory)))
+ (should (file-exists-p tst))
+ (should-not (semantic-ia-utest tst))))
+
+(ert-deftest semantic-utest-ia-typedefs.cpp ()
+ (let ((tst (expand-file-name "testtypedefs.cpp" semantic-utest-test-directory)))
+ (should (file-exists-p tst))
+ (should-not (semantic-ia-utest tst))))
+
+(ert-deftest semantic-utest-ia-friends.cpp ()
+ (let ((tst (expand-file-name "testfriends.cpp" semantic-utest-test-directory)))
+ (should (file-exists-p tst))
+ (should-not (semantic-ia-utest tst))))
+
+(ert-deftest semantic-utest-ia-namespace.cpp ()
+ (let ((tst (expand-file-name "testnsp.cpp" semantic-utest-test-directory)))
+ (should (file-exists-p tst))
+ (should-not (semantic-ia-utest tst))))
+
+(ert-deftest semantic-utest-ia-sppcomplete.c ()
+ (let ((tst (expand-file-name "testsppcomplete.c" semantic-utest-test-directory)))
+ (should (file-exists-p tst))
+ (should-not (semantic-ia-utest tst))))
+
+(ert-deftest semantic-utest-ia-varnames.c ()
+ (let ((tst (expand-file-name "testvarnames.c" semantic-utest-test-directory)))
+ (should (file-exists-p tst))
+ (should-not (semantic-ia-utest tst))))
+
+(ert-deftest semantic-utest-ia-javacomp.java ()
+ (let ((tst (expand-file-name "testjavacomp.java" semantic-utest-test-directory)))
+ (should (file-exists-p tst))
+ (should-not (semantic-ia-utest tst))))
+
+;;; Core testing utility
+(defun semantic-ia-utest (testfile)
+ "Run the semantic ia unit test against stored sources."
+ (semantic-mode 1)
+ (let ((b (semantic-find-file-noselect testfile t)))
+
+ ;; Run the test on it.
+ (with-current-buffer b
+
+ ;; This line will also force the include, scope, and typecache.
+ (semantic-clear-toplevel-cache)
+ ;; Force tags to be parsed.
+ (semantic-fetch-tags)
+
+ (prog1
+ (or (semantic-ia-utest-buffer)
+ (semantic-ia-utest-buffer-refs)
+ (semantic-sr-utest-buffer-refs)
+ (semantic-src-utest-buffer-refs))
+
+ (kill-buffer b)
+ ))))
+
+(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
+ (list
+ (format "Failed %d. Desired: %S Actual %S"
+ idx desired actual)
+ )
+ fail)))
+
+ (setq p nil a nil)
+ (setq idx (1+ idx)))
+ )
+
+ (when fail
+ (cons "COMPLETION SUBTEST" fail))
+ ))
+
+(defun semantic-ia-utest-buffer-refs ()
+ "Run an 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
+ (list
+ (message "Test id %d. For %s (Num impls %d) (Num protos %d)"
+ idx (if ct (semantic-tag-name ct) "<No tag found>")
+ (length impl) (length proto))
+ )
+ fail))
+ ))
+ (setq p nil)
+ (setq idx (1+ idx))))
+ (when fail
+ (cons "ANALYZER REF COUNTING SUBTEST" fail))))
+
+(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))
+ (message "Failed Tool: %s" (eieio-object-name symref-tool-used))
+ )
+
+ (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 (list
+ (when (not (equal (car actual) (car desired)))
+ (list
+ (format "Actual: %S Desired: %S"
+ (car actual) (car desired))
+ (format "Failed Tool: %s" (eieio-object-name symref-tool-used))
+ ))
+ (when (not (equal (car (cdr actual)) (car (cdr desired))))
+ (list (format
+ "Actual: %S Desired: %S"
+ (car (cdr actual)) (car (cdr desired)))
+ (format
+ "Failed Tool: %s" (eieio-object-name symref-tool-used)))))
+ fail))
+ ))
+
+ (setq idx (1+ idx))
+ (setq tag nil))
+
+ (when fail
+ (cons "SYMREF SUBTEST" fail))))
+
+(defun semantic-symref-test-count-hits-in-tag ()
+ "Lookup in the current tag the symbol under point.
+Then count all the other references to the same symbol within the
+tag that contains point, and return that."
+ (interactive)
+ (let* ((ctxt (semantic-analyze-current-context))
+ (target (car (reverse (oref ctxt prefix))))
+ (tag (semantic-current-tag))
+ (start (current-time))
+ (Lcount 0))
+ (when (semantic-tag-p target)
+ (semantic-symref-hits-in-region
+ target (lambda (start end prefix) (setq Lcount (1+ Lcount)))
+ (semantic-tag-start tag)
+ (semantic-tag-end tag))
+ Lcount)))
+
+(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
+ (list
+ (format
+ "Symref id %d: No results." idx))
+ fail))
+
+ )
+
+ (if (equal desired actual)
+ ;; We passed
+ (setq pass (cons idx pass))
+ ;; We failed.
+ (setq fail (cons (list
+ (when (not (equal actual desired))
+ (format
+ "Symref id %d: Actual: %S Desired: %S"
+ idx actual desired)
+ )
+ )
+ fail))
+ ))
+
+ (setq idx (1+ idx))
+ )
+
+ (when fail
+ (cons "SYMREF COUNTING SUBTEST" fail))))
+
+(provide 'semantic-ia-utest)
+
+;;; semantic-ia-utest.el ends here
--- /dev/null
+;;; semantic-utest.el --- Tests for semantic's parsing system.
+
+;;; Copyright (C) 2003-2004, 2007-2019 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantic's parsing and partial parsing system is pretty complex.
+;; These unit tests attempt to emulate semantic's partial reparsing
+;; and full reparsing system, and anything else I may feel the urge
+;; to write a test for.
+
+(require 'cedet)
+(require 'semantic)
+
+(defvar cedet-utest-directory
+ (let* ((C (file-name-directory (locate-library "cedet")))
+ (D (expand-file-name "../../test/manual/cedet/" C)))
+ D)
+ "Location of test files for this test suite.")
+
+(defvar semantic-utest-test-directory (expand-file-name "tests" cedet-utest-directory)
+ "Location of test files.")
+
+(defvar semantic-utest-temp-directory (if (fboundp 'temp-directory)
+ (temp-directory)
+ temporary-file-directory)
+ "Temporary directory to use when creating files.")
+
+(defun semantic-utest-fname (name)
+ "Create a filename for NAME in /tmp."
+ (expand-file-name name semantic-utest-temp-directory))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data for C tests
+
+(defvar semantic-utest-C-buffer-contents
+ "/* Test file for C language for Unit Tests */
+
+#include <stdio.h>
+#include \"sutest.h\"
+
+struct mystruct1 {
+ int slot11;
+ char slot12;
+ float slot13;
+};
+
+int var1;
+
+float funp1(char arg11, char arg12);
+
+char fun2(int arg_21, int arg_22) /*1*/
+{
+ struct mystruct1 *ms1 = malloc(sizeof(struct mystruct1));
+
+ char sv = calc_sv(var1);
+
+ if (var1 == 0) {
+ sv = 1;
+ } else if (arg_21 == 0) {
+ sv = 2;
+ } else if (arg_22 == 0) {
+ sv = 3;
+ } else {
+ sv = 4;
+ }
+
+ printf(\"SV = %d\\n\", sv);
+
+ /* Memory Leak */
+ ms1.slot1 = sv;
+
+ return 'A' + sv;
+}
+"
+ "Contents of a C buffer initialized by this unit test.
+Be sure to change `semantic-utest-C-name-contents' when you
+change this variable.")
+
+(defvar semantic-utest-C-h-buffer-contents
+ "/* Test file for C language header file for Unit Tests */
+
+int calc_sv(int);
+
+"
+ "Contents of a C header file buffer initialized by this unit test.")
+
+(defvar semantic-utest-C-filename (semantic-utest-fname "sutest.c")
+ "File to open and erase during this test for C.")
+
+(defvar semantic-utest-C-filename-h
+ (concat (file-name-sans-extension semantic-utest-C-filename)
+ ".h")
+ "Header file filename for C")
+
+
+(defvar semantic-utest-C-name-contents
+ '(("stdio.h" include
+ (:system-flag t)
+ nil (overlay 48 66 "sutest.c"))
+ ("sutest.h" include nil nil (overlay 67 86 "sutest.c"))
+ ("mystruct1" type
+ (:members
+ (("slot11" variable
+ (:type "int")
+ (reparse-symbol classsubparts)
+ (overlay 109 120 "sutest.c"))
+ ("slot12" variable
+ (:type "char")
+ (reparse-symbol classsubparts)
+ (overlay 123 135 "sutest.c"))
+ ("slot13" variable
+ (:type "float")
+ (reparse-symbol classsubparts)
+ (overlay 138 151 "sutest.c")))
+ :type "struct")
+ nil (overlay 88 154 "sutest.c"))
+ ("var1" variable
+ (:type "int")
+ nil (overlay 156 165 "sutest.c"))
+ ("funp1" function
+ (:prototype-flag t :arguments
+ (("arg11" variable
+ (:type "char")
+ (reparse-symbol arg-sub-list)
+ (overlay 179 190 "sutest.c"))
+ ("arg12" variable
+ (:type "char")
+ (reparse-symbol arg-sub-list)
+ (overlay 191 202 "sutest.c")))
+ :type "float")
+ nil (overlay 167 203 "sutest.c"))
+ ("fun2" function
+ (:arguments
+ (("arg_21" variable
+ (:type "int")
+ (reparse-symbol arg-sub-list)
+ (overlay 215 226 "sutest.c"))
+ ("arg_22" variable
+ (:type "int")
+ (reparse-symbol arg-sub-list)
+ (overlay 227 238 "sutest.c")))
+ :type "char")
+ nil (overlay 205 566 "sutest.c")))
+ "List of expected tag names for C.")
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data for Python tests
+
+(defvar semantic-utest-Python-buffer-contents
+"
+def fun1(a,b,c):
+ return a
+
+def fun2(a,b,c): #1
+ return b
+
+"
+
+
+)
+; "python test case. notice that python is indentation sensitive
+
+
+(defvar semantic-utest-Python-name-contents
+ '(("fun1" function
+ (:arguments
+ (("a" variable nil
+ (reparse-symbol function_parameters)
+ (overlay 10 11 "tst.py"))
+ ("b" variable nil
+ (reparse-symbol function_parameters)
+ (overlay 12 13 "tst.py"))
+ ("c" variable nil
+ (reparse-symbol function_parameters)
+ (overlay 14 15 "tst.py"))))
+ nil (overlay 1 31 "tst.py"))
+ ("fun2" function
+ (:arguments
+ (("a" variable nil
+ (reparse-symbol function_parameters)
+ (overlay 41 42 "tst.py"))
+ ("b" variable nil
+ (reparse-symbol function_parameters)
+ (overlay 43 44 "tst.py"))
+ ("c" variable nil
+ (reparse-symbol function_parameters)
+ (overlay 45 46 "tst.py"))))
+ nil (overlay 32 65 "tst.py")))
+
+ "List of expected tag names for Python.")
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data for Java tests
+
+(defvar semantic-utest-Java-buffer-contents
+"
+class JavaTest{
+ void fun1(int a,int b){
+ return a;
+ }
+
+ void fun2(int a,int b){ //1
+ return b;
+ }
+
+}
+"
+)
+
+(defvar semantic-utest-Java-name-contents
+ '(("JavaTest" type
+ (:members
+ (("fun1" function
+ (:arguments
+ (("a" variable
+ (:type "int")
+ (reparse-symbol formal_parameters)
+ (overlay 30 35 "JavaTest.java"))
+ ("b" variable
+ (:type "int")
+ (reparse-symbol formal_parameters)
+ (overlay 36 41 "JavaTest.java")))
+ :type "void")
+ (reparse-symbol class_member_declaration)
+ (overlay 20 61 "JavaTest.java"))
+ ("fun2" function
+ (:arguments
+ (("a" variable
+ (:type "int")
+ (reparse-symbol formal_parameters)
+ (overlay 75 80 "JavaTest.java"))
+ ("b" variable
+ (:type "int")
+ (reparse-symbol formal_parameters)
+ (overlay 81 86 "JavaTest.java")))
+ :type "void")
+ (reparse-symbol class_member_declaration)
+ (overlay 65 110 "JavaTest.java")))
+ :type "class")
+ nil (overlay 2 113 "JavaTest.java")))
+ "List of expected tag names for Java."
+ )
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data for Javascript tests
+
+(defvar semantic-utest-Javascript-buffer-contents
+"
+function fun1(a, b){
+ return a;
+ }
+
+function fun2(a,b){ //1
+ return b;
+ }
+"
+)
+
+
+(defvar semantic-utest-Javascript-name-contents
+ '(("fun1" function
+ (:arguments
+ (("a" variable nil
+ (reparse-symbol FormalParameterList)
+ (overlay 15 16 "tst.js"))
+ ("b" variable nil
+ (reparse-symbol FormalParameterList)
+ (overlay 18 19 "tst.js"))))
+ nil (overlay 1 39 "tst.js"))
+ ("fun2" function
+ (:arguments
+ (("a" variable nil
+ (reparse-symbol FormalParameterList)
+ (overlay 55 56 "tst.js"))
+ ("b" variable nil
+ (reparse-symbol FormalParameterList)
+ (overlay 57 58 "tst.js"))))
+ nil (overlay 41 82 "tst.js")))
+
+ "List of expected tag names for Javascript.")
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data for Makefile tests
+
+(defvar semantic-utest-Makefile-buffer-contents
+"
+t1:
+\techo t1
+
+t2:t1 #1
+\techo t2
+
+
+"
+)
+
+
+(defvar semantic-utest-Makefile-name-contents
+ '(("t1" function nil nil (overlay 1 9 "Makefile"))
+ ("t2" function
+ (:arguments
+ ("t1"))
+ nil (overlay 18 28 "Makefile")))
+ "List of expected tag names for Makefile.")
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data for Scheme tests
+
+(defvar semantic-utest-Scheme-buffer-contents
+ "
+ (define fun1 2)
+
+ (define fun2 3) ;1
+
+")
+
+(defvar semantic-utest-Scheme-name-contents
+ '(("fun1" variable
+ (:default-value ("2"))
+ nil (overlay 3 18 "tst.scm"))
+ ("fun2" variable
+ (:default-value ("3"))
+ nil (overlay 21 55 "tst.scm")))
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data for Html tests
+
+(defvar semantic-utest-Html-buffer-contents
+ "
+<html>
+ <body>
+ <h1>hello</h1>
+ </body><!--1-->
+</html>
+"
+ )
+
+(defvar semantic-utest-Html-name-contents
+ '(("hello" section
+ (:members
+ (("hello" section nil nil (overlay 21 24 "tst.html"))))
+ nil (overlay 10 15 "tst.html")))
+ )
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data for PHP tests
+
+(defvar semantic-utest-PHP-buffer-contents
+ "<?php
+
+function fun1(){
+ return \"fun1\";
+}
+
+function fun2($arg1){
+ $output = \"argument to fun2: \" . $arg1;
+ return $output;
+}
+
+class aClass {
+ public function fun1($a, $b){
+ return $a;
+ }
+
+ public function fun2($a, $b){
+ return $b;
+ }
+}
+?> "
+ )
+
+(defvar semantic-utest-PHP-name-contents
+ '(("fun1" function nil
+ nil (overlay 9 45 "phptest.php"))
+ ("fun2" function
+ (:arguments (("$arg1" variable nil (reparse-symbol formal_parameters) (overlay 61 66 "phptest.php"))))
+ nil
+ (overlay 47 132 "phptest.php"))
+ ("aClass" type
+ (:members (("fun1" function
+ (:typemodifiers ("public") :arguments
+ (("$a" variable nil (reparse-symbol formal_parameters) (overlay 174 176 "phptest.php"))
+ ("$b" variable nil (reparse-symbol formal_parameters) (overlay 178 180 "phptest.php"))))
+
+ nil
+ (overlay 153 204 "phptest.php"))
+
+ ("fun2" function
+ (:typemodifiers ("public") :arguments
+ (("$a" variable nil (reparse-symbol formal_parameters) (overlay 230 232 "phptest.php"))
+ ("$b" variable nil (reparse-symbol formal_parameters) (overlay 234 236 "phptest.php"))
+ ))
+ nil
+ (overlay 209 260 "phptest.php"))) :type "class")
+ nil
+ (overlay 135 262 "phptest.php"))
+ )
+ "Expected results from the PHP Unit test"
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data for Csharp C# tests
+
+(defvar semantic-utest-Csharp-buffer-contents
+"
+class someClass {
+ int fun1(int a, int b) {
+ return a; }
+ int fun2(int a, int b) {
+ return b; }
+}
+")
+
+(defvar semantic-utest-Csharp-name-contents
+ '(("someClass" type
+ (:members
+ (("fun1" function
+ (:arguments
+ (("a" variable
+ (:type "int")
+ (reparse-symbol formal_parameters)
+ (overlay 30 35 "tst.cs"))
+ ("b" variable
+ (:type "int")
+ (reparse-symbol formal_parameters)
+ (overlay 37 42 "tst.cs")))
+ :type "int")
+ (reparse-symbol class_member_declaration)
+ (overlay 21 61 "tst.cs"))
+ ("fun2" function
+ (:arguments
+ (("a" variable
+ (:type "int")
+ (reparse-symbol formal_parameters)
+ (overlay 73 78 "tst.cs"))
+ ("b" variable
+ (:type "int")
+ (reparse-symbol formal_parameters)
+ (overlay 80 85 "tst.cs")))
+ :type "int")
+ (reparse-symbol class_member_declaration)
+ (overlay 64 104 "tst.cs")))
+ :type "class")
+ nil (overlay 1 106 "tst.cs")))
+ )
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+(defun semantic-utest-makebuffer (filename contents)
+ "Create a buffer for FILENAME for use in a unit test.
+Pre-fill the buffer with CONTENTS."
+ (let ((buff (semantic-find-file-noselect filename)))
+ (set-buffer buff)
+ (setq buffer-offer-save nil)
+ (font-lock-mode -1) ;; Font lock has issues in Emacs 23
+ (toggle-read-only -1) ;; In case /tmp doesn't exist.
+ (erase-buffer)
+ (insert contents)
+ ;(semantic-fetch-tags) ;JAVE could this go here?
+ (set-buffer-modified-p nil)
+ buff
+ )
+ )
+
+(ert-deftest semantic-utest-C ()
+ "Run semantic's C unit test."
+ (semantic-mode 1)
+ (save-excursion
+ (let ((buff (semantic-utest-makebuffer semantic-utest-C-filename semantic-utest-C-buffer-contents))
+ (buff2 (semantic-utest-makebuffer semantic-utest-C-filename-h semantic-utest-C-h-buffer-contents))
+ )
+ (semantic-fetch-tags)
+ (set-buffer buff)
+
+ ;; Turn off a range of modes
+ (semantic-idle-scheduler-mode -1)
+
+ ;; Turn on some modes
+ (semantic-highlight-edits-mode 1)
+
+ ;; Update tags, and show it.
+ (semantic-fetch-tags)
+
+ ;; Run the tests.
+ ;;(message "First parsing test.")
+ (should (semantic-utest-verify-names semantic-utest-C-name-contents))
+
+ ;;(message "Invalid tag test.")
+ (semantic-utest-last-invalid semantic-utest-C-name-contents '("fun2") "/\\*1\\*/" "/* Deleted this line */")
+ (should (semantic-utest-verify-names semantic-utest-C-name-contents))
+
+ (set-buffer-modified-p nil)
+ ;; Clean up
+ (kill-buffer buff)
+ (kill-buffer buff2)
+ )))
+
+
+
+
+(defun semantic-utest-generic (testname filename contents name-contents names-removed killme insertme)
+ "Generic unit test according to template.
+Should work for languages without .h files, python javascript java.
+TESTNAME is the name of the test.
+FILENAME is the name of the file to create.
+CONTENTS is the contents of the file to test.
+NAME-CONTENTS is the list of names that should be in the contents.
+NAMES-REMOVED is the list of names that gets removed in the removal step.
+KILLME is the name of items to be killed.
+INSERTME is the text to be inserted after the deletion."
+ (semantic-mode 1)
+ (save-excursion
+ (let ((buff (semantic-utest-makebuffer filename contents))
+ )
+ ;; Turn off a range of modes
+ (semantic-idle-scheduler-mode -1)
+
+ ;; Turn on some modes
+ (semantic-highlight-edits-mode 1)
+
+ ;; Update tags, and show it.
+ (semantic-clear-toplevel-cache)
+ (semantic-fetch-tags)
+ (switch-to-buffer buff)
+ (sit-for 0)
+
+ ;; Run the tests.
+ ;;(message "First parsing test %s." testname)
+ (should (semantic-utest-verify-names name-contents))
+
+ ;;(message "Invalid tag test %s." testname)
+ (semantic-utest-last-invalid name-contents names-removed killme insertme)
+ (should (semantic-utest-verify-names name-contents))
+
+ (set-buffer-modified-p nil)
+ ;; Clean up
+ (kill-buffer buff)
+ )))
+
+(ert-deftest semantic-utest-Python()
+ (skip-unless (featurep 'python-mode))
+ (let ((python-indent-guess-indent-offset nil))
+ (semantic-utest-generic "Python" (semantic-utest-fname "pytest.py") semantic-utest-Python-buffer-contents semantic-utest-Python-name-contents '("fun2") "#1" "#deleted line")
+ ))
+
+
+(ert-deftest semantic-utest-Javascript()
+ (if (fboundp 'javascript-mode)
+ (semantic-utest-generic "Javascript" (semantic-utest-fname "javascripttest.js") semantic-utest-Javascript-buffer-contents semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line")
+ (message "Skipping JavaScript test: NO major mode."))
+ )
+
+(ert-deftest semantic-utest-Java()
+ ;; If JDE is installed, it might mess things up depending on the version
+ ;; that was installed.
+ (let ((auto-mode-alist '(("\\.java\\'" . java-mode))))
+ (semantic-utest-generic "Java" (semantic-utest-fname "JavaTest.java") semantic-utest-Java-buffer-contents semantic-utest-Java-name-contents '("fun2") "//1" "//deleted line")
+ ))
+
+(ert-deftest semantic-utest-Makefile()
+ (semantic-utest-generic "Makefile" (semantic-utest-fname "Makefile") semantic-utest-Makefile-buffer-contents semantic-utest-Makefile-name-contents '("fun2") "#1" "#deleted line")
+ )
+
+(ert-deftest semantic-utest-Scheme()
+ (skip-unless nil) ;; There is a bug w/ scheme parser. Skip this for now.
+ (semantic-utest-generic "Scheme" (semantic-utest-fname "tst.scm") semantic-utest-Scheme-buffer-contents semantic-utest-Scheme-name-contents '("fun2") ";1" ";deleted line")
+ )
+
+
+(ert-deftest semantic-utest-Html()
+ ;; Disable html-helper auto-fill-in mode.
+ (let ((html-helper-build-new-buffer nil))
+ (semantic-utest-generic "HTML" (semantic-utest-fname "tst.html") semantic-utest-Html-buffer-contents semantic-utest-Html-name-contents '("fun2") "<!--1-->" "<!--deleted line-->")
+ ))
+
+(ert-deftest semantic-utest-PHP()
+ (skip-unless (featurep 'php-mode))
+ (semantic-utest-generic "PHP" (semantic-utest-fname "phptest.php") semantic-utest-PHP-buffer-contents semantic-utest-PHP-name-contents '("fun1") "fun2" "%^@")
+ )
+
+;look at http://mfgames.com/linux/csharp-mode
+(ert-deftest semantic-utest-Csharp() ;; hmm i don't even know how to edit a scharp file. need a csharp mode implementation i suppose
+ (skip-unless (featurep 'csharp-mode))
+ (semantic-utest-generic "C#" (semantic-utest-fname "csharptest.cs") semantic-utest-Csharp-buffer-contents semantic-utest-Csharp-name-contents '("fun2") "//1" "//deleted line")
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; stubs
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; stuff for Erlang
+;;-module(hello).
+;-export([hello_world/0]).
+;
+;hello_world()->
+; io:format("Hello World ~n").
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;(defun semantic-utest-Erlang()
+; (interactive)
+; (semantic-utest-generic "Erlang" (semantic-utest-fname "tst.erl") semantic-utest-Erlang-buffer-contents semantic-utest-Erlang-name-contents '("fun2") "//1" "//deleted line")
+; )
+;
+;;texi is also supported
+;(defun semantic-utest-Texi()
+; (interactive)
+; (semantic-utest-generic "texi" (semantic-utest-fname "tst.texi") semantic-utest-Texi-buffer-contents semantic-utest-Texi-name-contents '("fun2") "//1" "//deleted line")
+; )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;; Buffer contents validation
+;;
+(defun semantic-utest-match-attributes (attr1 attr2 skipnames)
+ "Compare attribute lists ATTR1 and ATTR2.
+Argument SKIPNAMES is a list of names that may be child nodes to skip."
+ (let ((res t))
+ (while (and res attr1 attr2)
+
+ ;; Compare
+ (setq res
+ (cond ((and (listp (car attr1))
+ (semantic-tag-p (car (car attr1))))
+ ;; Compare the list of tags...
+ (semantic-utest-taglists-equivalent-p
+ (car attr2) (car attr1) skipnames)
+ )
+ (t
+ (equal (car attr1) (car attr2)))))
+
+ (if (not res)
+ (error "TAG INTERNAL DIFF: %S %S"
+ (car attr1) (car attr2)))
+
+ (setq attr1 (cdr attr1)
+ attr2 (cdr attr2)))
+ res))
+
+(defun semantic-utest-equivalent-tag-p (tag1 tag2 skipnames)
+ "Determine if TAG1 and TAG2 are the same.
+SKIPNAMES includes lists of possible child nodes that should be missing."
+ (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2))
+ (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))
+ (semantic-utest-match-attributes
+ (semantic-tag-attributes tag1) (semantic-tag-attributes tag2)
+ skipnames)
+ ))
+
+(defun semantic-utest-taglists-equivalent-p (table names skipnames)
+ "Compare TABLE and NAMES, where skipnames allow list1 to be different.
+SKIPNAMES is a list of names that should be skipped in the NAMES list."
+ (let ((SN skipnames))
+ (while SN
+ (setq names (remove (car SN) names))
+ (setq SN (cdr SN))))
+ (catch 'utest-err
+ (while (and names table)
+ (when (not (semantic-utest-equivalent-tag-p (car names)
+ (car table)
+ skipnames))
+ (message "Semantic Parse Test Fail: Expected %s, found %s"
+ (semantic-format-tag-prototype (car names))
+ (semantic-format-tag-prototype (car table)))
+ (throw 'utest-err nil)
+ )
+ (setq names (cdr names)
+ table (cdr table)))
+ (when names
+ (message "Semantic Parse Test Fail: Items forgotten: %S" (mapcar 'semantic-tag-name names))
+ (throw 'utest-err nil))
+ (when table
+ (message "Semantic parse Test Fail: Items extra: %S" (mapcar 'semantic-tag-name table))
+ (throw 'utest-err nil))
+ t))
+
+(defun semantic-utest-verify-names (name-contents &optional skipnames)
+ "Verify the names of the test buffer from NAME-CONTENTS.
+Argument SKIPNAMES is a list of names that should be skipped
+when analyzing the file.
+
+JAVE this thing would need to be recursive to handle java and csharp"
+ (let ((names name-contents)
+ (table (semantic-fetch-tags))
+ )
+ (semantic-utest-taglists-equivalent-p table names skipnames)
+ ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;
+; JAVE redefine a new validation function
+; is not quite as good as the old one yet
+(defun semantic-utest-verify-names-jave (name-contents &optional skipnames)
+ "JAVE version of `semantic-utest-verify-names'.
+NAME-CONTENTS is a sample of the tags buffer to test against.
+SKIPNAMES is a list of names to remove from NAME-CONTENTS"
+ (assert (semantic-utest-verify-names-2 name-contents (semantic-fetch-tags))
+ nil "failed test")
+)
+
+(defun semantic-utest-verify-names-2 (l1 l2)
+ (cond ( (and (consp l1) (equal (car l1) 'overlay))
+ (overlayp l2))
+ ((not (consp l1))
+ (equal l1 l2))
+ ((consp l1)
+ (and (semantic-utest-verify-names-2 (car l1) (car l2)) (semantic-utest-verify-names-2 (cdr l1) (cdr l2))))
+ (t (error "internal error"))))
+
+
+
+
+
+;;; Kill indicator line
+;;
+;; Utilities to modify the buffer for reparse, making sure a specific tag is deleted
+;; via the incremental parser.
+
+(defvar semantic-utest-last-kill-text nil
+ "The text from the last kill.")
+
+(defvar semantic-utest-last-kill-pos nil
+ "The position of the last kill.")
+
+(defun semantic-utest-kill-indicator ( killme insertme)
+ "Kill the line with KILLME on it and insert INSERTME in its place."
+ (goto-char (point-min))
+; (re-search-forward (concat "/\\*" indicator "\\*/")); JAVE this isn't generic enough for different languages
+ (re-search-forward killme)
+ (beginning-of-line)
+ (setq semantic-utest-last-kill-pos (point))
+ (setq semantic-utest-last-kill-text
+ (buffer-substring (point) (point-at-eol)))
+ (delete-region (point) (point-at-eol))
+ (insert insertme)
+ (sit-for 0)
+)
+
+(defun semantic-utest-unkill-indicator ()
+ "Unkill the last indicator."
+ (goto-char semantic-utest-last-kill-pos)
+ (delete-region (point) (point-at-eol))
+ (insert semantic-utest-last-kill-text)
+ (sit-for 0)
+ )
+
+(defun semantic-utest-last-invalid (name-contents names-removed killme insertme)
+ "Make the last fcn invalid."
+ (semantic-utest-kill-indicator killme insertme)
+; (semantic-utest-verify-names name-contents names-removed); verify its gone ;new validator doesn't handle skipnames yet
+ (semantic-utest-unkill-indicator);put back killed stuff
+ )
+
+
+
+;;; semantic-utest.el ends here
+++ /dev/null
-;;; semantic-ia-utest.el --- Analyzer unit tests
-
-;; Copyright (C) 2008-2019 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-
-;; 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 <https://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/testfriends.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 occurring 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 an 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-symref-test-count-hits-in-tag ()
- "Lookup in the current tag the symbol under point.
-Then count all the other references to the same symbol within the
-tag that contains point, and return that."
- (interactive)
- (let* ((ctxt (semantic-analyze-current-context))
- (target (car (reverse (oref ctxt prefix))))
- (tag (semantic-current-tag))
- (start (current-time))
- (Lcount 0))
- (when (semantic-tag-p target)
- (semantic-symref-hits-in-region
- target (lambda (start end prefix) (setq Lcount (1+ Lcount)))
- (semantic-tag-start tag)
- (semantic-tag-end tag))
- (when (interactive-p)
- (message "Found %d occurrences of %s in %.2f seconds"
- Lcount (semantic-tag-name target)
- (semantic-elapsed-time start nil)))
- Lcount)))
-
-(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)
-
-;;; semantic-ia-utest.el ends here
+++ /dev/null
-;;; semantic-utest-c.el --- C based parsing tests.
-
-;; Copyright (C) 2008-2019 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Run some C based parsing tests.
-
-(require 'semantic)
-
-(defvar semantic-utest-c-comparisons
- '( ("testsppreplace.c" . "testsppreplaced.c")
- )
- "List of files to parse and compare against each other.")
-
-;;; Code:
-;;;###autoload
-(defun semantic-utest-c ()
- "Run parsing test for C from the test directory."
- (interactive)
- (dolist (fp semantic-utest-c-comparisons)
- (let* ((sem (locate-library "semantic"))
- (sdir (file-name-directory sem))
- (semantic-lex-c-nested-namespace-ignore-second nil)
- (tags-actual
- (save-excursion
- (set-buffer (find-file-noselect (expand-file-name (concat "tests/" (car fp)) sdir)))
- (semantic-clear-toplevel-cache)
- (semantic-fetch-tags)))
- (tags-expected
- (save-excursion
- (set-buffer (find-file-noselect (expand-file-name (concat "tests/" (cdr fp)) sdir)))
- (semantic-clear-toplevel-cache)
- (semantic-fetch-tags))))
- ;; Now that we have the tags, compare them for SPP accuracy.
- (dolist (tag tags-actual)
- (if (and (semantic-tag-of-class-p tag 'variable)
- (semantic-tag-variable-constant-p tag))
- nil ; skip the macros.
- (if (semantic-tag-similar-with-subtags-p tag (car tags-expected))
- (setq tags-expected (cdr tags-expected))
- (with-mode-local c-mode
- (error "Found: >> %s << Expected: >> %s <<"
- (semantic-format-tag-prototype tag nil t)
- (semantic-format-tag-prototype (car tags-expected) nil t)
- )))
- ))
- ;; Passed?
- (message "PASSED!")
- )))
-
-
-(provide 'semantic-utest-c)
-
-;;; semantic-utest-c.el ends here
+++ /dev/null
-;;; semantic-utest.el --- Tests for semantic's parsing system.
-
-;;; Copyright (C) 2003-2004, 2007-2019 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic's parsing and partial parsing system is pretty complex.
-;; These unit tests attempt to emulate semantic's partial reparsing
-;; and full reparsing system, and anything else I may feel the urge
-;; to write a test for.
-
-(require 'semantic)
-
-(load-file "cedet-utests.el")
-
-(defvar semantic-utest-temp-directory (if (fboundp 'temp-directory)
- (temp-directory)
- temporary-file-directory)
- "Temporary directory to use when creating files.")
-
-(defun semantic-utest-fname (name)
- "Create a filename for NAME in /tmp."
- (expand-file-name name semantic-utest-temp-directory))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for C tests
-
-(defvar semantic-utest-C-buffer-contents
- "/* Test file for C language for Unit Tests */
-
-#include <stdio.h>
-#include \"sutest.h\"
-
-struct mystruct1 {
- int slot11;
- char slot12;
- float slot13;
-};
-
-int var1;
-
-float funp1(char arg11, char arg12);
-
-char fun2(int arg_21, int arg_22) /*1*/
-{
- struct mystruct1 *ms1 = malloc(sizeof(struct mystruct1));
-
- char sv = calc_sv(var1);
-
- if (var1 == 0) {
- sv = 1;
- } else if (arg_21 == 0) {
- sv = 2;
- } else if (arg_22 == 0) {
- sv = 3;
- } else {
- sv = 4;
- }
-
- printf(\"SV = %d\\n\", sv);
-
- /* Memory Leak */
- ms1.slot1 = sv;
-
- return 'A' + sv;
-}
-"
- "Contents of a C buffer initialized by this unit test.
-Be sure to change `semantic-utest-C-name-contents' when you
-change this variable.")
-
-(defvar semantic-utest-C-h-buffer-contents
- "/* Test file for C language header file for Unit Tests */
-
-int calc_sv(int);
-
-"
- "Contents of a C header file buffer initialized by this unit test.")
-
-(defvar semantic-utest-C-filename (semantic-utest-fname "sutest.c")
- "File to open and erase during this test for C.")
-
-(defvar semantic-utest-C-filename-h
- (concat (file-name-sans-extension semantic-utest-C-filename)
- ".h")
- "Header file filename for C")
-
-
-(defvar semantic-utest-C-name-contents
- '(("stdio.h" include
- (:system-flag t)
- nil (overlay 48 66 "sutest.c"))
- ("sutest.h" include nil nil (overlay 67 86 "sutest.c"))
- ("mystruct1" type
- (:members
- (("slot11" variable
- (:type "int")
- (reparse-symbol classsubparts)
- (overlay 109 120 "sutest.c"))
- ("slot12" variable
- (:type "char")
- (reparse-symbol classsubparts)
- (overlay 123 135 "sutest.c"))
- ("slot13" variable
- (:type "float")
- (reparse-symbol classsubparts)
- (overlay 138 151 "sutest.c")))
- :type "struct")
- nil (overlay 88 154 "sutest.c"))
- ("var1" variable
- (:type "int")
- nil (overlay 156 165 "sutest.c"))
- ("funp1" function
- (:prototype-flag t :arguments
- (("arg11" variable
- (:type "char")
- (reparse-symbol arg-sub-list)
- (overlay 179 190 "sutest.c"))
- ("arg12" variable
- (:type "char")
- (reparse-symbol arg-sub-list)
- (overlay 191 202 "sutest.c")))
- :type "float")
- nil (overlay 167 203 "sutest.c"))
- ("fun2" function
- (:arguments
- (("arg_21" variable
- (:type "int")
- (reparse-symbol arg-sub-list)
- (overlay 215 226 "sutest.c"))
- ("arg_22" variable
- (:type "int")
- (reparse-symbol arg-sub-list)
- (overlay 227 238 "sutest.c")))
- :type "char")
- nil (overlay 205 566 "sutest.c")))
- "List of expected tag names for C.")
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Python tests
-
-(defvar semantic-utest-Python-buffer-contents
-"
-def fun1(a,b,c):
- return a
-
-def fun2(a,b,c): #1
- return b
-
-"
-
-
-)
-; "python test case. notice that python is indentation sensitive
-
-
-(defvar semantic-utest-Python-name-contents
- '(("fun1" function
- (:arguments
- (("a" variable nil
- (reparse-symbol function_parameters)
- (overlay 10 11 "tst.py"))
- ("b" variable nil
- (reparse-symbol function_parameters)
- (overlay 12 13 "tst.py"))
- ("c" variable nil
- (reparse-symbol function_parameters)
- (overlay 14 15 "tst.py"))))
- nil (overlay 1 31 "tst.py"))
- ("fun2" function
- (:arguments
- (("a" variable nil
- (reparse-symbol function_parameters)
- (overlay 41 42 "tst.py"))
- ("b" variable nil
- (reparse-symbol function_parameters)
- (overlay 43 44 "tst.py"))
- ("c" variable nil
- (reparse-symbol function_parameters)
- (overlay 45 46 "tst.py"))))
- nil (overlay 32 65 "tst.py")))
-
- "List of expected tag names for Python.")
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Java tests
-
-(defvar semantic-utest-Java-buffer-contents
-"
-class JavaTest{
- void fun1(int a,int b){
- return a;
- }
-
- void fun2(int a,int b){ //1
- return b;
- }
-
-}
-"
-)
-
-(defvar semantic-utest-Java-name-contents
- '(("JavaTest" type
- (:members
- (("fun1" function
- (:arguments
- (("a" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 30 35 "JavaTest.java"))
- ("b" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 36 41 "JavaTest.java")))
- :type "void")
- (reparse-symbol class_member_declaration)
- (overlay 20 61 "JavaTest.java"))
- ("fun2" function
- (:arguments
- (("a" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 75 80 "JavaTest.java"))
- ("b" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 81 86 "JavaTest.java")))
- :type "void")
- (reparse-symbol class_member_declaration)
- (overlay 65 110 "JavaTest.java")))
- :type "class")
- nil (overlay 2 113 "JavaTest.java")))
- "List of expected tag names for Java."
- )
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Javascript tests
-
-(defvar semantic-utest-Javascript-buffer-contents
-"
-function fun1(a, b){
- return a;
- }
-
-function fun2(a,b){ //1
- return b;
- }
-"
-)
-
-
-(defvar semantic-utest-Javascript-name-contents
- '(("fun1" function
- (:arguments
- (("a" variable nil
- (reparse-symbol FormalParameterList)
- (overlay 15 16 "tst.js"))
- ("b" variable nil
- (reparse-symbol FormalParameterList)
- (overlay 18 19 "tst.js"))))
- nil (overlay 1 39 "tst.js"))
- ("fun2" function
- (:arguments
- (("a" variable nil
- (reparse-symbol FormalParameterList)
- (overlay 55 56 "tst.js"))
- ("b" variable nil
- (reparse-symbol FormalParameterList)
- (overlay 57 58 "tst.js"))))
- nil (overlay 41 82 "tst.js")))
-
- "List of expected tag names for Javascript.")
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Makefile tests
-
-(defvar semantic-utest-Makefile-buffer-contents
-"
-t1:
-\techo t1
-
-t2:t1 #1
-\techo t2
-
-
-"
-)
-
-
-(defvar semantic-utest-Makefile-name-contents
- '(("t1" function nil nil (overlay 1 9 "Makefile"))
- ("t2" function
- (:arguments
- ("t1"))
- nil (overlay 18 28 "Makefile")))
- "List of expected tag names for Makefile.")
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Scheme tests
-
-(defvar semantic-utest-Scheme-buffer-contents
- "
- (define fun1 2)
-
- (define fun2 3 ;1
- )
-")
-
-(defvar semantic-utest-Scheme-name-contents
- '(("fun1" variable
- (:default-value ("2"))
- nil (overlay 3 18 "tst.scm"))
- ("fun2" variable
- (:default-value ("3"))
- nil (overlay 21 55 "tst.scm")))
- )
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Html tests
-
-(defvar semantic-utest-Html-buffer-contents
- "
-<html>
- <body>
- <h1>hello</h1>
- </body><!--1-->
-</html>
-"
- )
-
-(defvar semantic-utest-Html-name-contents
- '(("hello" section
- (:members
- (("hello" section nil nil (overlay 21 24 "tst.html"))))
- nil (overlay 10 15 "tst.html")))
- )
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for PHP tests
-
-(defvar semantic-utest-PHP-buffer-contents
- "<?php
-
-function fun1(){
- return \"fun1\";
-}
-
-function fun2($arg1){
- $output = \"argument to fun2: \" . $arg1;
- return $output;
-}
-
-class aClass {
- public function fun1($a, $b){
- return $a;
- }
-
- public function fun2($a, $b){
- return $b;
- }
-}
-?> "
- )
-
-(defvar semantic-utest-PHP-name-contents
- '(("fun1" function nil
- nil (overlay 9 45 "phptest.php"))
- ("fun2" function
- (:arguments (("$arg1" variable nil (reparse-symbol formal_parameters) (overlay 61 66 "phptest.php"))))
- nil
- (overlay 47 132 "phptest.php"))
- ("aClass" type
- (:members (("fun1" function
- (:typemodifiers ("public") :arguments
- (("$a" variable nil (reparse-symbol formal_parameters) (overlay 174 176 "phptest.php"))
- ("$b" variable nil (reparse-symbol formal_parameters) (overlay 178 180 "phptest.php"))))
-
- nil
- (overlay 153 204 "phptest.php"))
-
- ("fun2" function
- (:typemodifiers ("public") :arguments
- (("$a" variable nil (reparse-symbol formal_parameters) (overlay 230 232 "phptest.php"))
- ("$b" variable nil (reparse-symbol formal_parameters) (overlay 234 236 "phptest.php"))
- ))
- nil
- (overlay 209 260 "phptest.php"))) :type "class")
- nil
- (overlay 135 262 "phptest.php"))
- )
- "Expected results from the PHP Unit test"
- )
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Csharp C# tests
-
-(defvar semantic-utest-Csharp-buffer-contents
-"
-class someClass {
- int fun1(int a, int b) {
- return a; }
- int fun2(int a, int b) {
- return b; }
-}
-")
-
-(defvar semantic-utest-Csharp-name-contents
- '(("someClass" type
- (:members
- (("fun1" function
- (:arguments
- (("a" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 30 35 "tst.cs"))
- ("b" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 37 42 "tst.cs")))
- :type "int")
- (reparse-symbol class_member_declaration)
- (overlay 21 61 "tst.cs"))
- ("fun2" function
- (:arguments
- (("a" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 73 78 "tst.cs"))
- ("b" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 80 85 "tst.cs")))
- :type "int")
- (reparse-symbol class_member_declaration)
- (overlay 64 104 "tst.cs")))
- :type "class")
- nil (overlay 1 106 "tst.cs")))
- )
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-(defun semantic-utest-makebuffer (filename contents)
- "Create a buffer for FILENAME for use in a unit test.
-Pre-fill the buffer with CONTENTS."
- (let ((buff (semantic-find-file-noselect filename)))
- (set-buffer buff)
- (setq buffer-offer-save nil)
- (font-lock-mode -1) ;; Font lock has issues in Emacs 23
- (toggle-read-only -1) ;; In case /tmp doesn't exist.
- (erase-buffer)
- (insert contents)
- ;(semantic-fetch-tags) ;JAVE could this go here?
- (set-buffer-modified-p nil)
- buff
- )
- )
-
-(defun semantic-utest-C ()
- "Run semantic's C unit test."
- (interactive)
- (save-excursion
- (let ((buff (semantic-utest-makebuffer semantic-utest-C-filename semantic-utest-C-buffer-contents))
- (buff2 (semantic-utest-makebuffer semantic-utest-C-filename-h semantic-utest-C-h-buffer-contents))
- )
- (semantic-fetch-tags)
- (set-buffer buff)
-
- ;; Turn off a range of modes
- (semantic-idle-scheduler-mode -1)
-
- ;; Turn on some modes
- (semantic-highlight-edits-mode 1)
-
- ;; Update tags, and show it.
- (semantic-fetch-tags)
-
- (switch-to-buffer buff)
- (sit-for 0)
-
- ;; Run the tests.
- ;;(message "First parsing test.")
- (semantic-utest-verify-names semantic-utest-C-name-contents)
-
- ;;(message "Invalid tag test.")
- (semantic-utest-last-invalid semantic-utest-C-name-contents '("fun2") "/\\*1\\*/" "/* Deleted this line */")
- (semantic-utest-verify-names semantic-utest-C-name-contents)
-
- (set-buffer-modified-p nil)
- ;; Clean up
- ;; (kill-buffer buff)
- ;; (kill-buffer buff2)
- ))
- (message "All C tests passed.")
- )
-
-
-
-
-(defun semantic-utest-generic (testname filename contents name-contents names-removed killme insertme)
- "Generic unit test according to template.
-Should work for languages without .h files, python javascript java.
-TESTNAME is the name of the test.
-FILENAME is the name of the file to create.
-CONTENTS is the contents of the file to test.
-NAME-CONTENTS is the list of names that should be in the contents.
-NAMES-REMOVED is the list of names that gets removed in the removal step.
-KILLME is the name of items to be killed.
-INSERTME is the text to be inserted after the deletion."
- (save-excursion
- (let ((buff (semantic-utest-makebuffer filename contents))
- )
- ;; Turn off a range of modes
- (semantic-idle-scheduler-mode -1)
-
- ;; Turn on some modes
- (semantic-highlight-edits-mode 1)
-
- ;; Update tags, and show it.
- (semantic-fetch-tags)
- (switch-to-buffer buff)
- (sit-for 0)
-
- ;; Run the tests.
- ;;(message "First parsing test %s." testname)
- (semantic-utest-verify-names name-contents)
-
- ;;(message "Invalid tag test %s." testname)
- (semantic-utest-last-invalid name-contents names-removed killme insertme)
- (semantic-utest-verify-names name-contents)
-
- (set-buffer-modified-p nil)
- ;; Clean up
- ;; (kill-buffer buff)
- ))
- (message "All %s tests passed." testname)
- )
-
-(defun semantic-utest-Python()
- (interactive)
- (if (fboundp 'python-mode)
- (semantic-utest-generic "Python" (semantic-utest-fname "pytest.py") semantic-utest-Python-buffer-contents semantic-utest-Python-name-contents '("fun2") "#1" "#deleted line")
- (message "Skilling Python test: NO major mode."))
- )
-
-
-(defun semantic-utest-Javascript()
- (interactive)
- (if (fboundp 'javascript-mode)
- (semantic-utest-generic "Javascript" (semantic-utest-fname "javascripttest.js") semantic-utest-Javascript-buffer-contents semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line")
- (message "Skipping JavaScript test: NO major mode."))
- )
-
-(defun semantic-utest-Java()
- (interactive)
- ;; If JDE is installed, it might mess things up depending on the version
- ;; that was installed.
- (let ((auto-mode-alist '(("\\.java\\'" . java-mode))))
- (semantic-utest-generic "Java" (semantic-utest-fname "JavaTest.java") semantic-utest-Java-buffer-contents semantic-utest-Java-name-contents '("fun2") "//1" "//deleted line")
- ))
-
-(defun semantic-utest-Makefile()
- (interactive)
- (semantic-utest-generic "Makefile" (semantic-utest-fname "Makefile") semantic-utest-Makefile-buffer-contents semantic-utest-Makefile-name-contents '("fun2") "#1" "#deleted line")
- )
-
-(defun semantic-utest-Scheme()
- (interactive)
- (semantic-utest-generic "Scheme" (semantic-utest-fname "tst.scm") semantic-utest-Scheme-buffer-contents semantic-utest-Scheme-name-contents '("fun2") ";1" ";deleted line")
- )
-
-
-(defun semantic-utest-Html()
- (interactive)
- ;; Disable html-helper auto-fill-in mode.
- (let ((html-helper-build-new-buffer nil))
- (semantic-utest-generic "HTML" (semantic-utest-fname "tst.html") semantic-utest-Html-buffer-contents semantic-utest-Html-name-contents '("fun2") "<!--1-->" "<!--deleted line-->")
- ))
-
-(defun semantic-utest-PHP()
- (interactive)
- (if (fboundp 'php-mode)
- (semantic-utest-generic "PHP" (semantic-utest-fname "phptest.php") semantic-utest-PHP-buffer-contents semantic-utest-PHP-name-contents '("fun1") "fun2" "%^@")
- (message "Skipping PHP Test. No php-mode loaded."))
- )
-
-;look at http://mfgames.com/linux/csharp-mode
-(defun semantic-utest-Csharp() ;; hmm i don't even know how to edit a scharp file. need a csharp mode implementation i suppose
- (interactive)
- (if (fboundp 'csharp-mode)
- (semantic-utest-generic "C#" (semantic-utest-fname "csharptest.cs") semantic-utest-Csharp-buffer-contents semantic-utest-Csharp-name-contents '("fun2") "//1" "//deleted line")
- (message "Skipping C# test. No csharp-mode loaded."))
- )
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; stubs
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; stuff for Erlang
-;;-module(hello).
-;-export([hello_world/0]).
-;
-;hello_world()->
-; io:format("Hello World ~n").
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;(defun semantic-utest-Erlang()
-; (interactive)
-; (semantic-utest-generic "Erlang" (semantic-utest-fname "tst.erl") semantic-utest-Erlang-buffer-contents semantic-utest-Erlang-name-contents '("fun2") "//1" "//deleted line")
-; )
-;
-;;texi is also supported
-;(defun semantic-utest-Texi()
-; (interactive)
-; (semantic-utest-generic "texi" (semantic-utest-fname "tst.texi") semantic-utest-Texi-buffer-contents semantic-utest-Texi-name-contents '("fun2") "//1" "//deleted line")
-; )
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;;###autoload
-(defun semantic-utest-main()
- (interactive)
- "call all utests"
- (cedet-utest-log-start "multi-lang parsing")
- (cedet-utest-log " * C tests...")
- (semantic-utest-C)
- (cedet-utest-log " * Python tests...")
- (semantic-utest-Python)
- (cedet-utest-log " * Java tests...")
- (semantic-utest-Java)
- (cedet-utest-log " * Javascript tests...")
- (semantic-utest-Javascript)
- (cedet-utest-log " * Makefile tests...")
- (semantic-utest-Makefile)
- (cedet-utest-log " * Scheme tests...")
- (semantic-utest-Scheme)
- (cedet-utest-log " * Html tests...")
- (semantic-utest-Html)
- (cedet-utest-log " * PHP tests...")
- (semantic-utest-PHP)
- (cedet-utest-log " * Csharp tests...")
- (semantic-utest-Csharp)
-
- (cedet-utest-log-shutdown "multi-lang parsing")
- )
-
-;;; Buffer contents validation
-;;
-(defun semantic-utest-match-attributes (attr1 attr2 skipnames)
- "Compare attribute lists ATTR1 and ATTR2.
-Argument SKIPNAMES is a list of names that may be child nodes to skip."
- (let ((res t))
- (while (and res attr1 attr2)
-
- ;; Compare
- (setq res
- (cond ((and (listp (car attr1))
- (semantic-tag-p (car (car attr1))))
- ;; Compare the list of tags...
- (semantic-utest-taglists-equivalent-p
- (car attr2) (car attr1) skipnames)
- )
- (t
- (equal (car attr1) (car attr2)))))
-
- (if (not res)
- (error "TAG INTERNAL DIFF: %S %S"
- (car attr1) (car attr2)))
-
- (setq attr1 (cdr attr1)
- attr2 (cdr attr2)))
- res))
-
-(defun semantic-utest-equivalent-tag-p (tag1 tag2 skipnames)
- "Determine if TAG1 and TAG2 are the same.
-SKIPNAMES includes lists of possible child nodes that should be missing."
- (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2))
- (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))
- (semantic-utest-match-attributes
- (semantic-tag-attributes tag1) (semantic-tag-attributes tag2)
- skipnames)
- ))
-
-(defun semantic-utest-taglists-equivalent-p (table names skipnames)
- "Compare TABLE and NAMES, where skipnames allow list1 to be different.
-SKIPNAMES is a list of names that should be skipped in the NAMES list."
- (let ((SN skipnames))
- (while SN
- (setq names (remove (car SN) names))
- (setq SN (cdr SN))))
- (while (and names table)
- (if (not (semantic-utest-equivalent-tag-p (car names)
- (car table)
- skipnames))
- (error "Expected %s, found %s"
- (semantic-format-tag-prototype (car names))
- (semantic-format-tag-prototype (car table))))
- (setq names (cdr names)
- table (cdr table)))
- (when names (error "Items forgotten: %S"
- (mapcar 'semantic-tag-name names)
- ))
- (when table (error "Items extra: %S"
- (mapcar 'semantic-tag-name table)))
- t)
-
-(defun semantic-utest-verify-names (name-contents &optional skipnames)
- "Verify the names of the test buffer from NAME-CONTENTS.
-Argument SKIPNAMES is a list of names that should be skipped
-when analyzing the file.
-
-JAVE this thing would need to be recursive to handle java and csharp"
- (let ((names name-contents)
- (table (semantic-fetch-tags))
- )
- (semantic-utest-taglists-equivalent-p table names skipnames)
- ))
-
-;;;;;;;;;;;;;;;;;;;;;;;;
-; JAVE redefine a new validation function
-; is not quite as good as the old one yet
-(defun semantic-utest-verify-names-jave (name-contents &optional skipnames)
- "JAVE version of `semantic-utest-verify-names'.
-NAME-CONTENTS is a sample of the tags buffer to test against.
-SKIPNAMES is a list of names to remove from NAME-CONTENTS"
- (assert (semantic-utest-verify-names-2 name-contents (semantic-fetch-tags))
- nil "failed test")
-)
-
-(defun semantic-utest-verify-names-2 (l1 l2)
- (cond ( (and (consp l1) (equal (car l1) 'overlay))
- (overlayp l2))
- ((not (consp l1))
- (equal l1 l2))
- ((consp l1)
- (and (semantic-utest-verify-names-2 (car l1) (car l2)) (semantic-utest-verify-names-2 (cdr l1) (cdr l2))))
- (t (error "internal error"))))
-
-
-
-
-
-;;; Kill indicator line
-;;
-(defvar semantic-utest-last-kill-text nil
- "The text from the last kill.")
-
-(defvar semantic-utest-last-kill-pos nil
- "The position of the last kill.")
-
-(defun semantic-utest-kill-indicator ( killme insertme)
- "Kill the line with KILLME on it and insert INSERTME in its place."
- (goto-char (point-min))
-; (re-search-forward (concat "/\\*" indicator "\\*/")); JAVE this isn't generic enough for different languages
- (re-search-forward killme)
- (beginning-of-line)
- (setq semantic-utest-last-kill-pos (point))
- (setq semantic-utest-last-kill-text
- (buffer-substring (point) (point-at-eol)))
- (delete-region (point) (point-at-eol))
- (insert insertme)
- (sit-for 0)
-)
-
-(defun semantic-utest-unkill-indicator ()
- "Unkill the last indicator."
- (goto-char semantic-utest-last-kill-pos)
- (delete-region (point) (point-at-eol))
- (insert semantic-utest-last-kill-text)
- (sit-for 0)
- )
-
-;;; EDITING TESTS
-;;
-
-(defun semantic-utest-last-invalid (name-contents names-removed killme insertme)
- "Make the last fcn invalid."
- (semantic-utest-kill-indicator killme insertme)
-; (semantic-utest-verify-names name-contents names-removed); verify its gone ;new validator doesn't handle skipnames yet
- (semantic-utest-unkill-indicator);put back killed stuff
- )
-
-
-
-
-;"#<overlay from \\([0-9]+\\) to \\([0-9]+\\) in \\([^>]*\\)>"
-;#<overlay from \([0-9]+\) to \([0-9]+\) in \([^>]*\)>
-;(overlay \1 \2 "\3")
-
-
-;; JAVE
-;; these are some unit tests for cedet that I got from Eric and modified a bit for:
-;; python
-;; javascript
-;; java
-;; I tried to generalize the structure of the tests a bit to make it easier to add languages
-
-;; Mail from Eric:
-;; Many items in the checklist look like:
-
-;; M-x global-semantic-highlight-edits-mode RET
-;; - Edit a file. See the highlight of newly inserted text.
-;; - Customize `semantic-edits-verbose-flag' to be non-nil.
-;; - Wait for the idle scheduler, it should clean up the edits.
-;; - observe messages from incremental parser. Do they relate
-;; to the edits?
-;; - M-x bovinate RET - verify your changes are reflected.
-
-;; It's all about watching the behavior. Timers go off, things get
-;; cleaned up, you type in new changes, etc. An example I tried to
-;; do is below, but covers only 1 language, and not very well at that.
-;; I seem to remember seeing a unit test framework going by one of the
-;; lists. I'm not sure if that would help.
-
-;; Another that might be automatable:
-
-;; M-x semantic-analyze-current-context RET
-;; - Do this in different contexts in your language
-;; files. Verify that reasonable results are returned
-;; such as identification of assignments, function arguments, etc.
-
-;; Anyway, those are some ideas. Any effort you put it will be helpful!
-
-;; Thanks
-;; Eric
-
-;; -----------
-
-
-
-;;; semantic-utest.el ends here
projects / emacs.git / commitdiff