emacs/lisp/cedet/semantic/adebug.el

;;; semantic/adebug.el --- Semantic Application Debugger

;;; Copyright (C) 2007, 2008, 2009 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 <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Semantic datastructure debugger for semantic applications.
;; Uses data-debug for core implementation.
;;
;; Goals:
;;
;; Inspect all known details of a TAG in a buffer.
;;
;; Analyze the list of active semantic databases, and the tags therin.
;;
;; Allow interactive navigation of the analysis process, tags, etc.

(require 'data-debug)
(require 'eieio-datadebug)
(require 'semantic/analyze)

;;; Code:

;;; SEMANTIC TAG STUFF
;;
(defun data-debug-insert-tag-parts (tag prefix &optional parent)
  "Insert all the parts of TAG.
PREFIX specifies what to insert at the start of each line.
PARENT specifires any parent tag."
  (data-debug-insert-thing (semantic-tag-name tag)
			   prefix
			   "Name: "
			   parent)
  (insert prefix "Class: '" (format "%S" (semantic-tag-class tag)) "\n")
  (when (semantic-tag-with-position-p tag)
    (let ((ol (semantic-tag-overlay tag))
	  (file (semantic-tag-file-name tag))
	  (start (semantic-tag-start tag))
	  (end (semantic-tag-end tag))
	  )
      (insert prefix "Position: "
	      (if (and (numberp start) (numberp end))
		  (format "%d -> %d in " start end)
		"")
	      (if file (file-name-nondirectory file) "unknown-file")
	      (if (semantic-overlay-p ol)
		  " <live tag>"
		"")
	      "\n")
      (data-debug-insert-thing ol prefix
			       "Position Data: "
			       parent)
      ))
  (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")))
    (insert prefix "Attributes:\n")
    (data-debug-insert-property-list
     (semantic-tag-attributes tag) attrprefix tag)
    (insert prefix "Properties:\n")
    (data-debug-insert-property-list
     (semantic-tag-properties tag) attrprefix tag)
    )

  )

(defun data-debug-insert-tag-parts-from-point (point)
  "Call `data-debug-insert-tag-parts' based on text properties at POINT."
  (let ((tag (get-text-property point 'ddebug))
	(parent (get-text-property point 'ddebug-parent))
	(indent (get-text-property point 'ddebug-indent))
	start
	)
    (end-of-line)
    (setq start (point))
    (forward-char 1)
    (data-debug-insert-tag-parts tag
				 (concat (make-string indent ? )
					 "| ")
				 parent)
    (goto-char start)
    ))

(defun data-debug-insert-tag (tag prefix prebuttontext &optional parent)
  "Insert TAG into the current buffer at the current point.
PREFIX specifies text to insert in front of TAG.
PREBUTTONTEXT is text appearing btewen the prefix and TAG.
Optional PARENT is the parent tag containing TAG.
Add text properties needed to allow tag expansion later."
  (let ((start (point))
	(end nil)
	(str (semantic-format-tag-uml-abbreviate tag parent t))
	(tip (semantic-format-tag-prototype tag parent t))
	)
    (insert prefix prebuttontext str "\n")
    (setq end (point))
    (put-text-property start end 'ddebug tag)
    (put-text-property start end 'ddebug-parent parent)
    (put-text-property start end 'ddebug-indent(length prefix))
    (put-text-property start end 'ddebug-prefix prefix)
    (put-text-property start end 'help-echo tip)
    (put-text-property start end 'ddebug-function
		       'data-debug-insert-tag-parts-from-point)

    ))

;;; TAG LISTS
;;
(defun data-debug-insert-tag-list (taglist prefix &optional parent)
  "Insert the tag list TAGLIST with PREFIX.
Optional argument PARENT specifies the part of TAGLIST."
  (condition-case nil
      (while taglist
	(cond ((and (consp taglist) (semantic-tag-p (car taglist)))
	       (data-debug-insert-tag (car taglist) prefix "" parent))
	      ((consp taglist)
	       (data-debug-insert-thing (car taglist) prefix "" parent))
	      (t (data-debug-insert-thing taglist prefix "" parent)))
	(setq taglist (cdr taglist)))
    (error nil)))

(defun data-debug-insert-taglist-from-point (point)
  "Insert the taglist found at the taglist button at POINT."
  (let ((taglist (get-text-property point 'ddebug))
	(parent (get-text-property point 'ddebug-parent))
	(indent (get-text-property point 'ddebug-indent))
	start
	)
    (end-of-line)
    (setq start (point))
    (forward-char 1)
    (data-debug-insert-tag-list taglist
				(concat (make-string indent ? )
					"* ")
				parent)
    (goto-char start)

    ))

(defun data-debug-insert-tag-list-button (taglist prefix prebuttontext &optional parent)
  "Insert a single summary of a TAGLIST.
PREFIX is the text that preceeds the button.
PREBUTTONTEXT is some text between PREFIX and the taglist button.
PARENT is the tag that represents the parent of all the tags."
  (let ((start (point))
	(end nil)
	(str (format "#<TAG LIST: %d entries>" (safe-length taglist)))
	(tip nil))
    (insert prefix prebuttontext str)
    (setq end (point))
    (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face)
    (put-text-property start end 'ddebug taglist)
    (put-text-property start end 'ddebug-parent parent)
    (put-text-property start end 'ddebug-indent(length prefix))
    (put-text-property start end 'ddebug-prefix prefix)
    (put-text-property start end 'help-echo tip)
    (put-text-property start end 'ddebug-function
		       'data-debug-insert-taglist-from-point)
    (insert "\n")
    ))

;;; SEMANTICDB FIND RESULTS
;;
(defun data-debug-insert-find-results (findres prefix)
  "Insert the find results FINDRES with PREFIX."
  ;; ( (DBOBJ TAG TAG TAG) (DBOBJ TAG TAG TAG) ... )
  (let ((cnt 1))
    (while findres
      (let* ((dbhit (car findres))
	     (db (car dbhit))
	     (tags (cdr dbhit)))
	(data-debug-insert-thing db prefix (format "DB %d: " cnt))
	(data-debug-insert-thing tags prefix (format "HITS %d: " cnt))
	)
      (setq findres (cdr findres)
	    cnt (1+ cnt)))))

(defun data-debug-insert-find-results-from-point (point)
  "Insert the find results found at the find results button at POINT."
  (let ((findres (get-text-property point 'ddebug))
	(indent (get-text-property point 'ddebug-indent))
	start
	)
    (end-of-line)
    (setq start (point))
    (forward-char 1)
    (data-debug-insert-find-results findres
				    (concat (make-string indent ? )
					    "!* ")
				    )
    (goto-char start)
    ))

(declare-function semanticdb-find-result-prin1-to-string "semantic/db-find")

(defun data-debug-insert-find-results-button (findres prefix prebuttontext)
  "Insert a single summary of a find results FINDRES.
PREFIX is the text that preceeds the button.
PREBUTTONTEXT is some text between prefix and the find results button."
  (require 'semantic/db-find)
  (let ((start (point))
	(end nil)
	(str (semanticdb-find-result-prin1-to-string findres))
	(tip nil))
    (insert prefix prebuttontext str)
    (setq end (point))
    (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face)
    (put-text-property start end 'ddebug findres)
    (put-text-property start end 'ddebug-indent(length prefix))
    (put-text-property start end 'ddebug-prefix prefix)
    (put-text-property start end 'help-echo tip)
    (put-text-property start end 'ddebug-function
		       'data-debug-insert-find-results-from-point)
    (insert "\n")
    ))

(defun data-debug-insert-db-and-tag-button (dbtag prefix prebuttontext)
  "Insert a single summary of short list DBTAG of format (DB . TAG).
PREFIX is the text that preceeds the button.
PREBUTTONTEXT is some text between prefix and the find results button."
  (let ((start (point))
	(end nil)
	(str (concat "(#<db/tag "
		     (object-name-string (car dbtag))
		     " / "
		     (semantic-format-tag-name (cdr dbtag) nil t)
		     ")"))
	(tip nil))
    (insert prefix prebuttontext str)
    (setq end (point))
    (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face)
    (put-text-property start end 'ddebug dbtag)
    (put-text-property start end 'ddebug-indent(length prefix))
    (put-text-property start end 'ddebug-prefix prefix)
    (put-text-property start end 'help-echo tip)
    (put-text-property start end 'ddebug-function
		       'data-debug-insert-db-and-tag-from-point)
    (insert "\n")
    ))

(defun data-debug-insert-db-and-tag-from-point (point)
  "Insert the find results found at the find results button at POINT."
  (let ((dbtag (get-text-property point 'ddebug))
	(indent (get-text-property point 'ddebug-indent))
	start
	)
    (end-of-line)
    (setq start (point))
    (forward-char 1)
    (data-debug-insert-thing (car dbtag) (make-string indent ? )
			     "| DB ")
    (data-debug-insert-tag (cdr dbtag) (concat (make-string indent ? )
					       "| ")
			   "TAG ")
    (goto-char start)
    ))

;;; DEBUG COMMANDS
;;
;; Various commands to output aspects of the current semantic environment.
(defun semantic-adebug-bovinate ()
  "The same as `bovinate'.  Display the results in a debug buffer."
  (interactive)
  (let* ((start (current-time))
	 (out (semantic-fetch-tags))
	 (end (current-time)))

    (message "Retrieving tags took %.2f seconds."
	     (semantic-elapsed-time start end))

    (data-debug-new-buffer (concat "*" (buffer-name) " ADEBUG*"))
    (data-debug-insert-tag-list out "* "))
  )

(defun semantic-adebug-searchdb (regex)
  "Search the semanticdb for REGEX for the current buffer.
Display the results as a debug list."
  (interactive "sSymbol Regex: ")
  (let ((start (current-time))
	(fr (semanticdb-find-tags-by-name-regexp regex))
	(end (current-time)))

    (data-debug-new-buffer (concat "*SEMANTICDB SEARCH: "
				   regex
				   " ADEBUG*"))
    (message "Search of tags took %.2f seconds."
	     (semantic-elapsed-time start end))

    (data-debug-insert-find-results fr "*")))

(defun semantic-adebug-analyze (&optional ctxt)
  "Perform `semantic-analyze-current-context'.
Display the results as a debug list.
Optional argument CTXT is the context to show."
  (interactive)
  (let ((start (current-time))
	(ctxt (or ctxt (semantic-analyze-current-context)))
	(end (current-time)))
    (if (not ctxt)
	(message "No Analyzer Results")
      (message "Analysis  took %.2f seconds."
	       (semantic-elapsed-time start end))
      (semantic-analyze-pulse ctxt)
      (if ctxt
	  (progn
	    (data-debug-new-buffer "*Analyzer ADEBUG*")
	    (data-debug-insert-object-slots ctxt "]"))
	(message "No Context to analyze here.")))))

(defun semantic-adebug-edebug-expr (expr)
  "Dump out the contets of some expression EXPR in edebug with adebug."
  (interactive "sExpression: ")
  (let ((v (eval (read expr))))
    (if (not v)
	(message "Expression %s is nil." expr)
      (data-debug-new-buffer "*expression ADEBUG*")
      (data-debug-insert-thing v "?" "")
      )))

(defun semanticdb-debug-file-tag-check (startfile)
  "Report debug info for checking STARTFILE for up-to-date tags."
  (interactive "FFile to Check (default = current-buffer): ")
  (let* ((file (file-truename startfile))
	 (default-directory (file-name-directory file))
	 (db (or
	      ;; This line will pick up system databases.
	      (semanticdb-directory-loaded-p default-directory)
	      ;; this line will make a new one if needed.
	      (semanticdb-get-database default-directory)))
	 (tab (semanticdb-file-table db file))
	 )
    (with-output-to-temp-buffer "*DEBUG STUFF*"
      (princ "Starting file is: ")
      (princ startfile)
      (princ "\nTrueName is: ")
      (princ file)
      (when (not (file-exists-p file))
	(princ "\nFile does not exist!"))
      (princ "\nDirectory Part is: ")
      (princ default-directory)
      (princ "\nFound Database is: ")
      (princ (object-print db))
      (princ "\nFound Table is: ")
      (if tab (princ (object-print tab)) (princ "nil"))
      (princ "\n\nAction Summary: ")
      (cond
       ((and tab
	     ;; Is this in a buffer?
	     (find-buffer-visiting (semanticdb-full-filename tab))
	     )
	(princ "Found Buffer: ")
	(prin1 (find-buffer-visiting (semanticdb-full-filename tab)))
	)
       ((and tab
	     ;; Is table fully loaded, or just a proxy?
	     (number-or-marker-p (oref tab pointmax))
	     ;; Is this table up to date with the file?
	     (not (semanticdb-needs-refresh-p tab)))
	(princ "Found table, no refresh needed.\n   Pointmax is: ")
	(prin1 (oref tab pointmax))
	)
       (t
	(princ "Found table that needs refresh.")
	(if (not tab)
	    (princ "\n   No Saved Point.")
	  (princ "\n  Saved pointmax: ")
	  (prin1 (oref tab pointmax))
	  (princ "  Needs Refresh: ")
	  (prin1 (semanticdb-needs-refresh-p tab))
	  )
	))
      ;; Buffer isn't loaded.  The only clue we have is if the file
      ;; is somehow different from our mark in the semanticdb table.
      (let* ((stats (file-attributes file))
	     (actualsize (nth 7 stats))
	     (actualmod (nth 5 stats))
	     )

	(if (or  (not tab)
		 (not (slot-boundp tab 'tags))
		 (not (oref tab tags)))
	    (princ "\n   No tags in table.")
	  (princ "\n   Number of known tags: ")
	  (prin1 (length (oref tab tags))))

	(princ "\n   File Size is: ")
	(prin1 actualsize)
	(princ "\n   File Mod Time is: ")
	(princ (format-time-string "%Y-%m-%d %T" actualmod))
	(when tab
	  (princ "\n   Saved file size is: ")
	  (prin1 (oref tab fsize))
	  (princ "\n   Saved Mod time is: ")
	  (princ (format-time-string "%Y-%m-%d %T"
				     (oref tab lastmodtime)))
	  )
	)
      )
    ;; Force load
    (semanticdb-file-table-object file)
    nil
    ))

;; (semanticdb-debug-file-tag-check "/usr/lib/gcc/i486-linux-gnu/4.2/include/stddef.h")
;; (semanticdb-debug-file-tag-check "/usr/include/stdlib.h")



(provide 'semantic/adebug)

;;; semantic/adebug.el ends here