code.delx.au - gnu-emacs/blob - lisp/cedet/semantic/adebug.el

   1 ;;; semantic/adebug.el --- Semantic Application Debugger
   2
   3 ;;; Copyright (C) 2007, 2008, 2009 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 ;; Semantic datastructure debugger for semantic applications.
  25 ;; Uses data-debug for core implementation.
  26 ;;
  27 ;; Goals:
  28 ;;
  29 ;; Inspect all known details of a TAG in a buffer.
  30 ;;
  31 ;; Analyze the list of active semantic databases, and the tags therin.
  32 ;;
  33 ;; Allow interactive navigation of the analysis process, tags, etc.
  34
  35 (require 'eieio)
  36 (require 'data-debug)
  37 (require 'semantic)
  38 (require 'semantic/tag)
  39 (require 'semantic/format)
  40
  41 (declare-function semanticdb-get-database "semantic/db")
  42 (declare-function semanticdb-directory-loaded-p "semantic/db")
  43 (declare-function semanticdb-file-table "semantic/db")
  44 (declare-function semanticdb-needs-refresh-p "semantic/db")
  45 (declare-function semanticdb-full-filename "semantic/db")
  46
  47 ;;; Code:
  48
  49 ;;; SEMANTIC TAG STUFF
  50 ;;
  51 (defun data-debug-insert-tag-parts (tag prefix &optional parent)
  52   "Insert all the parts of TAG.
  53 PREFIX specifies what to insert at the start of each line.
  54 PARENT specifires any parent tag."
  55   (data-debug-insert-thing (semantic-tag-name tag)
  56                            prefix
  57                            "Name: "
  58                            parent)
  59   (insert prefix "Class: '" (format "%S" (semantic-tag-class tag)) "\n")
  60   (when (semantic-tag-with-position-p tag)
  61     (let ((ol (semantic-tag-overlay tag))
  62           (file (semantic-tag-file-name tag))
  63           (start (semantic-tag-start tag))
  64           (end (semantic-tag-end tag))
  65           )
  66       (insert prefix "Position: "
  67               (if (and (numberp start) (numberp end))
  68                   (format "%d -> %d in " start end)
  69                 "")
  70               (if file (file-name-nondirectory file) "unknown-file")
  71               (if (semantic-overlay-p ol)
  72                   " <live tag>"
  73                 "")
  74               "\n")
  75       (data-debug-insert-thing ol prefix
  76                                "Position Data: "
  77                                parent)
  78       ))
  79   (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")))
  80     (insert prefix "Attributes:\n")
  81     (data-debug-insert-property-list
  82      (semantic-tag-attributes tag) attrprefix tag)
  83     (insert prefix "Properties:\n")
  84     (data-debug-insert-property-list
  85      (semantic-tag-properties tag) attrprefix tag)
  86     )
  87
  88   )
  89
  90 (defun data-debug-insert-tag-parts-from-point (point)
  91   "Call `data-debug-insert-tag-parts' based on text properties at POINT."
  92   (let ((tag (get-text-property point 'ddebug))
  93         (parent (get-text-property point 'ddebug-parent))
  94         (indent (get-text-property point 'ddebug-indent))
  95         start
  96         )
  97     (end-of-line)
  98     (setq start (point))
  99     (forward-char 1)
 100     (data-debug-insert-tag-parts tag
 101                                  (concat (make-string indent ? )
 102                                          "| ")
 103                                  parent)
 104     (goto-char start)
 105     ))
 106
 107 (defun data-debug-insert-tag (tag prefix prebuttontext &optional parent)
 108   "Insert TAG into the current buffer at the current point.
 109 PREFIX specifies text to insert in front of TAG.
 110 PREBUTTONTEXT is text appearing btewen the prefix and TAG.
 111 Optional PARENT is the parent tag containing TAG.
 112 Add text properties needed to allow tag expansion later."
 113   (let ((start (point))
 114         (end nil)
 115         (str (semantic-format-tag-uml-abbreviate tag parent t))
 116         (tip (semantic-format-tag-prototype tag parent t))
 117         )
 118     (insert prefix prebuttontext str "\n")
 119     (setq end (point))
 120     (put-text-property start end 'ddebug tag)
 121     (put-text-property start end 'ddebug-parent parent)
 122     (put-text-property start end 'ddebug-indent(length prefix))
 123     (put-text-property start end 'ddebug-prefix prefix)
 124     (put-text-property start end 'help-echo tip)
 125     (put-text-property start end 'ddebug-function
 126                        'data-debug-insert-tag-parts-from-point)
 127
 128     ))
 129
 130 ;;; TAG LISTS
 131 ;;
 132 (defun data-debug-insert-tag-list (taglist prefix &optional parent)
 133   "Insert the tag list TAGLIST with PREFIX.
 134 Optional argument PARENT specifies the part of TAGLIST."
 135   (condition-case nil
 136       (while taglist
 137         (cond ((and (consp taglist) (semantic-tag-p (car taglist)))
 138                (data-debug-insert-tag (car taglist) prefix "" parent))
 139               ((consp taglist)
 140                (data-debug-insert-thing (car taglist) prefix "" parent))
 141               (t (data-debug-insert-thing taglist prefix "" parent)))
 142         (setq taglist (cdr taglist)))
 143     (error nil)))
 144
 145 (defun data-debug-insert-taglist-from-point (point)
 146   "Insert the taglist found at the taglist button at POINT."
 147   (let ((taglist (get-text-property point 'ddebug))
 148         (parent (get-text-property point 'ddebug-parent))
 149         (indent (get-text-property point 'ddebug-indent))
 150         start
 151         )
 152     (end-of-line)
 153     (setq start (point))
 154     (forward-char 1)
 155     (data-debug-insert-tag-list taglist
 156                                 (concat (make-string indent ? )
 157                                         "* ")
 158                                 parent)
 159     (goto-char start)
 160
 161     ))
 162
 163 (defun data-debug-insert-tag-list-button (taglist prefix prebuttontext &optional parent)
 164   "Insert a single summary of a TAGLIST.
 165 PREFIX is the text that preceeds the button.
 166 PREBUTTONTEXT is some text between PREFIX and the taglist button.
 167 PARENT is the tag that represents the parent of all the tags."
 168   (let ((start (point))
 169         (end nil)
 170         (str (format "#<TAG LIST: %d entries>" (safe-length taglist)))
 171         (tip nil))
 172     (insert prefix prebuttontext str)
 173     (setq end (point))
 174     (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face)
 175     (put-text-property start end 'ddebug taglist)
 176     (put-text-property start end 'ddebug-parent parent)
 177     (put-text-property start end 'ddebug-indent(length prefix))
 178     (put-text-property start end 'ddebug-prefix prefix)
 179     (put-text-property start end 'help-echo tip)
 180     (put-text-property start end 'ddebug-function
 181                        'data-debug-insert-taglist-from-point)
 182     (insert "\n")
 183     ))
 184
 185 ;;; SEMANTICDB FIND RESULTS
 186 ;;
 187 (defun data-debug-insert-find-results (findres prefix)
 188   "Insert the find results FINDRES with PREFIX."
 189   ;; ( (DBOBJ TAG TAG TAG) (DBOBJ TAG TAG TAG) ... )
 190   (let ((cnt 1))
 191     (while findres
 192       (let* ((dbhit (car findres))
 193              (db (car dbhit))
 194              (tags (cdr dbhit)))
 195         (data-debug-insert-thing db prefix (format "DB %d: " cnt))
 196         (data-debug-insert-thing tags prefix (format "HITS %d: " cnt))
 197         )
 198       (setq findres (cdr findres)
 199             cnt (1+ cnt)))))
 200
 201 (defun data-debug-insert-find-results-from-point (point)
 202   "Insert the find results found at the find results button at POINT."
 203   (let ((findres (get-text-property point 'ddebug))
 204         (indent (get-text-property point 'ddebug-indent))
 205         start
 206         )
 207     (end-of-line)
 208     (setq start (point))
 209     (forward-char 1)
 210     (data-debug-insert-find-results findres
 211                                     (concat (make-string indent ? )
 212                                             "!* ")
 213                                     )
 214     (goto-char start)
 215     ))
 216
 217 (declare-function semanticdb-find-result-prin1-to-string "semantic/db-find")
 218
 219 (defun data-debug-insert-find-results-button (findres prefix prebuttontext)
 220   "Insert a single summary of a find results FINDRES.
 221 PREFIX is the text that preceeds the button.
 222 PREBUTTONTEXT is some text between prefix and the find results button."
 223   (require 'semantic/db-find)
 224   (let ((start (point))
 225         (end nil)
 226         (str (semanticdb-find-result-prin1-to-string findres))
 227         (tip nil))
 228     (insert prefix prebuttontext str)
 229     (setq end (point))
 230     (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face)
 231     (put-text-property start end 'ddebug findres)
 232     (put-text-property start end 'ddebug-indent(length prefix))
 233     (put-text-property start end 'ddebug-prefix prefix)
 234     (put-text-property start end 'help-echo tip)
 235     (put-text-property start end 'ddebug-function
 236                        'data-debug-insert-find-results-from-point)
 237     (insert "\n")
 238     ))
 239
 240 (defun data-debug-insert-db-and-tag-button (dbtag prefix prebuttontext)
 241   "Insert a single summary of short list DBTAG of format (DB . TAG).
 242 PREFIX is the text that preceeds the button.
 243 PREBUTTONTEXT is some text between prefix and the find results button."
 244   (let ((start (point))
 245         (end nil)
 246         (str (concat "(#<db/tag "
 247                      (object-name-string (car dbtag))
 248                      " / "
 249                      (semantic-format-tag-name (cdr dbtag) nil t)
 250                      ")"))
 251         (tip nil))
 252     (insert prefix prebuttontext str)
 253     (setq end (point))
 254     (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face)
 255     (put-text-property start end 'ddebug dbtag)
 256     (put-text-property start end 'ddebug-indent(length prefix))
 257     (put-text-property start end 'ddebug-prefix prefix)
 258     (put-text-property start end 'help-echo tip)
 259     (put-text-property start end 'ddebug-function
 260                        'data-debug-insert-db-and-tag-from-point)
 261     (insert "\n")
 262     ))
 263
 264 (defun data-debug-insert-db-and-tag-from-point (point)
 265   "Insert the find results found at the find results button at POINT."
 266   (let ((dbtag (get-text-property point 'ddebug))
 267         (indent (get-text-property point 'ddebug-indent))
 268         start
 269         )
 270     (end-of-line)
 271     (setq start (point))
 272     (forward-char 1)
 273     (data-debug-insert-thing (car dbtag) (make-string indent ? )
 274                              "| DB ")
 275     (data-debug-insert-tag (cdr dbtag) (concat (make-string indent ? )
 276                                                "| ")
 277                            "TAG ")
 278     (goto-char start)
 279     ))
 280
 281 ;;; DEBUG COMMANDS
 282 ;;
 283 ;; Various commands to output aspects of the current semantic environment.
 284 (defun semantic-adebug-bovinate ()
 285   "The same as `bovinate'.  Display the results in a debug buffer."
 286   (interactive)
 287   (let* ((start (current-time))
 288          (out (semantic-fetch-tags))
 289          (end (current-time)))
 290
 291     (message "Retrieving tags took %.2f seconds."
 292              (semantic-elapsed-time start end))
 293
 294     (data-debug-new-buffer (concat "*" (buffer-name) " ADEBUG*"))
 295     (data-debug-insert-tag-list out "* "))
 296   )
 297
 298 (defun semantic-adebug-searchdb (regex)
 299   "Search the semanticdb for REGEX for the current buffer.
 300 Display the results as a debug list."
 301   (interactive "sSymbol Regex: ")
 302   (let ((start (current-time))
 303         (fr (semanticdb-find-tags-by-name-regexp regex))
 304         (end (current-time)))
 305
 306     (data-debug-new-buffer (concat "*SEMANTICDB SEARCH: "
 307                                    regex
 308                                    " ADEBUG*"))
 309     (message "Search of tags took %.2f seconds."
 310              (semantic-elapsed-time start end))
 311
 312     (data-debug-insert-find-results fr "*")))
 313
 314 (defun semanticdb-debug-file-tag-check (startfile)
 315   "Report debug info for checking STARTFILE for up-to-date tags."
 316   (interactive "FFile to Check (default = current-buffer): ")
 317   (require 'semantic/db)
 318   (let* ((file (file-truename startfile))
 319          (default-directory (file-name-directory file))
 320          (db (or
 321               ;; This line will pick up system databases.
 322               (semanticdb-directory-loaded-p default-directory)
 323               ;; this line will make a new one if needed.
 324               (semanticdb-get-database default-directory)))
 325          (tab (semanticdb-file-table db file))
 326          )
 327     (with-output-to-temp-buffer "*DEBUG STUFF*"
 328       (princ "Starting file is: ")
 329       (princ startfile)
 330       (princ "\nTrueName is: ")
 331       (princ file)
 332       (when (not (file-exists-p file))
 333         (princ "\nFile does not exist!"))
 334       (princ "\nDirectory Part is: ")
 335       (princ default-directory)
 336       (princ "\nFound Database is: ")
 337       (princ (object-print db))
 338       (princ "\nFound Table is: ")
 339       (if tab (princ (object-print tab)) (princ "nil"))
 340       (princ "\n\nAction Summary: ")
 341       (cond
 342        ((and tab
 343              ;; Is this in a buffer?
 344              (find-buffer-visiting (semanticdb-full-filename tab))
 345              )
 346         (princ "Found Buffer: ")
 347         (prin1 (find-buffer-visiting (semanticdb-full-filename tab)))
 348         )
 349        ((and tab
 350              ;; Is table fully loaded, or just a proxy?
 351              (number-or-marker-p (oref tab pointmax))
 352              ;; Is this table up to date with the file?
 353              (not (semanticdb-needs-refresh-p tab)))
 354         (princ "Found table, no refresh needed.\n   Pointmax is: ")
 355         (prin1 (oref tab pointmax))
 356         )
 357        (t
 358         (princ "Found table that needs refresh.")
 359         (if (not tab)
 360             (princ "\n   No Saved Point.")
 361           (princ "\n  Saved pointmax: ")
 362           (prin1 (oref tab pointmax))
 363           (princ "  Needs Refresh: ")
 364           (prin1 (semanticdb-needs-refresh-p tab))
 365           )
 366         ))
 367       ;; Buffer isn't loaded.  The only clue we have is if the file
 368       ;; is somehow different from our mark in the semanticdb table.
 369       (let* ((stats (file-attributes file))
 370              (actualsize (nth 7 stats))
 371              (actualmod (nth 5 stats))
 372              )
 373
 374         (if (or  (not tab)
 375                  (not (slot-boundp tab 'tags))
 376                  (not (oref tab tags)))
 377             (princ "\n   No tags in table.")
 378           (princ "\n   Number of known tags: ")
 379           (prin1 (length (oref tab tags))))
 380
 381         (princ "\n   File Size is: ")
 382         (prin1 actualsize)
 383         (princ "\n   File Mod Time is: ")
 384         (princ (format-time-string "%Y-%m-%d %T" actualmod))
 385         (when tab
 386           (princ "\n   Saved file size is: ")
 387           (prin1 (oref tab fsize))
 388           (princ "\n   Saved Mod time is: ")
 389           (princ (format-time-string "%Y-%m-%d %T"
 390                                      (oref tab lastmodtime)))
 391           )
 392         )
 393       )
 394     ;; Force load
 395     (semanticdb-file-table-object file)
 396     nil
 397     ))
 398
 399 ;; (semanticdb-debug-file-tag-check "/usr/lib/gcc/i486-linux-gnu/4.2/include/stddef.h")
 400 ;; (semanticdb-debug-file-tag-check "/usr/include/stdlib.h")
 401
 402
 403
 404 (provide 'semantic/adebug)
 405
 406 ;;; semantic/adebug.el ends here