| 1 | ;;; semantic-utest.el --- Miscellaneous Semantic tests. |
| 2 | |
| 3 | ;;; Copyright (C) 2003-2004, 2007-2013 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Eric M. Ludlam <zappo@gnu.org> |
| 6 | |
| 7 | ;; This file is part of GNU Emacs. |
| 8 | |
| 9 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 10 | ;; it under the terms of the GNU General Public License as published by |
| 11 | ;; the Free Software Foundation, either version 3 of the License, or |
| 12 | ;; (at your option) any later version. |
| 13 | |
| 14 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 17 | ;; GNU General Public License for more details. |
| 18 | |
| 19 | ;; You should have received a copy of the GNU General Public License |
| 20 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 21 | |
| 22 | ;;; Commentary: |
| 23 | |
| 24 | ;; Originally, there are many test functions scattered among the |
| 25 | ;; Semantic source files. This file consolidates them. |
| 26 | |
| 27 | (require 'data-debug) |
| 28 | |
| 29 | ;;; From semantic-complete |
| 30 | |
| 31 | (require 'semantic/complete) |
| 32 | |
| 33 | (defun semantic-complete-test () |
| 34 | "Test completion mechanisms." |
| 35 | (interactive) |
| 36 | (message "%S" |
| 37 | (semantic-format-tag-prototype |
| 38 | (semantic-complete-read-tag-project "Symbol: ")))) |
| 39 | |
| 40 | ;;; From semanticdb-ebrowse |
| 41 | |
| 42 | (require 'semantic/db-ebrowse) |
| 43 | |
| 44 | (defun semanticdb-ebrowse-run-tests () |
| 45 | "Run some tests of the semanticdb-ebrowse system. |
| 46 | All systems are different. Ask questions along the way." |
| 47 | (interactive) |
| 48 | (let ((doload nil)) |
| 49 | (when (y-or-n-p "Create a system database to test with? ") |
| 50 | (call-interactively 'semanticdb-create-ebrowse-database) |
| 51 | (setq doload t)) |
| 52 | ;; Should we load in caches |
| 53 | (when (if doload |
| 54 | (y-or-n-p "New database created. Reload system databases? ") |
| 55 | (y-or-n-p "Load in all system databases? ")) |
| 56 | (semanticdb-load-ebrowse-caches))) |
| 57 | ;; Ok, databases were created. Let's try some searching. |
| 58 | (when (not (or (eq major-mode 'c-mode) |
| 59 | (eq major-mode 'c++-mode))) |
| 60 | (error "Please make your default buffer be a C or C++ file, then |
| 61 | run the test again"))) |
| 62 | |
| 63 | (defun semanticdb-ebrowse-dump () |
| 64 | "Find the first loaded ebrowse table, and dump out the contents." |
| 65 | (interactive) |
| 66 | (let ((db semanticdb-database-list) |
| 67 | (ab nil)) |
| 68 | (while db |
| 69 | (when (semanticdb-project-database-ebrowse-p (car db)) |
| 70 | (setq ab (data-debug-new-buffer "*EBROWSE Database*")) |
| 71 | (data-debug-insert-thing (car db) "*" "") |
| 72 | (setq db nil) |
| 73 | ) |
| 74 | (setq db (cdr db))))) |
| 75 | |
| 76 | ;;; From semanticdb-global: |
| 77 | |
| 78 | (require 'semantic/db-global) |
| 79 | |
| 80 | (defvar semanticdb-test-gnu-global-startfile "~/src/global-5.7.3/global/global.c" |
| 81 | "File to use for testing.") |
| 82 | |
| 83 | (defun semanticdb-test-gnu-global (searchfor &optional standardfile) |
| 84 | "Test the GNU Global semanticdb. |
| 85 | Argument SEARCHFOR is the text to search for. |
| 86 | If optional arg STANDARDFILE is non-nil, use a standard file w/ global enabled." |
| 87 | (interactive "sSearch For Tag: \nP") |
| 88 | |
| 89 | (require 'data-debug) |
| 90 | (save-excursion |
| 91 | (when standardfile |
| 92 | (save-match-data |
| 93 | (set-buffer (find-file-noselect semanticdb-test-gnu-global-startfile)))) |
| 94 | |
| 95 | (condition-case err |
| 96 | (semanticdb-enable-gnu-global-in-buffer) |
| 97 | (error (if standardfile |
| 98 | (error err) |
| 99 | (save-match-data |
| 100 | (set-buffer (find-file-noselect semanticdb-test-gnu-global-startfile))) |
| 101 | (semanticdb-enable-gnu-global-in-buffer)))) |
| 102 | |
| 103 | (let* ((db (semanticdb-project-database-global "global")) |
| 104 | (tab (semanticdb-file-table db (buffer-file-name))) |
| 105 | (result (semanticdb-deep-find-tags-for-completion-method tab searchfor)) |
| 106 | ) |
| 107 | (data-debug-new-buffer "*SemanticDB Gnu Global Result*") |
| 108 | (data-debug-insert-thing result "?" "")))) |
| 109 | |
| 110 | ;;; From semantic-format |
| 111 | |
| 112 | (require 'semantic/format) |
| 113 | |
| 114 | (defun semantic-test-all-format-tag-functions (&optional arg) |
| 115 | "Test all outputs from `semantic-format-tag-functions'. |
| 116 | Output is generated from the function under `point'. |
| 117 | Optional argument ARG specifies not to use color." |
| 118 | (interactive "P") |
| 119 | (semantic-fetch-tags) |
| 120 | (let* ((tag (semantic-current-tag)) |
| 121 | (par (semantic-current-tag-parent)) |
| 122 | (fns semantic-format-tag-functions)) |
| 123 | (with-output-to-temp-buffer "*format-tag*" |
| 124 | (princ "Tag->format function tests:") |
| 125 | (while fns |
| 126 | (princ "\n") |
| 127 | (princ (car fns)) |
| 128 | (princ ":\n ") |
| 129 | (let ((s (funcall (car fns) tag par (not arg)))) |
| 130 | (save-excursion |
| 131 | (set-buffer "*format-tag*") |
| 132 | (goto-char (point-max)) |
| 133 | (insert s))) |
| 134 | (setq fns (cdr fns)))) |
| 135 | )) |
| 136 | |
| 137 | ;;; From semantic-fw: |
| 138 | |
| 139 | (require 'semantic/fw) |
| 140 | |
| 141 | (defun semantic-test-data-cache () |
| 142 | "Test the data cache." |
| 143 | (interactive) |
| 144 | (let ((data '(a b c))) |
| 145 | (save-excursion |
| 146 | (set-buffer (get-buffer-create " *semantic-test-data-cache*")) |
| 147 | (erase-buffer) |
| 148 | (insert "The Moose is Loose") |
| 149 | (goto-char (point-min)) |
| 150 | (semantic-cache-data-to-buffer (current-buffer) (point) (+ (point) 5) |
| 151 | data 'moose 'exit-cache-zone) |
| 152 | (if (equal (semantic-get-cache-data 'moose) data) |
| 153 | (message "Successfully retrieved cached data.") |
| 154 | (error "Failed to retrieve cached data"))))) |
| 155 | |
| 156 | (defun semantic-test-throw-on-input () |
| 157 | "Test that throw on input will work." |
| 158 | (interactive) |
| 159 | (semantic-throw-on-input 'done-die) |
| 160 | (message "Exit Code: %s" |
| 161 | (semantic-exit-on-input 'testing |
| 162 | (let ((inhibit-quit nil) |
| 163 | (message-log-max nil)) |
| 164 | (while t |
| 165 | (message "Looping ... press a key to test") |
| 166 | (semantic-throw-on-input 'test-inner-loop)) |
| 167 | 'exit))) |
| 168 | (when (input-pending-p) |
| 169 | (if (fboundp 'read-event) |
| 170 | (read-event) |
| 171 | (read-char)))) |
| 172 | |
| 173 | ;;; From semantic-idle: |
| 174 | |
| 175 | (require 'semantic/idle) |
| 176 | |
| 177 | (defun semantic-idle-pnf-test () |
| 178 | "Test `semantic-idle-scheduler-work-parse-neighboring-files' and time it." |
| 179 | (interactive) |
| 180 | (let ((start (current-time)) |
| 181 | (junk (semantic-idle-scheduler-work-parse-neighboring-files)) |
| 182 | (end (current-time))) |
| 183 | (message "Work took %.2f seconds." (semantic-elapsed-time start end)))) |
| 184 | |
| 185 | ;;; From semantic-lex: |
| 186 | |
| 187 | (require 'semantic/lex) |
| 188 | |
| 189 | (defun semantic-lex-test-full-depth (arg) |
| 190 | "Test the semantic lexer in the current buffer parsing through lists. |
| 191 | Usually the lexer parses. |
| 192 | If universal argument ARG, then try the whole buffer." |
| 193 | (interactive "P") |
| 194 | (let* ((start (current-time)) |
| 195 | (result (semantic-lex |
| 196 | (if arg (point-min) (point)) |
| 197 | (point-max) |
| 198 | 100)) |
| 199 | (end (current-time))) |
| 200 | (message "Elapsed Time: %.2f seconds." |
| 201 | (semantic-elapsed-time start end)) |
| 202 | (pop-to-buffer "*Lexer Output*") |
| 203 | (require 'pp) |
| 204 | (erase-buffer) |
| 205 | (insert (pp-to-string result)) |
| 206 | (goto-char (point-min)))) |
| 207 | |
| 208 | (defun semantic-lex-test-region (beg end) |
| 209 | "Test the semantic lexer in the current buffer. |
| 210 | Analyze the area between BEG and END." |
| 211 | (interactive "r") |
| 212 | (let ((result (semantic-lex beg end))) |
| 213 | (pop-to-buffer "*Lexer Output*") |
| 214 | (require 'pp) |
| 215 | (erase-buffer) |
| 216 | (insert (pp-to-string result)) |
| 217 | (goto-char (point-min)))) |
| 218 | |
| 219 | ;;; From semantic-lex-spp: |
| 220 | |
| 221 | (require 'semantic/lex-spp) |
| 222 | |
| 223 | (defun semantic-lex-spp-write-test () |
| 224 | "Test the semantic tag writer against the current buffer." |
| 225 | (interactive) |
| 226 | (with-output-to-temp-buffer "*SPP Write Test*" |
| 227 | (semantic-lex-spp-table-write-slot-value |
| 228 | (semantic-lex-spp-save-table)))) |
| 229 | |
| 230 | (defun semantic-lex-spp-write-utest () |
| 231 | "Unit test using the test spp file to test the slot write fcn." |
| 232 | (interactive) |
| 233 | (let* ((sem (locate-library "semantic-lex-spp.el")) |
| 234 | (dir (file-name-directory sem))) |
| 235 | (save-excursion |
| 236 | (set-buffer (find-file-noselect |
| 237 | (expand-file-name "tests/testsppreplace.c" |
| 238 | dir))) |
| 239 | (semantic-lex-spp-write-test)))) |
| 240 | |
| 241 | ;;; From semantic-tag-write: |
| 242 | |
| 243 | ;;; TESTING. |
| 244 | |
| 245 | (require 'semantic/tag-write) |
| 246 | |
| 247 | (defun semantic-tag-write-test () |
| 248 | "Test the semantic tag writer against the tag under point." |
| 249 | (interactive) |
| 250 | (with-output-to-temp-buffer "*Tag Write Test*" |
| 251 | (semantic-tag-write-one-tag (semantic-current-tag)))) |
| 252 | |
| 253 | (defun semantic-tag-write-list-test () |
| 254 | "Test the semantic tag writer against the tag under point." |
| 255 | (interactive) |
| 256 | (with-output-to-temp-buffer "*Tag Write Test*" |
| 257 | (semantic-tag-write-tag-list (semantic-fetch-tags)))) |
| 258 | |
| 259 | ;;; From semantic-symref-filter: |
| 260 | |
| 261 | (require 'semantic/symref/filter) |
| 262 | |
| 263 | (defun semantic-symref-test-count-hits-in-tag () |
| 264 | "Lookup in the current tag the symbol under point. |
| 265 | Then count all the other references to the same symbol within the |
| 266 | tag that contains point, and return that." |
| 267 | (interactive) |
| 268 | (let* ((ctxt (semantic-analyze-current-context)) |
| 269 | (target (car (reverse (oref ctxt prefix)))) |
| 270 | (tag (semantic-current-tag)) |
| 271 | (start (current-time)) |
| 272 | (Lcount 0)) |
| 273 | (when (semantic-tag-p target) |
| 274 | (semantic-symref-hits-in-region |
| 275 | target (lambda (start end prefix) (setq Lcount (1+ Lcount))) |
| 276 | (semantic-tag-start tag) |
| 277 | (semantic-tag-end tag)) |
| 278 | (when (interactive-p) |
| 279 | (message "Found %d occurrences of %s in %.2f seconds" |
| 280 | Lcount (semantic-tag-name target) |
| 281 | (semantic-elapsed-time start (current-time)))) |
| 282 | Lcount))) |
| 283 | |
| 284 | ;;; From bovine-gcc: |
| 285 | |
| 286 | (require 'semantic/bovine/gcc) |
| 287 | |
| 288 | ;; Example output of "gcc -v" |
| 289 | (defvar semantic-gcc-test-strings |
| 290 | '(;; My old box: |
| 291 | "Reading specs from /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/specs |
| 292 | 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 |
| 293 | Thread model: posix |
| 294 | gcc version 3.2.2 20030222 (Red Hat Linux 3.2.2-5)" |
| 295 | ;; Alex Ott: |
| 296 | "Using built-in specs. |
| 297 | Target: i486-linux-gnu |
| 298 | 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 |
| 299 | Thread model: posix |
| 300 | gcc version 4.3.1 (Ubuntu 4.3.1-9ubuntu1)" |
| 301 | ;; My debian box: |
| 302 | "Using built-in specs. |
| 303 | Target: x86_64-unknown-linux-gnu |
| 304 | 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 |
| 305 | Thread model: posix |
| 306 | gcc version 4.2.3" |
| 307 | ;; My mac: |
| 308 | "Using built-in specs. |
| 309 | Target: i686-apple-darwin8 |
| 310 | 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 |
| 311 | Thread model: posix |
| 312 | gcc version 4.0.1 (Apple Computer, Inc. build 5341)" |
| 313 | ;; Ubuntu Intrepid |
| 314 | "Using built-in specs. |
| 315 | Target: x86_64-linux-gnu |
| 316 | 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 |
| 317 | Thread model: posix |
| 318 | gcc version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)" |
| 319 | ;; Red Hat EL4 |
| 320 | "Reading specs from /usr/lib/gcc/x86_64-redhat-linux/3.4.6/specs |
| 321 | 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 |
| 322 | Thread model: posix |
| 323 | gcc version 3.4.6 20060404 (Red Hat 3.4.6-10)" |
| 324 | ;; Red Hat EL5 |
| 325 | "Using built-in specs. |
| 326 | Target: x86_64-redhat-linux |
| 327 | 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 |
| 328 | Thread model: posix |
| 329 | gcc version 4.1.2 20080704 (Red Hat 4.1.2-44)" |
| 330 | ;; David Engster's german gcc on ubuntu 4.3 |
| 331 | "Es werden eingebaute Spezifikationen verwendet. |
| 332 | Ziel: i486-linux-gnu |
| 333 | 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 |
| 334 | Thread-Modell: posix |
| 335 | gcc-Version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)" |
| 336 | ;; Damien Deville bsd |
| 337 | "Using built-in specs. |
| 338 | Target: i386-undermydesk-freebsd |
| 339 | Configured with: FreeBSD/i386 system compiler |
| 340 | Thread model: posix |
| 341 | gcc version 4.2.1 20070719 [FreeBSD]" |
| 342 | ) |
| 343 | "A bunch of sample gcc -v outputs from different machines.") |
| 344 | |
| 345 | (defvar semantic-gcc-test-strings-fail |
| 346 | '(;; A really old solaris box I found |
| 347 | "Reading specs from /usr/local/gcc-2.95.2/lib/gcc-lib/sparc-sun-solaris2.6/2.95.2/specs |
| 348 | gcc version 2.95.2 19991024 (release)" |
| 349 | ) |
| 350 | "A bunch of sample gcc -v outputs that fail to provide the info we want.") |
| 351 | |
| 352 | (defun semantic-gcc-test-output-parser () |
| 353 | "Test the output parser against some collected strings." |
| 354 | (interactive) |
| 355 | (let ((fail nil)) |
| 356 | (dolist (S semantic-gcc-test-strings) |
| 357 | (let* ((fields (semantic-gcc-fields S)) |
| 358 | (v (cdr (assoc 'version fields))) |
| 359 | (h (or (cdr (assoc 'target fields)) |
| 360 | (cdr (assoc '--target fields)) |
| 361 | (cdr (assoc '--host fields)))) |
| 362 | (p (cdr (assoc '--prefix fields))) |
| 363 | ) |
| 364 | ;; No longer test for prefixes. |
| 365 | (when (not (and v h)) |
| 366 | (let ((strs (split-string S "\n"))) |
| 367 | (message "Test failed on %S\nV H P:\n%S %S %S" (car strs) v h p)) |
| 368 | (setq fail t)) |
| 369 | )) |
| 370 | (dolist (S semantic-gcc-test-strings-fail) |
| 371 | (let* ((fields (semantic-gcc-fields S)) |
| 372 | (v (cdr (assoc 'version fields))) |
| 373 | (h (or (cdr (assoc '--host fields)) |
| 374 | (cdr (assoc 'target fields)))) |
| 375 | (p (cdr (assoc '--prefix fields))) |
| 376 | ) |
| 377 | (when (and v h p) |
| 378 | (message "Negative test failed on %S" S) |
| 379 | (setq fail t)) |
| 380 | )) |
| 381 | (if (not fail) (message "Tests passed.")) |
| 382 | )) |
| 383 | |
| 384 | (defun semantic-gcc-test-output-parser-this-machine () |
| 385 | "Test the output parser against the machine currently running Emacs." |
| 386 | (interactive) |
| 387 | (let ((semantic-gcc-test-strings (list (semantic-gcc-query "gcc" "-v")))) |
| 388 | (semantic-gcc-test-output-parser)) |
| 389 | ) |