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

   1 ;;; semantic-utest.el --- Miscellaneous Semantic tests.
   2
   3 ;;; Copyright (C) 2003, 2004, 2007, 2008, 2009, 2010 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 creatd.  Lets 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-find
 111
 112 (require 'semantic/find)
 113
 114 (defun semantic-find-benchmark ()
 115   "Run some simple benchmarks to see how we are doing.
 116 Optional argument ARG is the number of iterations to run."
 117   (interactive)
 118   (require 'benchmark)
 119   (let ((f-name nil)
 120         (b-name nil)
 121         (f-comp)
 122         (b-comp)
 123         (f-regex)
 124         )
 125     (garbage-collect)
 126     (setq f-name
 127           (benchmark-run-compiled
 128               1000 (semantic-find-first-tag-by-name "class3"
 129                                                     "test/test.cpp")))
 130     (garbage-collect)
 131     (setq b-name
 132           (benchmark-run-compiled
 133               1000 (semantic-brute-find-first-tag-by-name "class3"
 134                                                           "test/test.cpp")))
 135     (garbage-collect)
 136     (setq f-comp
 137           (benchmark-run-compiled
 138               1000 (semantic-find-tags-for-completion "method"
 139                                                       "test/test.cpp")))
 140     (garbage-collect)
 141     (setq b-comp
 142           (benchmark-run-compiled
 143               1000 (semantic-brute-find-tag-by-name-regexp "^method"
 144                                                            "test/test.cpp")))
 145     (garbage-collect)
 146     (setq f-regex
 147           (benchmark-run-compiled
 148               1000 (semantic-find-tags-by-name-regexp "^method"
 149                                                       "test/test.cpp")))
 150
 151     (message "Name [new old] [ %.3f %.3f ] Complete [newc/new old] [ %.3f/%.3f %.3f ]"
 152              (car f-name) (car b-name)
 153              (car f-comp) (car f-regex)
 154              (car b-comp))
 155   ))
 156
 157 ;;; From semantic-format
 158
 159 (require 'semantic/format)
 160
 161 (defun semantic-test-all-format-tag-functions (&optional arg)
 162   "Test all outputs from `semantic-format-tag-functions'.
 163 Output is generated from the function under `point'.
 164 Optional argument ARG specifies not to use color."
 165   (interactive "P")
 166   (semantic-fetch-tags)
 167   (let* ((tag (semantic-current-tag))
 168          (par (semantic-current-tag-parent))
 169          (fns semantic-format-tag-functions))
 170     (with-output-to-temp-buffer "*format-tag*"
 171       (princ "Tag->format function tests:")
 172       (while fns
 173         (princ "\n")
 174         (princ (car fns))
 175         (princ ":\n ")
 176         (let ((s (funcall (car fns) tag par (not arg))))
 177           (save-excursion
 178             (set-buffer "*format-tag*")
 179             (goto-char (point-max))
 180             (insert s)))
 181         (setq fns (cdr fns))))
 182       ))
 183
 184 ;;; From semantic-fw:
 185
 186 (require 'semantic/fw)
 187
 188 (defun semantic-test-data-cache ()
 189   "Test the data cache."
 190   (interactive)
 191   (let ((data '(a b c)))
 192     (save-excursion
 193       (set-buffer (get-buffer-create " *semantic-test-data-cache*"))
 194       (erase-buffer)
 195       (insert "The Moose is Loose")
 196       (goto-char (point-min))
 197       (semantic-cache-data-to-buffer (current-buffer) (point) (+ (point) 5)
 198                                      data 'moose 'exit-cache-zone)
 199       (if (equal (semantic-get-cache-data 'moose) data)
 200           (message "Successfully retrieved cached data.")
 201         (error "Failed to retrieve cached data")))))
 202
 203 (defun semantic-test-throw-on-input ()
 204   "Test that throw on input will work."
 205   (interactive)
 206   (semantic-throw-on-input 'done-die)
 207   (message "Exit Code: %s"
 208            (semantic-exit-on-input 'testing
 209              (let ((inhibit-quit nil)
 210                    (message-log-max nil))
 211                (while t
 212                  (message "Looping ... press a key to test")
 213                  (semantic-throw-on-input 'test-inner-loop))
 214                'exit)))
 215   (when (input-pending-p)
 216     (if (fboundp 'read-event)
 217         (read-event)
 218       (read-char))))
 219
 220 ;;; From semantic-idle:
 221
 222 (require 'semantic/idle)
 223
 224 (defun semantic-idle-pnf-test ()
 225   "Test `semantic-idle-scheduler-work-parse-neighboring-files' and time it."
 226   (interactive)
 227   (let ((start (current-time))
 228         (junk (semantic-idle-scheduler-work-parse-neighboring-files))
 229         (end (current-time)))
 230     (message "Work took %.2f seconds." (semantic-elapsed-time start end))))
 231
 232 ;;; From semantic-lex:
 233
 234 (require 'semantic/lex)
 235
 236 (defun semantic-lex-test-full-depth (arg)
 237   "Test the semantic lexer in the current buffer parsing through lists.
 238 Usually the lexer parses.
 239 If universal argument ARG, then try the whole buffer."
 240   (interactive "P")
 241   (let* ((start (current-time))
 242          (result (semantic-lex
 243                   (if arg (point-min) (point))
 244                   (point-max)
 245                   100))
 246          (end (current-time)))
 247     (message "Elapsed Time: %.2f seconds."
 248              (semantic-elapsed-time start end))
 249     (pop-to-buffer "*Lexer Output*")
 250     (require 'pp)
 251     (erase-buffer)
 252     (insert (pp-to-string result))
 253     (goto-char (point-min))))
 254
 255 (defun semantic-lex-test-region (beg end)
 256   "Test the semantic lexer in the current buffer.
 257 Analyze the area between BEG and END."
 258   (interactive "r")
 259   (let ((result (semantic-lex beg end)))
 260     (pop-to-buffer "*Lexer Output*")
 261     (require 'pp)
 262     (erase-buffer)
 263     (insert (pp-to-string result))
 264     (goto-char (point-min))))
 265
 266 ;;; From semantic-lex-spp:
 267
 268 (require 'semantic/lex-spp)
 269
 270 (defun semantic-lex-spp-write-test ()
 271   "Test the semantic tag writer against the current buffer."
 272   (interactive)
 273   (with-output-to-temp-buffer "*SPP Write Test*"
 274     (semantic-lex-spp-table-write-slot-value
 275      (semantic-lex-spp-save-table))))
 276
 277 (defun semantic-lex-spp-write-utest ()
 278   "Unit test using the test spp file to test the slot write fcn."
 279   (interactive)
 280   (let* ((sem (locate-library "semantic-lex-spp.el"))
 281          (dir (file-name-directory sem)))
 282     (save-excursion
 283       (set-buffer (find-file-noselect
 284                    (expand-file-name "tests/testsppreplace.c"
 285                                      dir)))
 286       (semantic-lex-spp-write-test))))
 287
 288 ;;; From semantic-tag-write:
 289
 290 ;;; TESTING.
 291
 292 (require 'semantic/tag-write)
 293
 294 (defun semantic-tag-write-test ()
 295   "Test the semantic tag writer against the tag under point."
 296   (interactive)
 297   (with-output-to-temp-buffer "*Tag Write Test*"
 298     (semantic-tag-write-one-tag (semantic-current-tag))))
 299
 300 (defun semantic-tag-write-list-test ()
 301   "Test the semantic tag writer against the tag under point."
 302   (interactive)
 303   (with-output-to-temp-buffer "*Tag Write Test*"
 304     (semantic-tag-write-tag-list (semantic-fetch-tags))))
 305
 306 ;;; From semantic-symref-filter:
 307
 308 (require 'semantic/symref/filter)
 309
 310 (defun semantic-symref-test-count-hits-in-tag ()
 311   "Lookup in the current tag the symbol under point.
 312 Then count all the other references to the same symbol within the
 313 tag that contains point, and return that."
 314   (interactive)
 315   (let* ((ctxt (semantic-analyze-current-context))
 316          (target (car (reverse (oref ctxt prefix))))
 317          (tag (semantic-current-tag))
 318          (start (current-time))
 319          (Lcount 0))
 320     (when (semantic-tag-p target)
 321       (semantic-symref-hits-in-region
 322        target (lambda (start end prefix) (setq Lcount (1+ Lcount)))
 323        (semantic-tag-start tag)
 324        (semantic-tag-end tag))
 325       (when (interactive-p)
 326         (message "Found %d occurrences of %s in %.2f seconds"
 327                  Lcount (semantic-tag-name target)
 328                  (semantic-elapsed-time start (current-time))))
 329       Lcount)))
 330
 331 ;;; From bovine-gcc:
 332
 333 (require 'semantic/bovine/gcc)
 334
 335 ;; Example output of "gcc -v"
 336 (defvar semantic-gcc-test-strings
 337   '(;; My old box:
 338     "Reading specs from /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/specs
 339 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
 340 Thread model: posix
 341 gcc version 3.2.2 20030222 (Red Hat Linux 3.2.2-5)"
 342     ;; Alex Ott:
 343     "Using built-in specs.
 344 Target: i486-linux-gnu
 345 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
 346 Thread model: posix
 347 gcc version 4.3.1 (Ubuntu 4.3.1-9ubuntu1)"
 348     ;; My debian box:
 349     "Using built-in specs.
 350 Target: x86_64-unknown-linux-gnu
 351 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
 352 Thread model: posix
 353 gcc version 4.2.3"
 354     ;; My mac:
 355     "Using built-in specs.
 356 Target: i686-apple-darwin8
 357 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
 358 Thread model: posix
 359 gcc version 4.0.1 (Apple Computer, Inc. build 5341)"
 360     ;; Ubuntu Intrepid
 361     "Using built-in specs.
 362 Target: x86_64-linux-gnu
 363 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
 364 Thread model: posix
 365 gcc version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)"
 366     ;; Red Hat EL4
 367     "Reading specs from /usr/lib/gcc/x86_64-redhat-linux/3.4.6/specs
 368 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
 369 Thread model: posix
 370 gcc version 3.4.6 20060404 (Red Hat 3.4.6-10)"
 371     ;; Red Hat EL5
 372     "Using built-in specs.
 373 Target: x86_64-redhat-linux
 374 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
 375 Thread model: posix
 376 gcc version 4.1.2 20080704 (Red Hat 4.1.2-44)"
 377     ;; David Engster's german gcc on ubuntu 4.3
 378     "Es werden eingebaute Spezifikationen verwendet.
 379 Ziel: i486-linux-gnu
 380 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
 381 Thread-Modell: posix
 382 gcc-Version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)"
 383     ;; Damien Deville bsd
 384     "Using built-in specs.
 385 Target: i386-undermydesk-freebsd
 386 Configured with: FreeBSD/i386 system compiler
 387 Thread model: posix
 388 gcc version 4.2.1 20070719  [FreeBSD]"
 389     )
 390   "A bunch of sample gcc -v outputs from different machines.")
 391
 392 (defvar semantic-gcc-test-strings-fail
 393   '(;; A really old solaris box I found
 394     "Reading specs from /usr/local/gcc-2.95.2/lib/gcc-lib/sparc-sun-solaris2.6/2.95.2/specs
 395 gcc version 2.95.2 19991024 (release)"
 396     )
 397   "A bunch of sample gcc -v outputs that fail to provide the info we want.")
 398
 399 (defun semantic-gcc-test-output-parser ()
 400   "Test the output parser against some collected strings."
 401   (interactive)
 402   (let ((fail nil))
 403     (dolist (S semantic-gcc-test-strings)
 404       (let* ((fields (semantic-gcc-fields S))
 405              (v (cdr (assoc 'version fields)))
 406              (h (or (cdr (assoc 'target fields))
 407                     (cdr (assoc '--target fields))
 408                     (cdr (assoc '--host fields))))
 409              (p (cdr (assoc '--prefix fields)))
 410              )
 411         ;; No longer test for prefixes.
 412         (when (not (and v h))
 413           (let ((strs (split-string S "\n")))
 414             (message "Test failed on %S\nV H P:\n%S %S %S" (car strs) v h p))
 415           (setq fail t))
 416         ))
 417     (dolist (S semantic-gcc-test-strings-fail)
 418       (let* ((fields (semantic-gcc-fields S))
 419              (v (cdr (assoc 'version fields)))
 420              (h (or (cdr (assoc '--host fields))
 421                     (cdr (assoc 'target fields))))
 422              (p (cdr (assoc '--prefix fields)))
 423              )
 424         (when (and v h p)
 425           (message "Negative test failed on %S" S)
 426           (setq fail t))
 427         ))
 428     (if (not fail) (message "Tests passed."))
 429     ))
 430
 431 (defun semantic-gcc-test-output-parser-this-machine ()
 432   "Test the output parser against the machine currently running Emacs."
 433   (interactive)
 434   (let ((semantic-gcc-test-strings (list (semantic-gcc-query "gcc" "-v"))))
 435     (semantic-gcc-test-output-parser))
 436   )
 437
 438 ;; arch-tag: 91686489-4ab3-4392-8277-b3831269ddbb