--- /dev/null
+;;; 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)
+ ))
+
+(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."
+ (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
--- /dev/null
+;;; chart.el --- Utilities for use with semantic tag tables
+
+;;; Copyright (C) 1999, 2000, 2001, 2003, 2005, 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:
+;;
+;; A set of simple functions for charting details about a file based on
+;; the output of the semantic parser.
+;;
+
+(require 'semantic)
+(require 'chart)
+
+;;; Code:
+
+(defun semantic-chart-tags-by-class (&optional tagtable)
+ "Create a bar chart representing the number of tags for a given tag class.
+Each bar represents how many toplevel tags in TAGTABLE
+exist with a given class. See `semantic-symbol->name-assoc-list'
+for tokens which will be charted.
+TAGTABLE is passedto `semantic-something-to-tag-table'."
+ (interactive)
+ (let* ((stream (semantic-something-to-tag-table
+ (or tagtable (current-buffer))))
+ (names (mapcar 'cdr semantic-symbol->name-assoc-list))
+ (nums (mapcar
+ (lambda (symname)
+ (length
+ (semantic-brute-find-tag-by-class (car symname)
+ stream)
+ ))
+ semantic-symbol->name-assoc-list)))
+ (chart-bar-quickie 'vertical
+ "Semantic Toplevel Tag Volume"
+ names "Tag Class"
+ nums "Volume")
+ ))
+
+(defun semantic-chart-database-size (&optional tagtable)
+ "Create a bar chart representing the size of each file in semanticdb.
+Each bar represents how many toplevel tags in TAGTABLE
+exist in each database entry.
+TAGTABLE is passed to `semantic-something-to-tag-table'."
+ (interactive)
+ (if (or (not (fboundp 'semanticdb-minor-mode-p))
+ (not (semanticdb-minor-mode-p)))
+ (error "Semanticdb is not enabled"))
+ (let* ((db semanticdb-current-database)
+ (dbt (semanticdb-get-database-tables db))
+ (names (mapcar 'car
+ (object-assoc-list
+ 'file
+ dbt)))
+ (numnuts (mapcar (lambda (dba)
+ (prog1
+ (cons
+ (if (slot-boundp dba 'tags)
+ (length (oref dba tags))
+ 1)
+ (car names))
+ (setq names (cdr names))))
+ dbt))
+ (nums nil)
+ (fh (/ (- (frame-height) 7) 4)))
+ (setq numnuts (sort numnuts (lambda (a b) (> (car a) (car b)))))
+ (setq names (mapcar 'cdr numnuts)
+ nums (mapcar 'car numnuts))
+ (if (> (length names) fh)
+ (progn
+ (setcdr (nthcdr fh names) nil)
+ (setcdr (nthcdr fh nums) nil)))
+ (chart-bar-quickie 'horizontal
+ "Semantic DB Toplevel Tag Volume"
+ names "File"
+ nums "Volume")
+ ))
+
+(defun semantic-chart-token-complexity (tok)
+ "Calculate the `complexity' of token TOK."
+ (count-lines
+ (semantic-tag-end tok)
+ (semantic-tag-start tok)))
+
+(defun semantic-chart-tag-complexity
+ (&optional class tagtable)
+ "Create a bar chart representing the complexity of some tags.
+Complexity is calculated for tags of CLASS. Each bar represents
+the complexity of some tag in TAGTABLE. Only the most complex
+items are charted. TAGTABLE is passedto
+`semantic-something-to-tag-table'."
+ (interactive)
+ (let* ((sym (if (not class) 'function))
+ (stream
+ (semantic-find-tags-by-class
+ sym (semantic-something-to-tag-table (or tagtable
+ (current-buffer)))
+ ))
+ (name (cond ((semantic-tag-with-position-p (car stream))
+ (buffer-name (semantic-tag-buffer (car stream))))
+ (t "")))
+ (cplx (mapcar (lambda (tok)
+ (cons tok (semantic-chart-token-complexity tok)))
+ stream))
+ (namelabel (cdr (assoc 'function semantic-symbol->name-assoc-list)))
+ (names nil)
+ (nums nil))
+ (setq cplx (sort cplx (lambda (a b) (> (cdr a) (cdr b)))))
+ (while (and cplx (<= (length names) (/ (- (frame-height) 7) 4)))
+ (setq names (cons (semantic-tag-name (car (car cplx)))
+ names)
+ nums (cons (cdr (car cplx)) nums)
+ cplx (cdr cplx)))
+;; ;; (setq names (mapcar (lambda (str)
+;; ;; (substring str (- (length str) 10)))
+;; ;; names))
+ (chart-bar-quickie 'horizontal
+ (format "%s Complexity in %s"
+ (capitalize (symbol-name sym))
+ name)
+ names namelabel
+ nums "Complexity (Lines of code)")
+ ))
+
+(defun semantic-chart-analyzer ()
+ "Chart the extent of the context analysis."
+ (interactive)
+ (let* ((p (semanticdb-find-translate-path nil nil))
+ (plen (length p))
+ (tab semanticdb-current-table)
+ (tc (semanticdb-get-typecache tab))
+ (tclen (+ (length (oref tc filestream))
+ (length (oref tc includestream))))
+ (scope (semantic-calculate-scope))
+ (fslen (length (oref scope fullscope)))
+ (lvarlen (length (oref scope localvar)))
+ )
+ (chart-bar-quickie 'vertical
+ (format "Analyzer Overhead in %s" (buffer-name))
+ '("includes" "typecache" "scopelen" "localvar")
+ "Overhead Entries"
+ (list plen tclen fslen lvarlen)
+ "Number of tags")
+ ))
+
+
+
+(provide 'semantic/chart)
+
+;;; semantic-chart.el ends here
--- /dev/null
+;;; db-debug.el --- Extra level debugging routines for Semantic
+
+;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+;; 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:
+;;
+;; Various routines for debugging SemanticDB issues, or viewing
+;; semanticdb state.
+
+(require 'semantic/db)
+
+;;; Code:
+;;
+(defun semanticdb-dump-all-table-summary ()
+ "Dump a list of all databases in Emacs memory."
+ (interactive)
+ (require 'data-debug)
+ (let ((db semanticdb-database-list))
+ (data-debug-new-buffer "*SEMANTICDB*")
+ (data-debug-insert-stuff-list db "*")))
+
+(defalias 'semanticdb-adebug-database-list 'semanticdb-dump-all-table-summary)
+
+(defun semanticdb-adebug-current-database ()
+ "Run ADEBUG on the current database."
+ (interactive)
+ (require 'data-debug)
+ (let ((p semanticdb-current-database)
+ )
+ (data-debug-new-buffer "*SEMANTICDB ADEBUG*")
+ (data-debug-insert-stuff-list p "*")))
+
+(defun semanticdb-adebug-current-table ()
+ "Run ADEBUG on the current database."
+ (interactive)
+ (require 'data-debug)
+ (let ((p semanticdb-current-table))
+ (data-debug-new-buffer "*SEMANTICDB ADEBUG*")
+ (data-debug-insert-stuff-list p "*")))
+
+
+(defun semanticdb-adebug-project-database-list ()
+ "Run ADEBUG on the current database."
+ (interactive)
+ (require 'data-debug)
+ (let ((p (semanticdb-current-database-list)))
+ (data-debug-new-buffer "*SEMANTICDB ADEBUG*")
+ (data-debug-insert-stuff-list p "*")))
+
+
+\f
+;;; Sanity Checks
+;;
+
+(defun semanticdb-table-oob-sanity-check (cache)
+ "Validate that CACHE tags do not have any overlays in them."
+ (while cache
+ (when (semantic-overlay-p (semantic-tag-overlay cache))
+ (message "Tag %s has an erroneous overlay!"
+ (semantic-format-tag-summarize (car cache))))
+ (semanticdb-table-oob-sanity-check
+ (semantic-tag-components-with-overlays (car cache)))
+ (setq cache (cdr cache))))
+
+(defun semanticdb-table-sanity-check (&optional table)
+ "Validate the current semanticdb TABLE."
+ (interactive)
+ (if (not table) (setq table semanticdb-current-table))
+ (let* ((full-filename (semanticdb-full-filename table))
+ (buff (find-buffer-visiting full-filename)))
+ (if buff
+ (save-excursion
+ (set-buffer buff)
+ (semantic-sanity-check))
+ ;; We can't use the usual semantic validity check, so hack our own.
+ (semanticdb-table-oob-sanity-check (semanticdb-get-tags table)))))
+
+(defun semanticdb-database-sanity-check ()
+ "Validate the current semantic database."
+ (interactive)
+ (let ((tables (semanticdb-get-database-tables
+ semanticdb-current-database)))
+ (while tables
+ (semanticdb-table-sanity-check (car tables))
+ (setq tables (cdr tables)))
+ ))
+
+
+
+(provide 'semantic/db-debug)
+;;; semanticdb-debug.el ends here
--- /dev/null
+;;; db-ebrowse.el --- Semanticdb backend using ebrowse.
+
+;;; Copyright (C) 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Authors: Eric M. Ludlam <zappo@gnu.org>, Joakim Verona
+;; Keywords: tags
+
+;; 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:
+;;
+;; This program was started by Eric Ludlam, and Joakim Verona finished
+;; the implementation by adding searches and fixing bugs.
+;;
+;; Read in custom-created ebrowse BROWSE files into a semanticdb back
+;; end.
+;;
+;; Add these databases to the 'system' search.
+;; Possibly use ebrowse for local parsing too.
+;;
+;; When real details are needed out of the tag system from ebrowse,
+;; we will need to delve into the originating source and parse those
+;; files the usual way.
+;;
+;; COMMANDS:
+;; `semanticdb-create-ebrowse-database' - Call EBROWSE to create a
+;; system database for some directory. In general, use this for
+;; system libraries, such as /usr/include, or include directories
+;; large software projects.
+;; Customize `semanticdb-ebrowse-file-match' to make sure the correct
+;; file extensions are matched.
+;;
+;; `semanticdb-load-ebrowse-caches' - Load all the EBROWSE caches from
+;; your semanticdb system database directory. Once they are
+;; loaded, they become searchable as omnipotent databases for
+;; all C++ files. This is called automatically by semantic-load.
+;; Call it a second time to refresh the Emacs DB with the file.
+;;
+
+(eval-when-compile
+ ;; For generic function searching.
+ (require 'eieio)
+ (require 'eieio-opt)
+ )
+(require 'semantic/db-file)
+
+(eval-and-compile
+ ;; Hopefully, this will allow semanticdb-ebrowse to compile under
+ ;; XEmacs, it just won't run if a user attempts to use it.
+ (condition-case nil
+ (require 'ebrowse)
+ (error nil)))
+
+;;; Code:
+(defvar semanticdb-ebrowse-default-file-name "BROWSE"
+ "The EBROWSE file name used for system caches.")
+
+(defcustom semanticdb-ebrowse-file-match "\\.\\(hh?\\|HH?\\|hpp\\)"
+ "Regular expression matching file names for ebrowse to parse.
+This expression should exclude C++ headers that have no extension.
+By default, include only headers since the semantic use of EBrowse
+is only for searching via semanticdb, and thus only headers would
+be searched."
+ :group 'semanticdb
+ :type 'string)
+
+(defun semanticdb-ebrowse-C-file-p (file)
+ "Is FILE a C or C++ file?"
+ (or (string-match semanticdb-ebrowse-file-match file)
+ (and (string-match "/\\w+$" file)
+ (not (file-directory-p file))
+ (let ((tmp (get-buffer-create "*semanticdb-ebrowse-tmp*")))
+ (save-excursion
+ (set-buffer tmp)
+ (condition-case nil
+ (insert-file-contents file nil 0 100 t)
+ (error (insert-file-contents file nil nil nil t)))
+ (goto-char (point-min))
+ (looking-at "\\s-*/\\(\\*\\|/\\)")
+ ))
+ )))
+
+(defun semanticdb-create-ebrowse-database (dir)
+ "Create an EBROSE database for directory DIR.
+The database file is stored in ~/.semanticdb, or whichever directory
+is specified by `semanticdb-default-save-directory'."
+ (interactive "DDirectory: ")
+ (setq dir (file-name-as-directory dir)) ;; for / on end
+ (let* ((savein (semanticdb-ebrowse-file-for-directory dir))
+ (filebuff (get-buffer-create "*SEMANTICDB EBROWSE TMP*"))
+ (files (directory-files (expand-file-name dir) t))
+ (mma auto-mode-alist)
+ (regexp nil)
+ )
+ ;; Create the input to the ebrowse command
+ (save-excursion
+ (set-buffer filebuff)
+ (buffer-disable-undo filebuff)
+ (setq default-directory (expand-file-name dir))
+
+ ;;; @TODO - convert to use semanticdb-collect-matching-filenames
+ ;; to get the file names.
+
+
+ (mapcar (lambda (f)
+ (when (semanticdb-ebrowse-C-file-p f)
+ (insert f)
+ (insert "\n")))
+ files)
+ ;; Cleanup the ebrowse output buffer.
+ (save-excursion
+ (set-buffer (get-buffer-create "*EBROWSE OUTPUT*"))
+ (erase-buffer))
+ ;; Call the EBROWSE command.
+ (message "Creating ebrowse file: %s ..." savein)
+ (call-process-region (point-min) (point-max)
+ "ebrowse" nil "*EBROWSE OUTPUT*" nil
+ (concat "--output-file=" savein)
+ "--very-verbose")
+ )
+ ;; Create a short LOADER program for loading in this database.
+ (let* ((lfn (concat savein "-load.el"))
+ (lf (find-file-noselect lfn)))
+ (save-excursion
+ (set-buffer lf)
+ (erase-buffer)
+ (insert "(semanticdb-ebrowse-load-helper \""
+ (expand-file-name dir)
+ "\")\n")
+ (save-buffer)
+ (kill-buffer (current-buffer)))
+ (message "Creating ebrowse file: %s ... done" savein)
+ ;; Reload that database
+ (load lfn nil t)
+ )))
+
+(defun semanticdb-load-ebrowse-caches ()
+ "Load all semanticdb controlled EBROWSE caches."
+ (interactive)
+ (let ((f (directory-files semanticdb-default-save-directory
+ t (concat semanticdb-ebrowse-default-file-name "-load.el$") t)))
+ (while f
+ (load (car f) nil t)
+ (setq f (cdr f)))
+ ))
+
+(defun semanticdb-ebrowse-load-helper (directory)
+ "Create the semanticdb database via ebrowse for directory.
+If DIRECTORY is found to be defunct, it won't load the DB, and will
+warn instead."
+ (if (file-directory-p directory)
+ (semanticdb-create-database semanticdb-project-database-ebrowse
+ directory)
+ (let* ((BF (semanticdb-ebrowse-file-for-directory directory))
+ (BFL (concat BF "-load.el"))
+ (BFLB (concat BF "-load.el~")))
+ (save-window-excursion
+ (with-output-to-temp-buffer "*FILES TO DELETE*"
+ (princ "The following BROWSE files are obsolete.\n\n")
+ (princ BF)
+ (princ "\n")
+ (princ BFL)
+ (princ "\n")
+ (when (file-exists-p BFLB)
+ (princ BFLB)
+ (princ "\n"))
+ )
+ (when (y-or-n-p (format
+ "Warning: Obsolete BROWSE file for: %s\nDelete? "
+ directory))
+ (delete-file BF)
+ (delete-file BFL)
+ (when (file-exists-p BFLB)
+ (delete-file BFLB))
+ )))))
+
+;;; SEMANTIC Database related Code
+;;; Classes:
+(defclass semanticdb-table-ebrowse (semanticdb-table)
+ ((major-mode :initform c++-mode)
+ (ebrowse-tree :initform nil
+ :initarg :ebrowse-tree
+ :documentation
+ "The raw ebrowse tree for this file."
+ )
+ (global-extract :initform nil
+ :initarg :global-extract
+ :documentation
+ "Table of ebrowse tags specific to this file.
+This table is compisited from the ebrowse *Globals* section.")
+ )
+ "A table for returning search results from ebrowse.")
+
+(defclass semanticdb-project-database-ebrowse
+ (semanticdb-project-database)
+ ((new-table-class :initform semanticdb-table-ebrowse
+ :type class
+ :documentation
+ "New tables created for this database are of this class.")
+ (system-include-p :initform nil
+ :initarg :system-include
+ :documentation
+ "Flag indicating this database represents a system include directory.")
+ (ebrowse-struct :initform nil
+ :initarg :ebrowse-struct
+ )
+ )
+ "Semantic Database deriving tags using the EBROWSE tool.
+EBROWSE is a C/C++ parser for use with `ebrowse' Emacs program.")
+
+;JAVE this just instantiates a default empty ebrowse struct?
+; how would new instances wind up here?
+; the ebrowse class isnt singleton, unlike the emacs lisp one
+(defvar-mode-local c++-mode semanticdb-project-system-databases
+ ()
+ "Search Ebrowse for symbols.")
+
+(defmethod semanticdb-needs-refresh-p ((table semanticdb-table-ebrowse))
+ "EBROWSE database do not need to be refreshed.
+
+JAVE: stub for needs-refresh, because, how do we know if BROWSE files
+ are out of date?
+
+EML: Our database should probably remember the timestamp/checksum of
+ the most recently read EBROWSE file, and use that."
+ nil
+)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+;;; EBROWSE code
+;;
+;; These routines deal with part of the ebrowse interface.
+(defun semanticdb-ebrowse-file-for-directory (dir)
+ "Return the file name for DIR where the ebrowse BROWSE file is.
+This file should reside in `semanticdb-default-save-directory'."
+ (let* ((semanticdb-default-save-directory
+ semanticdb-default-save-directory)
+ (B (semanticdb-file-name-directory
+ 'semanticdb-project-database-file
+ (concat (expand-file-name dir)
+ semanticdb-ebrowse-default-file-name)))
+ )
+ B))
+
+(defun semanticdb-ebrowse-get-ebrowse-structure (dir)
+ "Return the ebrowse structure for directory DIR.
+This assumes semantic manages the BROWSE files, so they are assumed to live
+where semantic cache files live, depending on your settings.
+
+For instance: /home/<username>/.semanticdb/!usr!include!BROWSE"
+ (let* ((B (semanticdb-ebrowse-file-for-directory dir))
+ (buf (get-buffer-create "*semanticdb ebrowse*")))
+ (message "semanticdb-ebrowse %s" B)
+ (when (file-exists-p B)
+ (set-buffer buf)
+ (buffer-disable-undo buf)
+ (erase-buffer)
+ (insert-file-contents B)
+ (let ((ans nil)
+ (efcn (symbol-function 'ebrowse-show-progress)))
+ (fset 'ebrowse-show-progress #'(lambda (&rest junk) nil))
+ (unwind-protect ;; Protect against errors w/ ebrowse
+ (setq ans (list B (ebrowse-read)))
+ ;; These items must always happen
+ (erase-buffer)
+ (fset 'ebrowse-show-fcn efcn)
+ )
+ ans))))
+
+;;; Methods for creating a database or tables
+;;
+(defmethod semanticdb-create-database :STATIC ((dbeC semanticdb-project-database-ebrowse)
+ directory)
+ "Create a new semantic database for DIRECTORY based on ebrowse.
+If there is no database for DIRECTORY available, then
+{not implemented yet} create one. Return nil if that is not possible."
+ ;; MAKE SURE THAT THE FILE LOADED DOESN'T ALREADY EXIST.
+ (let ((dbs semanticdb-database-list)
+ (found nil))
+ (while (and (not found) dbs)
+ (when (semanticdb-project-database-ebrowse-p (car dbs))
+ (when (string= (oref (car dbs) reference-directory) directory)
+ (setq found (car dbs))))
+ (setq dbs (cdr dbs)))
+ ;;STATIC means DBE cant be used as object, only as a class
+ (let* ((ebrowse-data (semanticdb-ebrowse-get-ebrowse-structure directory))
+ (dat (car (cdr ebrowse-data)))
+ (ebd (car dat))
+ (db nil)
+ (default-directory directory)
+ )
+ (if found
+ (setq db found)
+ (setq db (make-instance
+ dbeC
+ directory
+ :ebrowse-struct ebd
+ ))
+ (oset db reference-directory directory))
+
+ ;; Once we recycle or make a new DB, refresh the
+ ;; contents from the BROWSE file.
+ (oset db tables nil)
+ ;; only possible after object creation, tables inited to nil.
+ (semanticdb-ebrowse-strip-trees db dat)
+
+ ;; Once our database is loaded, if we are a system DB, we
+ ;; add ourselves to the include list for C++.
+ (semantic-add-system-include directory 'c++-mode)
+ (semantic-add-system-include directory 'c-mode)
+
+ db)))
+
+(defmethod semanticdb-ebrowse-strip-trees ((dbe semanticdb-project-database-ebrowse)
+ data)
+ "For the ebrowse database DBE, strip all tables from DATA."
+;JAVE what it actually seems to do is split the original tree in "tables" associated with files
+; im not sure it actually works:
+; the filename slot sometimes gets to be nil,
+; apparently for classes which definition cant be found, yet needs to be included in the tree
+; like library baseclasses
+; a file can define several classes
+ (let ((T (car (cdr data))));1st comes a header, then the tree
+ (while T
+
+ (let* ((tree (car T))
+ (class (ebrowse-ts-class tree)); root class of tree
+ ;; Something funny going on with this file thing...
+ (filename (or (ebrowse-cs-source-file class)
+ (ebrowse-cs-file class)))
+ )
+ (cond
+ ((ebrowse-globals-tree-p tree)
+ ;; We have the globals tree.. save this special.
+ (semanticdb-ebrowse-add-globals-to-table dbe tree)
+ )
+ (t
+ ;; ebrowse will collect all the info from multiple files
+ ;; into one tree. Semantic wants all the bits to be tied
+ ;; into different files. We need to do a full dissociation
+ ;; into semantic parsable tables.
+ (semanticdb-ebrowse-add-tree-to-table dbe tree)
+ ))
+ (setq T (cdr T))))
+ ))
+
+;;; Filename based methods
+;;
+(defun semanticdb-ebrowse-add-globals-to-table (dbe tree)
+ "For database DBE, add the ebrowse TREE into the table."
+ (if (or (not (ebrowse-ts-p tree))
+ (not (ebrowse-globals-tree-p tree)))
+ (signal 'wrong-type-argument (list 'ebrowse-ts-p tree)))
+
+ (let* ((class (ebrowse-ts-class tree))
+ (fname (or (ebrowse-cs-source-file class)
+ (ebrowse-cs-file class)
+ ;; Not def'd here, assume our current
+ ;; file
+ (concat default-directory "/unknown-proxy.hh")))
+ (vars (ebrowse-ts-member-functions tree))
+ (fns (ebrowse-ts-member-variables tree))
+ (toks nil)
+ )
+ (while vars
+ (let ((nt (semantic-tag (ebrowse-ms-name (car vars))
+ 'variable))
+ (defpoint (ebrowse-bs-point class)))
+ (when defpoint
+ (semantic--tag-set-overlay nt
+ (vector defpoint defpoint)))
+ (setq toks (cons nt toks)))
+ (setq vars (cdr vars)))
+ (while fns
+ (let ((nt (semantic-tag (ebrowse-ms-name (car fns))
+ 'function))
+ (defpoint (ebrowse-bs-point class)))
+ (when defpoint
+ (semantic--tag-set-overlay nt
+ (vector defpoint defpoint)))
+ (setq toks (cons nt toks)))
+ (setq fns (cdr fns)))
+
+ ))
+
+(defun semanticdb-ebrowse-add-tree-to-table (dbe tree &optional fname baseclasses)
+ "For database DBE, add the ebrowse TREE into the table for FNAME.
+Optional argument BASECLASSES specifyies a baseclass to the tree being provided."
+ (if (not (ebrowse-ts-p tree))
+ (signal 'wrong-type-argument (list 'ebrowse-ts-p tree)))
+
+ ;; Strategy overview:
+ ;; 1) Calculate the filename for this tree.
+ ;; 2) Find a matching namespace in TAB, or create a new one.
+ ;; 3) Fabricate a tag proxy for CLASS
+ ;; 4) Add it to the namespace
+ ;; 5) Add subclasses
+
+ ;; 1 - Find the filename
+ (if (not fname)
+ (setq fname (or (ebrowse-cs-source-file (ebrowse-ts-class tree))
+ (ebrowse-cs-file (ebrowse-ts-class tree))
+ ;; Not def'd here, assume our current
+ ;; file
+ (concat default-directory "/unknown-proxy.hh"))))
+
+ (let* ((tab (or (semanticdb-file-table dbe fname)
+ (semanticdb-create-table dbe fname)))
+ (class (ebrowse-ts-class tree))
+ (scope (ebrowse-cs-scope class))
+ (ns (when scope (cedet-split-string scope ":" t)))
+ (nst nil)
+ (cls nil)
+ )
+
+ ;; 2 - Get the namespace tag
+ (when ns
+ (let ((taglst (if (slot-boundp tab 'tags) (oref tab tags) nil)))
+ (setq nst (semantic-find-first-tag-by-name (car ns) taglst))
+ (when (not nst)
+ (setq nst (semantic-tag (car ns) 'type :type "namespace"))
+ (oset tab tags (cons nst taglst))
+ )))
+
+ ;; 3 - Create a proxy tg.
+ (setq cls (semantic-tag (ebrowse-cs-name class)
+ 'type
+ :type "class"
+ :superclasses baseclasses
+ :faux t
+ :filename fname
+ ))
+ (let ((defpoint (ebrowse-bs-point class)))
+ (when defpoint
+ (semantic--tag-set-overlay cls
+ (vector defpoint defpoint))))
+
+ ;; 4 - add to namespace
+ (if nst
+ (semantic-tag-put-attribute
+ nst :members (cons cls (semantic-tag-get-attribute nst :members)))
+ (oset tab tags (cons cls (when (slot-boundp tab 'tags)
+ (oref tab tags)))))
+
+ ;; 5 - Subclasses
+ (let* ((subclass (ebrowse-ts-subclasses tree))
+ (pname (ebrowse-cs-name class)))
+ (when (ebrowse-cs-scope class)
+ (setq pname (concat (mapconcat (lambda (a) a) (cdr ns) "::") "::" pname)))
+
+ (while subclass
+ (let* ((scc (ebrowse-ts-class (car subclass)))
+ (fname (or (ebrowse-cs-source-file scc)
+ (ebrowse-cs-file scc)
+ ;; Not def'd here, assume our current
+ ;; file
+ fname
+ )))
+ (when fname
+ (semanticdb-ebrowse-add-tree-to-table
+ dbe (car subclass) fname pname)))
+ (setq subclass (cdr subclass))))
+ ))
+
+;;;
+;; Overload for converting the simple faux tag into something better.
+;;
+(defmethod semanticdb-normalize-tags ((obj semanticdb-table-ebrowse) tags)
+ "Convert in Ebrowse database OBJ a list of TAGS into a complete tag.
+The default tag provided by searches exclude many features of a
+semantic parsed tag. Look up the file for OBJ, and match TAGS
+against a semantic parsed tag that has all the info needed, and
+return that."
+ (let ((tagret nil)
+ )
+ ;; SemanticDB will automatically create a regular database
+ ;; on top of the file just loaded by ebrowse during the set
+ ;; buffer. Fetch that table, and use it's tag list to look
+ ;; up the tag we just got, and thus turn it into a full semantic
+ ;; tag.
+ (while tags
+ (let ((tag (car tags)))
+ (save-excursion
+ (semanticdb-set-buffer obj)
+ (let ((ans nil))
+ ;; Gee, it would be nice to do this, but ebrowse LIES. Oi.
+ (when (semantic-tag-with-position-p tag)
+ (goto-char (semantic-tag-start tag))
+ (let ((foundtag (semantic-current-tag)))
+ ;; Make sure the discovered tag is the same as what we started with.
+ (when (string= (semantic-tag-name tag)
+ (semantic-tag-name foundtag))
+ ;; We have a winner!
+ (setq ans foundtag))))
+ ;; Sometimes ebrowse lies. Do a generic search
+ ;; to find it within this file.
+ (when (not ans)
+ ;; We might find multiple hits for this tag, and we have no way
+ ;; of knowing which one the user wanted. Return the first one.
+ (setq ans (semantic-deep-find-tags-by-name
+ (semantic-tag-name tag)
+ (semantic-fetch-tags))))
+ (if (semantic-tag-p ans)
+ (setq tagret (cons ans tagret))
+ (setq tagret (append ans tagret)))
+ ))
+ (setq tags (cdr tags))))
+ tagret))
+
+(defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-ebrowse) tag)
+ "Convert in Ebrowse database OBJ one TAG into a complete tag.
+The default tag provided by searches exclude many features of a
+semantic parsed tag. Look up the file for OBJ, and match TAG
+against a semantic parsed tag that has all the info needed, and
+return that."
+ (let ((tagret nil)
+ (objret nil))
+ ;; SemanticDB will automatically create a regular database
+ ;; on top of the file just loaded by ebrowse during the set
+ ;; buffer. Fetch that table, and use it's tag list to look
+ ;; up the tag we just got, and thus turn it into a full semantic
+ ;; tag.
+ (save-excursion
+ (semanticdb-set-buffer obj)
+ (setq objret semanticdb-current-table)
+ (when (not objret)
+ ;; What to do??
+ (debug))
+ (let ((ans nil))
+ ;; Gee, it would be nice to do this, but ebrowse LIES. Oi.
+ (when (semantic-tag-with-position-p tag)
+ (goto-char (semantic-tag-start tag))
+ (let ((foundtag (semantic-current-tag)))
+ ;; Make sure the discovered tag is the same as what we started with.
+ (when (string= (semantic-tag-name tag)
+ (semantic-tag-name foundtag))
+ ;; We have a winner!
+ (setq ans foundtag))))
+ ;; Sometimes ebrowse lies. Do a generic search
+ ;; to find it within this file.
+ (when (not ans)
+ ;; We might find multiple hits for this tag, and we have no way
+ ;; of knowing which one the user wanted. Return the first one.
+ (setq ans (semantic-deep-find-tags-by-name
+ (semantic-tag-name tag)
+ (semantic-fetch-tags))))
+ (if (semantic-tag-p ans)
+ (setq tagret ans)
+ (setq tagret (car ans)))
+ ))
+ (cons objret tagret)))
+
+;;; Search Overrides
+;;
+;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining
+;; how your new search routines are implemented.
+;;
+(defmethod semanticdb-find-tags-by-name-method
+ ((table semanticdb-table-ebrowse) name &optional tags)
+ "Find all tags named NAME in TABLE.
+Return a list of tags."
+ ;;(message "semanticdb-find-tags-by-name-method name -- %s" name)
+ (if tags
+ ;; If TAGS are passed in, then we don't need to do work here.
+ (call-next-method)
+ ;; If we ever need to do something special, add here.
+ ;; Since ebrowse tags are converted into semantic tags, we can
+ ;; get away with this sort of thing.
+ (call-next-method)
+ )
+ )
+
+(defmethod semanticdb-find-tags-by-name-regexp-method
+ ((table semanticdb-table-ebrowse) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (call-next-method)
+ ))
+
+(defmethod semanticdb-find-tags-for-completion-method
+ ((table semanticdb-table-ebrowse) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (call-next-method)
+ ))
+
+(defmethod semanticdb-find-tags-by-class-method
+ ((table semanticdb-table-ebrowse) class &optional tags)
+ "In TABLE, find all occurances of tags of CLASS.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ (call-next-method)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Deep Searches
+;;
+;; If your language does not have a `deep' concept, these can be left
+;; alone, otherwise replace with implementations similar to those
+;; above.
+;;
+
+(defmethod semanticdb-deep-find-tags-by-name-method
+ ((table semanticdb-table-ebrowse) name &optional tags)
+ "Find all tags name NAME in TABLE.
+Optional argument TAGS is a list of tags t
+Like `semanticdb-find-tags-by-name-method' for ebrowse."
+ ;;(semanticdb-find-tags-by-name-method table name tags)
+ (call-next-method))
+
+(defmethod semanticdb-deep-find-tags-by-name-regexp-method
+ ((table semanticdb-table-ebrowse) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-by-name-method' for ebrowse."
+ ;;(semanticdb-find-tags-by-name-regexp-method table regex tags)
+ (call-next-method))
+
+(defmethod semanticdb-deep-find-tags-for-completion-method
+ ((table semanticdb-table-ebrowse) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-for-completion-method' for ebrowse."
+ ;;(semanticdb-find-tags-for-completion-method table prefix tags)
+ (call-next-method))
+
+;;; Advanced Searches
+;;
+(defmethod semanticdb-find-tags-external-children-of-type-method
+ ((table semanticdb-table-ebrowse) type &optional tags)
+ "Find all nonterminals which are child elements of TYPE
+Optional argument TAGS is a list of tags to search.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; Ebrowse collects all this type of stuff together for us.
+ ;; but we can't use it.... yet.
+ nil
+ ))
+
+;;; TESTING
+;;
+;; This is a complex bit of stuff. Here are some tests for the
+;; system.
+
+(defun semanticdb-ebrowse-run-tests ()
+ "Run some tests of the semanticdb-ebrowse system.
+All systems are different. Ask questions along the way."
+ (interactive)
+ (let ((doload nil))
+ (when (y-or-n-p "Create a system database to test with? ")
+ (call-interactively 'semanticdb-create-ebrowse-database)
+ (setq doload t))
+ ;; Should we load in caches
+ (when (if doload
+ (y-or-n-p "New database created. Reload system databases? ")
+ (y-or-n-p "Load in all system databases? "))
+ (semanticdb-load-ebrowse-caches)))
+ ;; Ok, databases were creatd. Lets try some searching.
+ (when (not (or (eq major-mode 'c-mode)
+ (eq major-mode 'c++-mode)))
+ (error "Please make your default buffer be a C or C++ file, then
+run the test again..")
+ )
+
+ )
+
+(defun semanticdb-ebrowse-dump ()
+ "Find the first loaded ebrowse table, and dump out the contents."
+ (interactive)
+ (let ((db semanticdb-database-list)
+ (ab nil))
+ (while db
+ (when (semanticdb-project-database-ebrowse-p (car db))
+ (setq ab (data-debug-new-buffer "*EBROWSE Database*"))
+ (data-debug-insert-thing (car db) "*" "")
+ (setq db nil)
+ )
+ (setq db (cdr db)))))
+
+(provide 'semantic/db-ebrowse)
+
+;;; semanticdb-ebrowse.el ends here
--- /dev/null
+;;; db-el.el --- Semantic database extensions for Emacs Lisp
+
+;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Keywords: tags
+
+;; 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:
+;;
+;; There are a lot of Emacs Lisp functions and variables available for
+;; the asking. This adds on to the semanticdb programming interface to
+;; allow all loaded Emacs Lisp functions to be queried via semanticdb.
+;;
+;; This allows you to use programs written for Semantic using the database
+;; to also work in Emacs Lisp with no compromises.
+;;
+
+(require 'semantic/db-search)
+(eval-when-compile
+ ;; For generic function searching.
+ (require 'eieio)
+ (require 'eieio-opt)
+ (require 'eieio-base)
+ )
+;;; Code:
+
+;;; Classes:
+(defclass semanticdb-table-emacs-lisp (semanticdb-abstract-table)
+ ((major-mode :initform emacs-lisp-mode)
+ )
+ "A table for returning search results from Emacs.")
+
+(defmethod semanticdb-refresh-table ((obj semanticdb-table-emacs-lisp) &optional force)
+ "Do not refresh Emacs Lisp table.
+It does not need refreshing."
+ nil)
+
+(defmethod semanticdb-needs-refresh-p ((obj semanticdb-table-emacs-lisp))
+ "Return nil, we never need a refresh."
+ nil)
+
+(defclass semanticdb-project-database-emacs-lisp
+ (semanticdb-project-database eieio-singleton)
+ ((new-table-class :initform semanticdb-table-emacs-lisp
+ :type class
+ :documentation
+ "New tables created for this database are of this class.")
+ )
+ "Database representing Emacs core.")
+
+;; Create the database, and add it to searchable databases for Emacs Lisp mode.
+(defvar-mode-local emacs-lisp-mode semanticdb-project-system-databases
+ (list
+ (semanticdb-project-database-emacs-lisp "Emacs"))
+ "Search Emacs core for symbols.")
+
+(defvar-mode-local emacs-lisp-mode semanticdb-find-default-throttle
+ '(project omniscience)
+ "Search project files, then search this omniscience database.
+It is not necessary to to system or recursive searching because of
+the omniscience database.")
+
+;;; Filename based methods
+;;
+(defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-emacs-lisp))
+ "For an Emacs Lisp database, there are no explicit tables.
+Create one of our special tables that can act as an intermediary."
+ ;; We need to return something since there is always the "master table"
+ ;; The table can then answer file name type questions.
+ (when (not (slot-boundp obj 'tables))
+ (let ((newtable (semanticdb-table-emacs-lisp "Emacs System Table")))
+ (oset obj tables (list newtable))
+ (oset newtable parent-db obj)
+ (oset newtable tags nil)
+ ))
+ (call-next-method))
+
+(defmethod semanticdb-file-table ((obj semanticdb-project-database-emacs-lisp) filename)
+ "From OBJ, return FILENAME's associated table object.
+For Emacs Lisp, creates a specialized table."
+ (car (semanticdb-get-database-tables obj))
+ )
+
+(defmethod semanticdb-get-tags ((table semanticdb-table-emacs-lisp ))
+ "Return the list of tags belonging to TABLE."
+ ;; specialty table ? Probably derive tags at request time.
+ nil)
+
+(defmethod semanticdb-equivalent-mode ((table semanticdb-table-emacs-lisp) &optional buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+Equivalent modes are specified by by `semantic-equivalent-major-modes'
+local variable."
+ (save-excursion
+ (set-buffer buffer)
+ (eq (or mode-local-active-mode major-mode) 'emacs-lisp-mode)))
+
+(defmethod semanticdb-full-filename ((obj semanticdb-table-emacs-lisp))
+ "Fetch the full filename that OBJ refers to.
+For Emacs Lisp system DB, there isn't one."
+ nil)
+
+;;; Conversion
+;;
+(defmethod semanticdb-normalize-tags ((obj semanticdb-table-emacs-lisp) tags)
+ "Convert tags, originating from Emacs OBJ, into standardized form."
+ (let ((newtags nil))
+ (dolist (T tags)
+ (let* ((ot (semanticdb-normalize-one-tag obj T))
+ (tag (cdr ot)))
+ (setq newtags (cons tag newtags))))
+ ;; There is no promise to have files associated.
+ (nreverse newtags)))
+
+(defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-emacs-lisp) tag)
+ "Convert one TAG, originating from Emacs OBJ, into standardized form.
+If Emacs cannot resolve this symbol to a particular file, then return nil."
+ ;; Here's the idea. For each tag, get the name, then use
+ ;; Emacs' `symbol-file' to get the source. Once we have that,
+ ;; we can use more typical semantic searching techniques to
+ ;; get a regularly parsed tag.
+ (let* ((type (cond ((semantic-tag-of-class-p tag 'function)
+ 'defun)
+ ((semantic-tag-of-class-p tag 'variable)
+ 'defvar)
+ ))
+ (sym (intern (semantic-tag-name tag)))
+ (file (condition-case err
+ (symbol-file sym type)
+ ;; Older [X]Emacs don't have a 2nd argument.
+ (error (symbol-file sym))))
+ )
+ (if (or (not file) (not (file-exists-p file)))
+ ;; The file didn't exist. Return nil.
+ ;; We can't normalize this tag. Fake it out.
+ (cons obj tag)
+ (when (string-match "\\.elc" file)
+ (setq file (concat (file-name-sans-extension file)
+ ".el"))
+ (when (and (not (file-exists-p file))
+ (file-exists-p (concat file ".gz")))
+ ;; Is it a .gz file?
+ (setq file (concat file ".gz"))))
+
+ (let* ((tab (semanticdb-file-table-object file))
+ (alltags (semanticdb-get-tags tab))
+ (newtags (semanticdb-find-tags-by-name-method
+ tab (semantic-tag-name tag)))
+ (match nil))
+ ;; Find the best match.
+ (dolist (T newtags)
+ (when (semantic-tag-similar-p T tag)
+ (setq match T)))
+ ;; Backup system.
+ (when (not match)
+ (setq match (car newtags)))
+ ;; Return it.
+ (cons tab match)))))
+
+(defun semanticdb-elisp-sym-function-arglist (sym)
+ "Get the argument list for SYM.
+Deal with all different forms of function.
+This was snarfed out of eldoc."
+ (let* ((prelim-def
+ (let ((sd (and (fboundp sym)
+ (symbol-function sym))))
+ (and (symbolp sd)
+ (condition-case err
+ (setq sd (indirect-function sym))
+ (error (setq sd nil))))
+ sd))
+ (def (if (eq (car-safe prelim-def) 'macro)
+ (cdr prelim-def)
+ prelim-def))
+ (arglist (cond ((null def) nil)
+ ((byte-code-function-p def)
+ ;; This is an eieio compatibility function.
+ ;; We depend on EIEIO, so use this.
+ (eieio-compiled-function-arglist def))
+ ((eq (car-safe def) 'lambda)
+ (nth 1 def))
+ (t nil))))
+ arglist))
+
+(defun semanticdb-elisp-sym->tag (sym &optional toktype)
+ "Convert SYM into a semantic tag.
+TOKTYPE is a hint to the type of tag desired."
+ (if (stringp sym)
+ (setq sym (intern-soft sym)))
+ (when sym
+ (cond ((and (eq toktype 'function) (fboundp sym))
+ (semantic-tag-new-function
+ (symbol-name sym)
+ nil ;; return type
+ (semantic-elisp-desymbolify
+ (semanticdb-elisp-sym-function-arglist sym)) ;; arg-list
+ :user-visible-flag (condition-case nil
+ (interactive-form sym)
+ (error nil))
+ ))
+ ((and (eq toktype 'variable) (boundp sym))
+ (semantic-tag-new-variable
+ (symbol-name sym)
+ nil ;; type
+ nil ;; value - ignore for now
+ ))
+ ((and (eq toktype 'type) (class-p sym))
+ (semantic-tag-new-type
+ (symbol-name sym)
+ "class"
+ (semantic-elisp-desymbolify
+ (aref (class-v semanticdb-project-database)
+ class-public-a)) ;; slots
+ (semantic-elisp-desymbolify (class-parents sym)) ;; parents
+ ))
+ ((not toktype)
+ ;; Figure it out on our own.
+ (cond ((class-p sym)
+ (semanticdb-elisp-sym->tag sym 'type))
+ ((fboundp sym)
+ (semanticdb-elisp-sym->tag sym 'function))
+ ((boundp sym)
+ (semanticdb-elisp-sym->tag sym 'variable))
+ (t nil))
+ )
+ (t nil))))
+
+;;; Search Overrides
+;;
+(defvar semanticdb-elisp-mapatom-collector nil
+ "Variable used to collect mapatoms output.")
+
+(defmethod semanticdb-find-tags-by-name-method
+ ((table semanticdb-table-emacs-lisp) name &optional tags)
+ "Find all tags name NAME in TABLE.
+Uses `inter-soft' to match NAME to emacs symbols.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; No need to search. Use `intern-soft' which does the same thing for us.
+ (let* ((sym (intern-soft name))
+ (fun (semanticdb-elisp-sym->tag sym 'function))
+ (var (semanticdb-elisp-sym->tag sym 'variable))
+ (typ (semanticdb-elisp-sym->tag sym 'type))
+ (taglst nil)
+ )
+ (when (or fun var typ)
+ ;; If the symbol is any of these things, build the search table.
+ (when var (setq taglst (cons var taglst)))
+ (when typ (setq taglst (cons typ taglst)))
+ (when fun (setq taglst (cons fun taglst)))
+ taglst
+ ))))
+
+(defmethod semanticdb-find-tags-by-name-regexp-method
+ ((table semanticdb-table-emacs-lisp) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Uses `apropos-internal' to find matches.
+Return a list of tags."
+ (if tags (call-next-method)
+ (delq nil (mapcar 'semanticdb-elisp-sym->tag
+ (apropos-internal regex)))))
+
+(defmethod semanticdb-find-tags-for-completion-method
+ ((table semanticdb-table-emacs-lisp) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ (delq nil (mapcar 'semanticdb-elisp-sym->tag
+ (all-completions prefix obarray)))))
+
+(defmethod semanticdb-find-tags-by-class-method
+ ((table semanticdb-table-emacs-lisp) class &optional tags)
+ "In TABLE, find all occurances of tags of CLASS.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ ;; We could implement this, but it could be messy.
+ nil))
+
+;;; Deep Searches
+;;
+;; For Emacs Lisp deep searches are like top level searches.
+(defmethod semanticdb-deep-find-tags-by-name-method
+ ((table semanticdb-table-emacs-lisp) name &optional tags)
+ "Find all tags name NAME in TABLE.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-by-name-method' for Emacs Lisp."
+ (semanticdb-find-tags-by-name-method table name tags))
+
+(defmethod semanticdb-deep-find-tags-by-name-regexp-method
+ ((table semanticdb-table-emacs-lisp) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-by-name-method' for Emacs Lisp."
+ (semanticdb-find-tags-by-name-regexp-method table regex tags))
+
+(defmethod semanticdb-deep-find-tags-for-completion-method
+ ((table semanticdb-table-emacs-lisp) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-for-completion-method' for Emacs Lisp."
+ (semanticdb-find-tags-for-completion-method table prefix tags))
+
+;;; Advanced Searches
+;;
+(defmethod semanticdb-find-tags-external-children-of-type-method
+ ((table semanticdb-table-emacs-lisp) type &optional tags)
+ "Find all nonterminals which are child elements of TYPE
+Optional argument TAGS is a list of tags to search.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; EIEIO is the only time this matters
+ (when (featurep 'eieio)
+ (let* ((class (intern-soft type))
+ (taglst (when class
+ (delq nil
+ (mapcar 'semanticdb-elisp-sym->tag
+ ;; Fancy eieio function that knows all about
+ ;; built in methods belonging to CLASS.
+ (eieio-all-generic-functions class)))))
+ )
+ taglst))))
+
+(provide 'semantic/db-el)
+
+;;; semanticdb-el.el ends here
--- /dev/null
+;;; db-file.el --- Save a semanticdb to a cache file.
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Keywords: tags
+
+;; 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:
+;;
+;; A set of semanticdb classes for persistently saving caches on disk.
+;;
+
+(require 'semantic)
+(require 'semantic/db)
+(require 'cedet-files)
+
+(defvar semanticdb-file-version semantic-version
+ "Version of semanticdb we are writing files to disk with.")
+(defvar semanticdb-file-incompatible-version "1.4"
+ "Version of semanticdb we are not reverse compatible with.")
+
+;;; Settings
+;;
+(defcustom semanticdb-default-file-name "semantic.cache"
+ "*File name of the semantic tag cache."
+ :group 'semanticdb
+ :type 'string)
+
+(defcustom semanticdb-default-save-directory (expand-file-name "~/.semanticdb")
+ "*Directory name where semantic cache files are stored.
+If this value is nil, files are saved in the current directory. If the value
+is a valid directory, then it overrides `semanticdb-default-file-name' and
+stores caches in a coded file name in this directory."
+ :group 'semanticdb
+ :type '(choice :tag "Default-Directory"
+ :menu-tag "Default-Directory"
+ (const :tag "Use current directory" :value nil)
+ (directory)))
+
+(defcustom semanticdb-persistent-path '(always)
+ "*List of valid paths that semanticdb will cache tags to.
+When `global-semanticdb-minor-mode' is active, tag lists will
+be saved to disk when Emacs exits. Not all directories will have
+tags that should be saved.
+The value should be a list of valid paths. A path can be a string,
+indicating a directory in which to save a variable. An element in the
+list can also be a symbol. Valid symbols are `never', which will
+disable any saving anywhere, `always', which enables saving
+everywhere, or `project', which enables saving in any directory that
+passes a list of predicates in `semanticdb-project-predicate-functions'."
+ :group 'semanticdb
+ :type nil)
+
+(defcustom semanticdb-save-database-hooks nil
+ "*Hooks run after a database is saved.
+Each function is called with one argument, the object representing
+the database recently written."
+ :group 'semanticdb
+ :type 'hook)
+
+(defvar semanticdb-dir-sep-char (if (boundp 'directory-sep-char)
+ (symbol-value 'directory-sep-char)
+ ?/)
+ "Character used for directory separation.
+Obsoleted in some versions of Emacs. Needed in others.
+NOTE: This should get deleted from semantic soon.")
+
+(defun semanticdb-fix-pathname (dir)
+ "If DIR is broken, fix it.
+Force DIR to end with a /.
+Note: Same as `file-name-as-directory'.
+NOTE: This should get deleted from semantic soon."
+ (file-name-as-directory dir))
+;; I didn't initially know about the above fcn. Keep the below as a
+;; reference. Delete it someday once I've proven everything is the same.
+;; (if (not (= semanticdb-dir-sep-char (aref path (1- (length path)))))
+;; (concat path (list semanticdb-dir-sep-char))
+;; path))
+
+;;; Classes
+;;
+(defclass semanticdb-project-database-file (semanticdb-project-database
+ eieio-persistent)
+ ((file-header-line :initform ";; SEMANTICDB Tags save file")
+ (do-backups :initform nil)
+ (semantic-tag-version :initarg :semantic-tag-version
+ :initform "1.4"
+ :documentation
+ "The version of the tags saved.
+The default value is 1.4. In semantic 1.4 there was no versioning, so
+when those files are loaded, this becomes the version number.
+To save the version number, we must hand-set this version string.")
+ (semanticdb-version :initarg :semanticdb-version
+ :initform "1.4"
+ :documentation
+ "The version of the object system saved.
+The default value is 1.4. In semantic 1.4, there was no versioning,
+so when those files are loaded, this becomes the version number.
+To save the version number, we must hand-set this version string.")
+ )
+ "Database of file tables saved to disk.")
+
+;;; Code:
+;;
+(defmethod semanticdb-create-database :STATIC ((dbc semanticdb-project-database-file)
+ directory)
+ "Create a new semantic database for DIRECTORY and return it.
+If a database for DIRECTORY has already been loaded, return it.
+If a database for DIRECTORY exists, then load that database, and return it.
+If DIRECTORY doesn't exist, create a new one."
+ ;; Make sure this is fully expanded so we don't get duplicates.
+ (setq directory (file-truename directory))
+ (let* ((fn (semanticdb-cache-filename dbc directory))
+ (db (or (semanticdb-file-loaded-p fn)
+ (if (file-exists-p fn)
+ (progn
+ (semanticdb-load-database fn))))))
+ (unless db
+ (setq db (make-instance
+ dbc ; Create the database requested. Perhaps
+ (concat (file-name-nondirectory
+ (directory-file-name
+ directory))
+ "/")
+ :file fn :tables nil
+ :semantic-tag-version semantic-version
+ :semanticdb-version semanticdb-file-version)))
+ ;; Set this up here. We can't put it in the constructor because it
+ ;; would be saved, and we want DB files to be portable.
+ (oset db reference-directory directory)
+ db))
+
+;;; File IO
+(defun semanticdb-load-database (filename)
+ "Load the database FILENAME."
+ (require 'inversion)
+ (condition-case foo
+ (let* ((r (eieio-persistent-read filename))
+ (c (semanticdb-get-database-tables r))
+ (tv (oref r semantic-tag-version))
+ (fv (oref r semanticdb-version))
+ )
+ ;; Restore the parent-db connection
+ (while c
+ (oset (car c) parent-db r)
+ (setq c (cdr c)))
+ (if (not (inversion-test 'semanticdb-file fv))
+ (when (inversion-test 'semantic-tag tv)
+ ;; Incompatible version. Flush tables.
+ (semanticdb-flush-database-tables r)
+ ;; Reset the version to new version.
+ (oset r semantic-tag-version semantic-tag-version)
+ ;; Warn user
+ (message "Semanticdb file is old. Starting over for %s"
+ filename)
+ )
+ ;; Version is not ok. Flush whole system
+ (message "semanticdb file is old. Starting over for %s"
+ filename)
+ ;; This database is so old, we need to replace it.
+ ;; We also need to delete it from the instance tracker.
+ (delete-instance r)
+ (setq r nil))
+ r)
+ (error (message "Cache Error: [%s] %s, Restart"
+ filename foo)
+ nil)))
+
+(defun semanticdb-file-loaded-p (filename)
+ "Return the project belonging to FILENAME if it was already loaded."
+ (eieio-instance-tracker-find filename 'file 'semanticdb-database-list))
+
+(defmethod semanticdb-file-directory-exists-p ((DB semanticdb-project-database-file)
+ &optional supress-questions)
+ "Does the directory the database DB needs to write to exist?
+If SUPRESS-QUESTIONS, then do not ask to create the directory."
+ (let ((dest (file-name-directory (oref DB file)))
+ )
+ (cond ((null dest)
+ ;; @TODO - If it was never set up... what should we do ?
+ nil)
+ ((file-exists-p dest) t)
+ (supress-questions nil)
+ ((y-or-n-p (format "Create directory %s for SemanticDB? "
+ dest))
+ (make-directory dest t)
+ t)
+ (t nil))
+ ))
+
+(defmethod semanticdb-save-db ((DB semanticdb-project-database-file)
+ &optional
+ supress-questions)
+ "Write out the database DB to its file.
+If DB is not specified, then use the current database."
+ (let ((objname (oref DB file)))
+ (when (and (semanticdb-dirty-p DB)
+ (semanticdb-live-p DB)
+ (semanticdb-file-directory-exists-p DB supress-questions)
+ (semanticdb-write-directory-p DB)
+ )
+ ;;(message "Saving tag summary for %s..." objname)
+ (condition-case foo
+ (eieio-persistent-save (or DB semanticdb-current-database))
+ (file-error ; System error saving? Ignore it.
+ (message "%S: %s" foo objname))
+ (error
+ (cond
+ ((and (listp foo)
+ (stringp (nth 1 foo))
+ (string-match "write[- ]protected" (nth 1 foo)))
+ (message (nth 1 foo)))
+ ((and (listp foo)
+ (stringp (nth 1 foo))
+ (string-match "no such directory" (nth 1 foo)))
+ (message (nth 1 foo)))
+ (t
+ ;; @todo - It should ask if we are not called from a hook.
+ ;; How?
+ (if (or supress-questions
+ (y-or-n-p (format "Skip Error: %S ?" (car (cdr foo)))))
+ (message "Save Error: %S: %s" (car (cdr foo))
+ objname)
+ (error "%S" (car (cdr foo))))))))
+ (run-hook-with-args 'semanticdb-save-database-hooks
+ (or DB semanticdb-current-database))
+ ;;(message "Saving tag summary for %s...done" objname)
+ )
+ ))
+
+(defmethod semanticdb-live-p ((obj semanticdb-project-database))
+ "Return non-nil if the file associated with OBJ is live.
+Live databases are objects associated with existing directories."
+ (and (slot-boundp obj 'reference-directory)
+ (file-exists-p (oref obj reference-directory))))
+
+(defmethod semanticdb-live-p ((obj semanticdb-table))
+ "Return non-nil if the file associated with OBJ is live.
+Live files are either buffers in Emacs, or files existing on the filesystem."
+ (let ((full-filename (semanticdb-full-filename obj)))
+ (or (find-buffer-visiting full-filename)
+ (file-exists-p full-filename))))
+
+(defvar semanticdb-data-debug-on-write-error nil
+ "Run the data debugger on tables that issue errors.
+This variable is set to nil after the first error is encountered
+to prevent overload.")
+
+(defmethod object-write ((obj semanticdb-table))
+ "When writing a table, we have to make sure we deoverlay it first.
+Restore the overlays after writting.
+Argument OBJ is the object to write."
+ (when (semanticdb-live-p obj)
+ (when (semanticdb-in-buffer-p obj)
+ (save-excursion
+ (set-buffer (semanticdb-in-buffer-p obj))
+
+ ;; Make sure all our tag lists are up to date.
+ (semantic-fetch-tags)
+
+ ;; Try to get an accurate unmatched syntax table.
+ (when (and (boundp semantic-show-unmatched-syntax-mode)
+ semantic-show-unmatched-syntax-mode)
+ ;; Only do this if the user runs unmatched syntax
+ ;; mode display enties.
+ (oset obj unmatched-syntax
+ (semantic-show-unmatched-lex-tokens-fetch))
+ )
+
+ ;; Make sure pointmax is up to date
+ (oset obj pointmax (point-max))
+ ))
+
+ ;; Make sure that the file size and other attributes are
+ ;; up to date.
+ (let ((fattr (file-attributes (semanticdb-full-filename obj))))
+ (oset obj fsize (nth 7 fattr))
+ (oset obj lastmodtime (nth 5 fattr))
+ )
+
+ ;; Do it!
+ (condition-case tableerror
+ (call-next-method)
+ (error
+ (when semanticdb-data-debug-on-write-error
+ (require 'data-debug)
+ (data-debug-new-buffer (concat "*SEMANTICDB ERROR*"))
+ (data-debug-insert-thing obj "*" "")
+ (setq semanticdb-data-debug-on-write-error nil))
+ (message "Error Writing Table: %s" (object-name obj))
+ (error "%S" (car (cdr tableerror)))))
+
+ ;; Clear the dirty bit.
+ (oset obj dirty nil)
+ ))
+
+;;; State queries
+;;
+(defmethod semanticdb-write-directory-p ((obj semanticdb-project-database-file))
+ "Return non-nil if OBJ should be written to disk.
+Uses `semanticdb-persistent-path' to determine the return value."
+ (let ((path semanticdb-persistent-path))
+ (catch 'found
+ (while path
+ (cond ((stringp (car path))
+ (if (string= (oref obj reference-directory) (car path))
+ (throw 'found t)))
+ ((eq (car path) 'project)
+ ;; @TODO - EDE causes us to go in here and disable
+ ;; the old default 'always save' setting.
+ ;;
+ ;; With new default 'always' should I care?
+ (if semanticdb-project-predicate-functions
+ (if (run-hook-with-args-until-success
+ 'semanticdb-project-predicate-functions
+ (oref obj reference-directory))
+ (throw 'found t))
+ ;; If the mode is 'project, and there are no project
+ ;; modes, then just always save the file. If users
+ ;; wish to restrict the search, modify
+ ;; `semanticdb-persistent-path' to include desired paths.
+ (if (= (length semanticdb-persistent-path) 1)
+ (throw 'found t))
+ ))
+ ((eq (car path) 'never)
+ (throw 'found nil))
+ ((eq (car path) 'always)
+ (throw 'found t))
+ (t (error "Invalid path %S" (car path))))
+ (setq path (cdr path)))
+ (call-next-method))
+ ))
+
+;;; Filename manipulation
+;;
+(defmethod semanticdb-file-table ((obj semanticdb-project-database-file) filename)
+ "From OBJ, return FILENAME's associated table object."
+ ;; Cheater option. In this case, we always have files directly
+ ;; under ourselves. The main project type may not.
+ (object-assoc (file-name-nondirectory filename) 'file (oref obj tables)))
+
+(defmethod semanticdb-file-name-non-directory :STATIC
+ ((dbclass semanticdb-project-database-file))
+ "Return the file name DBCLASS will use.
+File name excludes any directory part."
+ semanticdb-default-file-name)
+
+(defmethod semanticdb-file-name-directory :STATIC
+ ((dbclass semanticdb-project-database-file) directory)
+ "Return the relative directory to where DBCLASS will save its cache file.
+The returned path is related to DIRECTORY."
+ (if semanticdb-default-save-directory
+ (let ((file (cedet-directory-name-to-file-name directory)))
+ ;; Now create a filename for the cache file in
+ ;; ;`semanticdb-default-save-directory'.
+ (expand-file-name
+ file (file-name-as-directory semanticdb-default-save-directory)))
+ directory))
+
+(defmethod semanticdb-cache-filename :STATIC
+ ((dbclass semanticdb-project-database-file) path)
+ "For DBCLASS, return a file to a cache file belonging to PATH.
+This could be a cache file in the current directory, or an encoded file
+name in a secondary directory."
+ ;; Use concat and not expand-file-name, because the dir part
+ ;; may include some of the file name.
+ (concat (semanticdb-file-name-directory dbclass path)
+ (semanticdb-file-name-non-directory dbclass)))
+
+(defmethod semanticdb-full-filename ((obj semanticdb-project-database-file))
+ "Fetch the full filename that OBJ refers to."
+ (oref obj file))
+
+;;; FLUSH OLD FILES
+;;
+(defun semanticdb-cleanup-cache-files (&optional noerror)
+ "Cleanup any cache files associated with directories that no longer exist.
+Optional NOERROR prevents errors from being displayed."
+ (interactive)
+ (when (and (not semanticdb-default-save-directory)
+ (not noerror))
+ (error "No default save directory for semantic-save files"))
+
+ (when semanticdb-default-save-directory
+
+ ;; Calculate all the cache files we have.
+ (let* ((regexp (regexp-quote semanticdb-default-file-name))
+ (files (directory-files semanticdb-default-save-directory
+ t regexp))
+ (orig nil)
+ (to-delete nil))
+ (dolist (F files)
+ (setq orig (cedet-file-name-to-directory-name
+ (file-name-nondirectory F)))
+ (when (not (file-exists-p (file-name-directory orig)))
+ (setq to-delete (cons F to-delete))
+ ))
+ (if to-delete
+ (save-window-excursion
+ (let ((buff (get-buffer-create "*Semanticdb Delete*")))
+ (with-current-buffer buff
+ (erase-buffer)
+ (insert "The following Cache files appear to be obsolete.\n\n")
+ (dolist (F to-delete)
+ (insert F "\n")))
+ (pop-to-buffer buff t t)
+ (fit-window-to-buffer (get-buffer-window buff) nil 1)
+ (when (y-or-n-p "Delete Old Cache Files? ")
+ (mapc (lambda (F)
+ (message "Deleting to %s..." F)
+ (delete-file F))
+ to-delete)
+ (message "done."))
+ ))
+ ;; No files to delete
+ (when (not noerror)
+ (message "No obsolete semanticdb.cache files."))
+ ))))
+
+(provide 'semantic/db-file)
+
+;;; semanticdb-file.el ends here
--- /dev/null
+;;; db-javascript.el --- Semantic database extensions for javascript
+
+;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+;;; Free Software Foundation, Inc.
+
+;; Author: Joakim Verona
+
+;; 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:
+;;
+;; Semanticdb database for Javascript.
+;;
+;; This is an omniscient database with a hard-coded list of symbols for
+;; Javascript. See the doc at the end of this file for adding or modifying
+;; the list of tags.
+;;
+
+(require 'semantic/db-search)
+(eval-when-compile
+ ;; For generic function searching.
+ (require 'eieio)
+ (require 'eieio-opt)
+ )
+;;; Code:
+(defvar semanticdb-javascript-tags
+ '(("eval" function
+ (:arguments
+ (("x" variable nil nil nil)))
+ nil nil)
+ ("parseInt" function
+ (:arguments
+ (("string" variable nil nil nil)
+ ("radix" variable nil nil nil)))
+ nil nil)
+ ("parseFloat" function
+ (:arguments
+ (("string" variable nil nil nil)))
+ nil nil)
+ ("isNaN" function
+ (:arguments
+ (("number" variable nil nil nil)))
+ nil nil)
+ ("isFinite" function
+ (:arguments
+ (("number" variable nil nil nil)))
+ nil nil)
+ ("decodeURI" function
+ (:arguments
+ (("encodedURI" variable nil nil nil)))
+ nil nil)
+ ("decodeURIComponent" function
+ (:arguments
+ (("encodedURIComponent" variable nil nil nil)))
+ nil nil)
+ ("encodeURI" function
+ (:arguments
+ (("uri" variable nil nil nil)))
+ nil nil)
+ ("encodeURIComponent" function
+ (:arguments
+ (("uriComponent" variable nil nil nil)))
+ nil nil))
+ "Hard-coded list of javascript tags for semanticdb.
+See bottom of this file for instruction on managing this list.")
+
+;;; Classes:
+(defclass semanticdb-table-javascript (semanticdb-search-results-table)
+ ((major-mode :initform javascript-mode)
+ )
+ "A table for returning search results from javascript.")
+
+(defclass semanticdb-project-database-javascript
+ (semanticdb-project-database
+ eieio-singleton ;this db is for js globals, so singleton is apropriate
+ )
+ ((new-table-class :initform semanticdb-table-javascript
+ :type class
+ :documentation
+ "New tables created for this database are of this class.")
+ )
+ "Database representing javascript.")
+
+;; Create the database, and add it to searchable databases for javascript mode.
+(defvar-mode-local javascript-mode semanticdb-project-system-databases
+ (list
+ (semanticdb-project-database-javascript "Javascript"))
+ "Search javascript for symbols.")
+
+;; NOTE: Be sure to modify this to the best advantage of your
+;; language.
+(defvar-mode-local javascript-mode semanticdb-find-default-throttle
+ '(project omniscience)
+ "Search project files, then search this omniscience database.
+It is not necessary to to system or recursive searching because of
+the omniscience database.")
+
+;;; Filename based methods
+;;
+(defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-javascript))
+ "For a javascript database, there are no explicit tables.
+Create one of our special tables that can act as an intermediary."
+ ;; NOTE: This method overrides an accessor for the `tables' slot in
+ ;; a database. You can either construct your own (like tmp here
+ ;; or you can manage any number of tables.
+
+ ;; We need to return something since there is always the "master table"
+ ;; The table can then answer file name type questions.
+ (when (not (slot-boundp obj 'tables))
+ (let ((newtable (semanticdb-table-javascript "tmp")))
+ (oset obj tables (list newtable))
+ (oset newtable parent-db obj)
+ (oset newtable tags nil)
+ ))
+ (call-next-method)
+ )
+
+(defmethod semanticdb-file-table ((obj semanticdb-project-database-javascript) filename)
+ "From OBJ, return FILENAME's associated table object."
+ ;; NOTE: See not for `semanticdb-get-database-tables'.
+ (car (semanticdb-get-database-tables obj))
+ )
+
+(defmethod semanticdb-get-tags ((table semanticdb-table-javascript ))
+ "Return the list of tags belonging to TABLE."
+ ;; NOTE: Omniscient databases probably don't want to keep large tabes
+ ;; lolly-gagging about. Keep internal Emacs tables empty and
+ ;; refer to alternate databases when you need something.
+ semanticdb-javascript-tags)
+
+(defmethod semanticdb-equivalent-mode ((table semanticdb-table-javascript) &optional buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+Equivalent modes are specified by by `semantic-equivalent-major-modes'
+local variable."
+ (save-excursion
+ (set-buffer buffer)
+ (eq (or mode-local-active-mode major-mode) 'javascript-mode)))
+
+;;; Usage
+;;
+;; Unlike other tables, an omniscent database does not need to
+;; be associated with a path. Use this routine to always add ourselves
+;; to a search list.
+(define-mode-local-override semanticdb-find-translate-path javascript-mode
+ (path brutish)
+ "Return a list of semanticdb tables asociated with PATH.
+If brutish, do the default action.
+If not brutish, do the default action, and append the system
+database (if available.)"
+ (let ((default
+ ;; When we recurse, disable searching of system databases
+ ;; so that our Javascript database only shows up once when
+ ;; we append it in this iteration.
+ (let ((semanticdb-search-system-databases nil)
+ )
+ (semanticdb-find-translate-path-default path brutish))))
+ ;; Don't add anything if BRUTISH is on (it will be added in that fcn)
+ ;; or if we aren't supposed to search the system.
+ (if (or brutish (not semanticdb-search-system-databases))
+ default
+ (let ((tables (apply #'append
+ (mapcar
+ (lambda (db) (semanticdb-get-database-tables db))
+ semanticdb-project-system-databases))))
+ (append default tables)))))
+
+;;; Search Overrides
+;;
+;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining
+;; how your new search routines are implemented.
+;;
+(defun semanticdb-javascript-regexp-search (regexp)
+ "Search for REGEXP in our fixed list of javascript tags."
+ (let* ((tags semanticdb-javascript-tags)
+ (result nil))
+ (while tags
+ (if (string-match regexp (caar tags))
+ (setq result (cons (car tags) result)))
+ (setq tags (cdr tags)))
+ result))
+
+(defmethod semanticdb-find-tags-by-name-method
+ ((table semanticdb-table-javascript) name &optional tags)
+ "Find all tags named NAME in TABLE.
+Return a list of tags."
+ (if tags
+ ;; If TAGS are passed in, then we don't need to do work here.
+ (call-next-method)
+ (assoc-string name semanticdb-javascript-tags)
+ ))
+
+(defmethod semanticdb-find-tags-by-name-regexp-method
+ ((table semanticdb-table-javascript) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (semanticdb-javascript-regexp-search regex)
+
+ ))
+
+(defmethod semanticdb-find-tags-for-completion-method
+ ((table semanticdb-table-javascript) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (semanticdb-javascript-regexp-search (concat "^" prefix ".*"))
+ ))
+
+(defmethod semanticdb-find-tags-by-class-method
+ ((table semanticdb-table-javascript) class &optional tags)
+ "In TABLE, find all occurances of tags of CLASS.
+Optional argument TAGS is a list of tags to search.
+Returns a table of all matching tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ ;;
+ ;; Note: This search method could be considered optional in an
+ ;; omniscient database. It may be unwise to return all tags
+ ;; that exist for a language that are a variable or function.
+ ;;
+ ;; If it is optional, you can just delete this method.
+ nil))
+
+;;; Deep Searches
+;;
+;; If your language does not have a `deep' concept, these can be left
+;; alone, otherwise replace with implementations similar to those
+;; above.
+;;
+(defmethod semanticdb-deep-find-tags-by-name-method
+ ((table semanticdb-table-javascript) name &optional tags)
+ "Find all tags name NAME in TABLE.
+Optional argument TAGS is a list of tags t
+Like `semanticdb-find-tags-by-name-method' for javascript."
+ (semanticdb-find-tags-by-name-method table name tags))
+
+(defmethod semanticdb-deep-find-tags-by-name-regexp-method
+ ((table semanticdb-table-javascript) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-by-name-method' for javascript."
+ (semanticdb-find-tags-by-name-regexp-method table regex tags))
+
+(defmethod semanticdb-deep-find-tags-for-completion-method
+ ((table semanticdb-table-javascript) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+Optional argument TAGS is a list of tags to search.
+Like `semanticdb-find-tags-for-completion-method' for javascript."
+ (semanticdb-find-tags-for-completion-method table prefix tags))
+
+;;; Advanced Searches
+;;
+(defmethod semanticdb-find-tags-external-children-of-type-method
+ ((table semanticdb-table-javascript) type &optional tags)
+ "Find all nonterminals which are child elements of TYPE
+Optional argument TAGS is a list of tags to search.
+Return a list of tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ ;;
+ ;; OPTIONAL: This could be considered an optional function. It is
+ ;; used for `semantic-adopt-external-members' and may not
+ ;; be possible to do in your language.
+ ;;
+ ;; If it is optional, you can just delete this method.
+ ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun semanticdb-javascript-strip-tags (tags)
+ "Strip TAGS from overlays and reparse symbols."
+ (cond ((and (consp tags) (eq 'reparse-symbol (car tags)))
+ nil)
+ ((overlayp tags) nil)
+ ((atom tags) tags)
+ (t (cons (semanticdb-javascript-strip-tags
+ (car tags)) (semanticdb-javascript-strip-tags
+ (cdr tags))))))
+
+;this list was made from a javascript file, and the above function
+;; function eval(x){}
+;; function parseInt(string,radix){}
+;; function parseFloat(string){}
+;; function isNaN(number){}
+;; function isFinite(number){}
+;; function decodeURI(encodedURI){}
+;; function decodeURIComponent (encodedURIComponent){}
+;; function encodeURI (uri){}
+;; function encodeURIComponent (uriComponent){}
+
+
+(provide 'semantic/db-el)
+
+;;; semanticdb-el.el ends here
--- /dev/null
+;;; db-search.el --- Searching through semantic databases.
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 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:
+;;
+;; NOTE: THESE APIs ARE OBSOLETE:
+;;
+;; Databases of various forms can all be searched. These routines
+;; cover many common forms of searching.
+;;
+;; There are three types of searches that can be implemented:
+;;
+;; Basic Search:
+;; These searches allow searching on specific attributes of tags,
+;; such as name or type.
+;;
+;; Advanced Search:
+;; These are searches that were needed to accomplish some tasks
+;; during in utilities. Advanced searches include matching methods
+;; defined outside some parent class.
+;;
+;; The reason for advanced searches are so that external
+;; repositories such as the Emacs obarray, or java .class files can
+;; quickly answer these needed questions without dumping the entire
+;; symbol list into Emacs for a regular semanticdb search.
+;;
+;; Generic Search:
+;; The generic search, `semanticdb-find-nonterminal-by-function'
+;; accepts a Emacs Lisp predicate that tests tags in Semantic
+;; format. Most external searches cannot perform this search.
+
+(require 'semantic/db)
+(require 'semantic/find)
+
+;;; Code:
+;;
+;;; Classes:
+
+;; @TODO MOVE THIS CLASS?
+(defclass semanticdb-search-results-table (semanticdb-abstract-table)
+ (
+ )
+ "Table used for search results when there is no file or table association.
+Examples include search results from external sources such as from
+Emacs' own symbol table, or from external libraries.")
+
+(defmethod semanticdb-refresh-table ((obj semanticdb-search-results-table) &optional force)
+ "If the tag list associated with OBJ is loaded, refresh it.
+This will call `semantic-fetch-tags' if that file is in memory."
+ nil)
+
+;;; Utils
+;;
+;; Convenience routines for searches
+(defun semanticdb-collect-find-results (result-in-databases
+ result-finding-function
+ ignore-system
+ find-file-on-match)
+ "OBSOLETE:
+Collect results across RESULT-IN-DATABASES for RESULT-FINDING-FUNCTION.
+If RESULT-IN-DATABASES is nil, search a range of associated databases
+calculated by `semanticdb-current-database-list'.
+RESULT-IN-DATABASES is a list of variable `semanticdb-project-database'
+objects.
+RESULT-FINDING-FUNCTION should accept one argument, the database being searched.
+Argument IGNORE-SYSTEM specifies if any available system databases should
+be ignored, or searched.
+Argument FIND-FILE-ON-MATCH indicates that the found databases
+should be capable of doing so."
+ (if (not (listp result-in-databases))
+ (signal 'wrong-type-argument (list 'listp result-in-databases)))
+ (let* ((semanticdb-search-system-databases
+ (if ignore-system
+ nil
+ semanticdb-search-system-databases))
+ (dbs (or result-in-databases
+ ;; Calculate what database to use.
+ ;; Something simple and dumb for now.
+ (or (semanticdb-current-database-list)
+ (list (semanticdb-current-database)))))
+ (case-fold-search semantic-case-fold)
+ (res (mapcar
+ (lambda (db)
+ (if (or (not find-file-on-match)
+ (not (child-of-class-p
+ (oref db new-table-class)
+ semanticdb-search-results-table)))
+ (funcall result-finding-function db)))
+ dbs))
+ out)
+ ;; Flatten the list. The DB is unimportant at this stage.
+ (setq res (apply 'append res))
+ (setq out nil)
+ ;; Move across results, and throw out empties.
+ (while res
+ (if (car res)
+ (setq out (cons (car res) out)))
+ (setq res (cdr res)))
+ ;; Results
+ out))
+
+;;; Programatic interfaces
+;;
+;; These routines all perform different types of searches, and are
+;; interfaces to the database methods used to also perform those searches.
+
+(defun semanticdb-find-nonterminal-by-token
+ (token &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
+ "OBSOLETE:
+Find all occurances of nonterminals with token TOKEN in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES, DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-collect-find-results
+ databases
+ (lambda (db)
+ (semanticdb-find-nonterminal-by-token-method
+ db token search-parts search-includes diff-mode find-file-match))
+ ignore-system
+ find-file-match))
+(make-obsolete 'semanticdb-find-nonterminal-by-token
+ "Please don't use this function")
+
+(defun semanticdb-find-nonterminal-by-name
+ (name &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
+ "OBSOLETE:
+Find all occurances of nonterminals with name NAME in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES, DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
+Return a list ((DB-TABLE . TOKEN) ...)."
+ (semanticdb-collect-find-results
+ databases
+ (lambda (db)
+ (semanticdb-find-nonterminal-by-name-method
+ db name search-parts search-includes diff-mode find-file-match))
+ ignore-system
+ find-file-match))
+(make-obsolete 'semanticdb-find-nonterminal-by-name
+ "Please don't use this function")
+
+(defun semanticdb-find-nonterminal-by-name-regexp
+ (regex &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
+ "OBSOLETE:
+Find all occurances of nonterminals with name matching REGEX in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-collect-find-results
+ databases
+ (lambda (db)
+ (semanticdb-find-nonterminal-by-name-regexp-method
+ db regex search-parts search-includes diff-mode find-file-match))
+ ignore-system
+ find-file-match))
+(make-obsolete 'semanticdb-find-nonterminal-by-name-regexp
+ "Please don't use this function")
+
+
+(defun semanticdb-find-nonterminal-by-type
+ (type &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
+ "OBSOLETE:
+Find all nonterminals with a type of TYPE in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-collect-find-results
+ databases
+ (lambda (db)
+ (semanticdb-find-nonterminal-by-type-method
+ db type search-parts search-includes diff-mode find-file-match))
+ ignore-system
+ find-file-match))
+(make-obsolete 'semanticdb-find-nonterminal-by-type
+ "Please don't use this function")
+
+
+(defun semanticdb-find-nonterminal-by-property
+ (property value &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
+ "OBSOLETE:
+Find all nonterminals with a PROPERTY equal to VALUE in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-collect-find-results
+ databases
+ (lambda (db)
+ (semanticdb-find-nonterminal-by-property-method
+ db property value search-parts search-includes diff-mode find-file-match))
+ ignore-system
+ find-file-match))
+(make-obsolete 'semanticdb-find-nonterminal-by-property
+ "Please don't use this function")
+
+(defun semanticdb-find-nonterminal-by-extra-spec
+ (spec &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
+ "OBSOLETE:
+Find all nonterminals with a SPEC in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-collect-find-results
+ databases
+ (lambda (db)
+ (semanticdb-find-nonterminal-by-extra-spec-method
+ db spec search-parts search-includes diff-mode find-file-match))
+ ignore-system
+ find-file-match))
+(make-obsolete 'semanticdb-find-nonterminal-by-extra-spec
+ "Please don't use this function")
+
+(defun semanticdb-find-nonterminal-by-extra-spec-value
+ (spec value &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
+ "OBSOLETE:
+Find all nonterminals with a SPEC equal to VALUE in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-collect-find-results
+ databases
+ (lambda (db)
+ (semanticdb-find-nonterminal-by-extra-spec-value-method
+ db spec value search-parts search-includes diff-mode find-file-match))
+ ignore-system
+ find-file-match))
+(make-obsolete 'semanticdb-find-nonterminal-by-extra-spec-value
+ "Please don't use this function")
+
+;;; Advanced Search Routines
+;;
+(defun semanticdb-find-nonterminal-external-children-of-type
+ (type &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
+ "OBSOLETE:
+Find all nonterminals which are child elements of TYPE.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-collect-find-results
+ databases
+ (lambda (db)
+ (semanticdb-find-nonterminal-external-children-of-type-method
+ db type search-parts search-includes diff-mode find-file-match))
+ ignore-system
+ find-file-match))
+
+;;; Generic Search routine
+;;
+
+(defun semanticdb-find-nonterminal-by-function
+ (function &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
+ "OBSOLETE:
+Find all occurances of nonterminals which match FUNCTION.
+Search in all DATABASES. If DATABASES is nil, search a range of
+associated databases calculated `semanticdb-current-database-list' and
+DATABASES is a list of variable `semanticdb-project-database' objects.
+When SEARCH-PARTS is non-nil the search will include children of tags.
+When SEARCH-INCLUDES is non-nil, the search will include dependency files.
+When DIFF-MODE is non-nil, search databases which are of a different mode.
+A Mode is the `major-mode' that file was in when it was last parsed.
+When FIND-FILE-MATCH is non-nil, the make sure any found token's file is
+in an Emacs buffer.
+When IGNORE-SYSTEM is non-nil, system libraries are not searched.
+Return a list ((DB-TABLE . TOKEN-OR-TOKEN-LIST) ...)."
+ (semanticdb-collect-find-results
+ databases
+ (lambda (db)
+ (semanticdb-find-nonterminal-by-function-method
+ db function search-parts search-includes diff-mode find-file-match))
+ ignore-system
+ find-file-match))
+
+;;; Search Methods
+;;
+;; These are the base routines for searching semantic databases.
+;; Overload these with your subclasses to participate in the searching
+;; mechanism.
+(defmethod semanticdb-find-nonterminal-by-token-method
+ ((database semanticdb-project-database) token search-parts search-includes diff-mode find-file-match)
+ "OBSOLETE:
+In DB, find all occurances of nonterminals with token TOKEN in databases.
+See `semanticdb-find-nonterminal-by-function-method' for details on,
+SEARCH-PARTS, SEARCH-INCLUDES, DIFF-MODE, and FIND-FILE-MATCH.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (let ((goofy-token-name token))
+ (semanticdb-find-nonterminal-by-function-method
+ database (lambda (stream sp si)
+ (semantic-brute-find-tag-by-class goofy-token-name stream sp si))
+ search-parts search-includes diff-mode find-file-match)))
+
+(defmethod semanticdb-find-nonterminal-by-name-method
+ ((database semanticdb-project-database) name search-parts search-includes diff-mode find-file-match)
+ "OBSOLETE:
+Find all occurances of nonterminals with name NAME in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES, DIFF-MODE, and FIND-FILE-MATCH.
+Return a list ((DB-TABLE . TOKEN) ...)."
+ (semanticdb-find-nonterminal-by-function-method
+ database
+ (lambda (stream sp si)
+ (semantic-brute-find-first-tag-by-name name stream sp si))
+ search-parts search-includes diff-mode find-file-match))
+
+(defmethod semanticdb-find-nonterminal-by-name-regexp-method
+ ((database semanticdb-project-database) regex search-parts search-includes diff-mode find-file-match)
+ "OBSOLETE:
+Find all occurances of nonterminals with name matching REGEX in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-find-nonterminal-by-function-method
+ database
+ (lambda (stream sp si)
+ (semantic-brute-find-tag-by-name-regexp regex stream sp si))
+ search-parts search-includes diff-mode find-file-match))
+
+(defmethod semanticdb-find-nonterminal-by-type-method
+ ((database semanticdb-project-database) type search-parts search-includes diff-mode find-file-match)
+ "OBSOLETE:
+Find all nonterminals with a type of TYPE in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-find-nonterminal-by-function-method
+ database
+ (lambda (stream sp si)
+ (semantic-brute-find-tag-by-type type stream sp si))
+ search-parts search-includes diff-mode find-file-match))
+
+(defmethod semanticdb-find-nonterminal-by-property-method
+ ((database semanticdb-project-database) property value search-parts search-includes diff-mode find-file-match)
+ "OBSOLETE:
+Find all nonterminals with a PROPERTY equal to VALUE in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-find-nonterminal-by-function-method
+ database
+ (lambda (stream sp si)
+ (semantic-brute-find-tag-by-property property value stream sp si))
+ search-parts search-includes diff-mode find-file-match))
+
+(defmethod semanticdb-find-nonterminal-by-extra-spec-method
+ ((database semanticdb-project-database) spec search-parts search-includes diff-mode find-file-match)
+ "OBSOLETE:
+Find all nonterminals with a SPEC in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-find-nonterminal-by-function-method
+ database
+ (lambda (stream sp si)
+ (semantic-brute-find-tag-by-attribute spec stream sp si))
+ search-parts search-includes diff-mode find-file-match))
+
+(defmethod semanticdb-find-nonterminal-by-extra-spec-value-method
+ ((database semanticdb-project-database) spec value search-parts search-includes diff-mode find-file-match)
+ "OBSOLETE:
+Find all nonterminals with a SPEC equal to VALUE in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-find-nonterminal-by-function-method
+ database
+ (lambda (stream sp si)
+ (semantic-brute-find-tag-by-attribute-value spec value stream sp si))
+ search-parts search-includes diff-mode find-file-match))
+
+;;; Advanced Searches
+;;
+(defmethod semanticdb-find-nonterminal-external-children-of-type-method
+ ((database semanticdb-project-database) type search-parts search-includes diff-mode find-file-match)
+ "OBSOLETE:
+Find all nonterminals which are child elements of TYPE
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+ (semanticdb-find-nonterminal-by-function-method
+ database
+ `(lambda (stream sp si)
+ (semantic-brute-find-tag-by-function
+ (lambda (tok)
+ (let ((p (semantic-nonterminal-external-member-parent tok)))
+ (and (stringp p) (string= ,type p)))
+ )
+ stream sp si))
+ nil nil t))
+
+;;; Generic Search
+;;
+(defmethod semanticdb-find-nonterminal-by-function-method
+ ((database semanticdb-project-database)
+ function &optional search-parts search-includes diff-mode find-file-match)
+ "OBSOLETE:
+In DATABASE, find all occurances of nonterminals which match FUNCTION.
+When SEARCH-PARTS is non-nil the search will include children of tags.
+When SEARCH-INCLUDES is non-nil, the search will include dependency files.
+When DIFF-MODE is non-nil, search databases which are of a different mode.
+A mode is the `major-mode' that file was in when it was last parsed.
+When FIND-FILE-MATCH is non-nil, the make sure any found token's file is
+in an Emacs buffer.
+Return a list of matches."
+ (let* ((ret nil)
+ (files (semanticdb-get-database-tables database))
+ (found nil)
+ (orig-buffer (current-buffer)))
+ (while files
+ (when (or diff-mode
+ (semanticdb-equivalent-mode (car files) orig-buffer))
+ ;; This can cause unneeded refreshes while typing with
+ ;; senator-eldoc mode.
+ ;;(semanticdb-refresh-table (car files))
+ (setq found (funcall function
+ (semanticdb-get-tags (car files))
+ search-parts
+ search-includes
+ )))
+ (if found
+ (progn
+ ;; When something is found, make sure we read in that buffer if it
+ ;; had not already been loaded.
+ (if find-file-match
+ (save-excursion (semanticdb-set-buffer (car files))))
+ ;; In theory, the database is up-to-date with what is in the file, and
+ ;; these tags are ready to go.
+ ;; There is a bug lurking here I don't have time to fix.
+ (setq ret (cons (cons (car files) found) ret))
+ (setq found nil)))
+ (setq files (cdr files)))
+ (nreverse ret)))
+
+(provide 'semantic/db-search)
+
+;;; semanticdb-search.el ends here
--- /dev/null
+;;; db-typecache.el --- Manage Datatypes
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+;; 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:
+;;
+;; Manage a datatype cache.
+;;
+;; For typed languages like C++ collect all known types from various
+;; headers, merge namespaces, and expunge duplicates.
+;;
+;; It is likely this feature will only be needed for C/C++.
+
+(require 'semantic/db)
+(require 'semantic/db-find)
+
+;;; Code:
+
+\f
+;;; TABLE TYPECACHE
+(defclass semanticdb-typecache ()
+ ((filestream :initform nil
+ :documentation
+ "Fully sorted/merged list of tags within this buffer.")
+ (includestream :initform nil
+ :documentation
+ "Fully sorted/merged list of tags from this file's includes list.")
+ (stream :initform nil
+ :documentation
+ "The searchable tag stream for this cache.
+NOTE: Can I get rid of this? Use a hashtable instead?")
+ (dependants :initform nil
+ :documentation
+ "Any other object that is dependent on typecache results.
+Said object must support `semantic-reset' methods.")
+ ;; @todo - add some sort of fast-hash.
+ ;; @note - Rebuilds in large projects already take a while, and the
+ ;; actual searches are pretty fast. Really needed?
+ )
+ "Structure for maintaining a typecache.")
+
+(defmethod semantic-reset ((tc semanticdb-typecache))
+ "Reset the object IDX."
+ (oset tc filestream nil)
+ (oset tc includestream nil)
+
+ (oset tc stream nil)
+
+ (mapc 'semantic-reset (oref tc dependants))
+ (oset tc dependants nil)
+ )
+
+(defmethod semanticdb-typecache-notify-reset ((tc semanticdb-typecache))
+ "Do a reset from a notify from a table we depend on."
+ (oset tc includestream nil)
+ (mapc 'semantic-reset (oref tc dependants))
+ (oset tc dependants nil)
+ )
+
+(defmethod semanticdb-partial-synchronize ((tc semanticdb-typecache)
+ new-tags)
+ "Reset the typecache based on a partial reparse."
+ (when (semantic-find-tags-by-class 'include new-tags)
+ (oset tc includestream nil)
+ (mapc 'semantic-reset (oref tc dependants))
+ (oset tc dependants nil)
+ )
+
+ (when (semantic-find-tags-by-class 'type new-tags)
+ ;; Reset our index
+ (oset tc filestream nil)
+ t ;; Return true, our core file tags have changed in a relavant way.
+ )
+
+ ;; NO CODE HERE
+ )
+
+(defun semanticdb-typecache-add-dependant (dep)
+ "Add into the local typecache a dependant DEP."
+ (let* ((table semanticdb-current-table)
+ ;;(idx (semanticdb-get-table-index table))
+ (cache (semanticdb-get-typecache table))
+ )
+ (object-add-to-list cache 'dependants dep)))
+
+(defun semanticdb-typecache-length(thing)
+ "How long is THING?
+Debugging function."
+ (cond ((semanticdb-typecache-child-p thing)
+ (length (oref thing stream)))
+ ((semantic-tag-p thing)
+ (length (semantic-tag-type-members thing)))
+ ((and (listp thing) (semantic-tag-p (car thing)))
+ (length thing))
+ ((null thing)
+ 0)
+ (t -1) ))
+
+
+(defmethod semanticdb-get-typecache ((table semanticdb-abstract-table))
+ "Retrieve the typecache from the semanticdb TABLE.
+If there is no table, create one, and fill it in."
+ (semanticdb-refresh-table table)
+ (let* ((idx (semanticdb-get-table-index table))
+ (cache (oref idx type-cache))
+ )
+
+ ;; Make sure we have a cache object in the DB index.
+ (when (not cache)
+ ;; The object won't change as we fill it with stuff.
+ (setq cache (semanticdb-typecache (semanticdb-full-filename table)))
+ (oset idx type-cache cache))
+
+ cache))
+
+(defmethod semanticdb-have-typecache-p ((table semanticdb-abstract-table))
+ "Return non-nil (the typecache) if TABLE has a pre-calculated typecache."
+ (let* ((idx (semanticdb-get-table-index table)))
+ (oref idx type-cache)))
+
+\f
+;;; DATABASE TYPECACHE
+;;
+;; A full database can cache the types across its files.
+;;
+;; Unlike file based caches, this one is a bit simpler, and just needs
+;; to get reset when a table gets updated.
+
+(defclass semanticdb-database-typecache (semanticdb-abstract-db-cache)
+ ((stream :initform nil
+ :documentation
+ "The searchable tag stream for this cache.")
+ )
+ "Structure for maintaining a typecache.")
+
+(defmethod semantic-reset ((tc semanticdb-database-typecache))
+ "Reset the object IDX."
+ (oset tc stream nil)
+ )
+
+(defmethod semanticdb-synchronize ((cache semanticdb-database-typecache)
+ new-tags)
+ "Synchronize a CACHE with some NEW-TAGS."
+ )
+
+(defmethod semanticdb-partial-synchronize ((cache semanticdb-database-typecache)
+ new-tags)
+ "Synchronize a CACHE with some changed NEW-TAGS."
+ )
+
+(defmethod semanticdb-get-typecache ((db semanticdb-project-database))
+ "Retrieve the typecache from the semantic database DB.
+If there is no table, create one, and fill it in."
+ (semanticdb-cache-get db semanticdb-database-typecache)
+ )
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; MERGING
+;;
+;; Managing long streams of tags representing data types.
+;;
+(defun semanticdb-typecache-apply-filename (file stream)
+ "Apply the filename FILE to all tags in STREAM."
+ (let ((new nil))
+ (while stream
+ (setq new (cons (semantic-tag-copy (car stream) nil file)
+ new))
+ ;The below is handled by the tag-copy fcn.
+ ;(semantic--tag-put-property (car new) :filename file)
+ (setq stream (cdr stream)))
+ (nreverse new)))
+
+
+(defsubst semanticdb-typecache-safe-tag-members (tag)
+ "Return a list of members for TAG that are safe to permute."
+ (let ((mem (semantic-tag-type-members tag))
+ (fname (semantic-tag-file-name tag)))
+ (if fname
+ (setq mem (semanticdb-typecache-apply-filename fname mem))
+ (copy-sequence mem))))
+
+(defsubst semanticdb-typecache-safe-tag-list (tags table)
+ "Make the tag list TAGS found in TABLE safe for the typecache.
+Adds a filename and copies the tags."
+ (semanticdb-typecache-apply-filename
+ (semanticdb-full-filename table)
+ tags))
+
+(defun semanticdb-typecache-merge-streams (cache1 cache2)
+ "Merge into CACHE1 and CACHE2 together. The Caches will be merged in place."
+ (if (or (and (not cache1) (not cache2))
+ (and (not (cdr cache1)) (not cache2))
+ (and (not cache1) (not (cdr cache2))))
+ ;; If all caches are empty OR
+ ;; cache1 is length 1 and no cache2 OR
+ ;; no cache1 and length 1 cache2
+ ;;
+ ;; then just return the cache, and skip all this merging stuff.
+ (or cache1 cache2)
+
+ ;; Assume we always have datatypes, as this typecache isn't really
+ ;; useful without a typed language.
+ (let ((S (semantic-sort-tags-by-name-then-type-increasing
+ ;; I used to use append, but it copied cache1 but not cache2.
+ ;; Since sort was permuting cache2, I already had to make sure
+ ;; the caches were permute-safe. Might as well use nconc here.
+ (nconc cache1 cache2)))
+ (ans nil)
+ (next nil)
+ (prev nil)
+ (type nil))
+ ;; With all the tags in order, we can loop over them, and when
+ ;; two have the same name, we can either throw one away, or construct
+ ;; a fresh new tag merging the items together.
+ (while S
+ (setq prev (car ans))
+ (setq next (car S))
+ (if (or
+ ;; CASE 1 - First item
+ (null prev)
+ ;; CASE 2 - New name
+ (not (string= (semantic-tag-name next)
+ (semantic-tag-name prev))))
+ (setq ans (cons next ans))
+ ;; ELSE - We have a NAME match.
+ (setq type (semantic-tag-type next))
+ (if (semantic-tag-of-type-p prev type) ; Are they the same datatype
+ ;; Same Class, we can do a merge.
+ (cond
+ ((and (semantic-tag-of-class-p next 'type)
+ (string= type "namespace"))
+ ;; Namespaces - merge the children together.
+ (setcar ans
+ (semantic-tag-new-type
+ (semantic-tag-name prev) ; - they are the same
+ "namespace" ; - we know this as fact
+ (semanticdb-typecache-merge-streams
+ (semanticdb-typecache-safe-tag-members prev)
+ (semanticdb-typecache-safe-tag-members next))
+ nil ; - no attributes
+ ))
+ ;; Make sure we mark this as a fake tag.
+ (semantic-tag-set-faux (car ans))
+ )
+ ((semantic-tag-prototype-p next)
+ ;; NEXT is a prototype... so keep previous.
+ nil ; - keep prev, do nothing
+ )
+ ((semantic-tag-prototype-p prev)
+ ;; PREV is a prototype, but not next.. so keep NEXT.
+ ;; setcar - set by side-effect on top of prev
+ (setcar ans next)
+ )
+ (t
+ ;;(message "Don't know how to merge %s. Keeping first entry." (semantic-tag-name next))
+ ))
+ ;; Not same class... but same name
+ ;(message "Same name, different type: %s, %s!=%s"
+ ; (semantic-tag-name next)
+ ; (semantic-tag-type next)
+ ; (semantic-tag-type prev))
+ (setq ans (cons next ans))
+ ))
+ (setq S (cdr S)))
+ (nreverse ans))))
+\f
+;;; Refresh / Query API
+;;
+;; Queries that can be made for the typecache.
+(defmethod semanticdb-typecache-file-tags ((table semanticdb-abstract-table))
+ "No tags available from non-file based tables."
+ nil)
+
+(defmethod semanticdb-typecache-file-tags ((table semanticdb-table))
+ "Update the typecache for TABLE, and return the file-tags.
+File-tags are those that belong to this file only, and excludes
+all included files."
+ (let* (;(idx (semanticdb-get-table-index table))
+ (cache (semanticdb-get-typecache table))
+ )
+
+ ;; Make sure our file-tags list is up to date.
+ (when (not (oref cache filestream))
+ (let ((tags (semantic-find-tags-by-class 'type table)))
+ (when tags
+ (setq tags (semanticdb-typecache-safe-tag-list tags table))
+ (oset cache filestream (semanticdb-typecache-merge-streams tags nil)))))
+
+ ;; Return our cache.
+ (oref cache filestream)
+ ))
+
+(defmethod semanticdb-typecache-include-tags ((table semanticdb-abstract-table))
+ "No tags available from non-file based tables."
+ nil)
+
+(defmethod semanticdb-typecache-include-tags ((table semanticdb-table))
+ "Update the typecache for TABLE, and return the merged types from the include tags.
+Include-tags are the tags brought in via includes, all merged together into
+a master list."
+ (let* ((cache (semanticdb-get-typecache table))
+ )
+
+ ;; Make sure our file-tags list is up to date.
+ (when (not (oref cache includestream))
+ (let (;; Calc the path first. This will have a nice side -effect of
+ ;; getting the cache refreshed if a refresh is needed. Most of the
+ ;; time this value is itself cached, so the query is fast.
+ (incpath (semanticdb-find-translate-path table nil))
+ (incstream nil))
+ ;; Get the translated path, and extract all the type tags, then merge
+ ;; them all together.
+ (dolist (i incpath)
+ ;; don't include ourselves in this crazy list.
+ (when (and i (not (eq i table))
+ ;; @todo - This eieio fcn can be slow! Do I need it?
+ ;; (semanticdb-table-child-p i)
+ )
+ (setq incstream
+ (semanticdb-typecache-merge-streams
+ incstream
+ ;; Getting the cache from this table will also cause this
+ ;; file to update it's cache from it's decendants.
+ ;;
+ ;; In theory, caches are only built for most includes
+ ;; only once (in the loop before this one), so this ends
+ ;; up being super fast as we edit our file.
+ (copy-sequence
+ (semanticdb-typecache-file-tags i))))
+ ))
+
+ ;; Save...
+ (oset cache includestream incstream)))
+
+ ;; Return our cache.
+ (oref cache includestream)
+ ))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Search Routines
+;;
+(define-overloadable-function semanticdb-typecache-find (type &optional path find-file-match)
+ "Search the typecache for TYPE in PATH.
+If type is a string, split the string, and search for the parts.
+If type is a list, treat the type as a pre-split string.
+PATH can be nil for the current buffer, or a semanticdb table.
+FIND-FILE-MATCH is non-nil to force all found tags to be loaded into a buffer.")
+
+(defun semanticdb-typecache-find-default (type &optional path find-file-match)
+ "Default implementation of `semanticdb-typecache-find'.
+TYPE is the datatype to find.
+PATH is the search path.. which should be one table object.
+If FIND-FILE-MATCH is non-nil, then force the file belonging to the
+found tag to be loaded."
+ (semanticdb-typecache-find-method (or path semanticdb-current-table)
+ type find-file-match))
+
+(defun semanticdb-typecache-find-by-name-helper (name table)
+ "Find the tag with NAME in TABLE, which is from a typecache.
+If more than one tag has NAME in TABLE, we will prefer the tag that
+is of class 'type."
+ (let* ((names (semantic-find-tags-by-name name table))
+ (types (semantic-find-tags-by-class 'type names)))
+ (or (car-safe types) (car-safe names))))
+
+(defmethod semanticdb-typecache-find-method ((table semanticdb-abstract-table)
+ type find-file-match)
+ "Search the typecache in TABLE for the datatype TYPE.
+If type is a string, split the string, and search for the parts.
+If type is a list, treat the type as a pre-split string.
+If FIND-FILE-MATCH is non-nil, then force the file belonging to the
+found tag to be loaded."
+ ;; convert string to a list.
+ (when (stringp type) (setq type (semantic-analyze-split-name type)))
+ (when (stringp type) (setq type (list type)))
+
+ ;; Search for the list in our typecache.
+ (let* ((file (semanticdb-typecache-file-tags table))
+ (inc (semanticdb-typecache-include-tags table))
+ (stream nil)
+ (f-ans nil)
+ (i-ans nil)
+ (ans nil)
+ (notdone t)
+ (lastfile nil)
+ (thisfile nil)
+ (lastans nil)
+ (calculated-scope nil)
+ )
+ ;; 1) Find first symbol in the two master lists and then merge
+ ;; the found streams.
+
+ ;; We stripped duplicates, so these will be super-fast!
+ (setq f-ans (semantic-find-first-tag-by-name (car type) file))
+ (setq i-ans (semantic-find-first-tag-by-name (car type) inc))
+ (if (and f-ans i-ans)
+ (progn
+ ;; This trick merges the two identified tags, making sure our lists are
+ ;; complete. The second find then gets the new 'master' from the list of 2.
+ (setq ans (semanticdb-typecache-merge-streams (list f-ans) (list i-ans)))
+ (setq ans (semantic-find-first-tag-by-name (car type) ans))
+ )
+
+ ;; The answers are already sorted and merged, so if one misses,
+ ;; no need to do any special work.
+ (setq ans (or f-ans i-ans)))
+
+ ;; 2) Loop over the remaining parts.
+ (while (and type notdone)
+
+ ;; For pass > 1, stream will be non-nil, so do a search, otherwise
+ ;; ans is from outside the loop.
+ (when stream
+ (setq ans (semanticdb-typecache-find-by-name-helper (car type) stream))
+
+ ;; NOTE: The below test to make sure we get a type is only relevant
+ ;; for the SECOND pass or later. The first pass can only ever
+ ;; find a type/namespace because everything else is excluded.
+
+ ;; If this is not the last entry from the list, then it
+ ;; must be a type or a namespace. Lets double check.
+ (when (cdr type)
+
+ ;; From above, there is only one tag in ans, and we prefer
+ ;; types.
+ (when (not (semantic-tag-of-class-p ans 'type))
+
+ (setq ans nil)))
+ )
+
+ (push ans calculated-scope)
+
+ ;; Track most recent file.
+ (setq thisfile (semantic-tag-file-name ans))
+ (when (and thisfile (stringp thisfile))
+ (setq lastfile thisfile))
+
+ ;; If we have a miss, exit, otherwise, update the stream to
+ ;; the next set of members.
+ (if (not ans)
+ (setq notdone nil)
+ (setq stream (semantic-tag-type-members ans)))
+
+ (setq lastans ans
+ ans nil
+ type (cdr type)))
+
+ (if (or type (not notdone))
+ ;; If there is stuff left over, then we failed. Just return
+ ;; nothing.
+ nil
+
+ ;; We finished, so return everything.
+
+ (if (and find-file-match lastfile)
+ ;; This won't liven up the tag since we have a copy, but
+ ;; we ought to be able to get there and go to the right line.
+ (find-file-noselect lastfile)
+ ;; We don't want to find-file match, so instead lets
+ ;; push the filename onto the return tag.
+ (when lastans
+ (setq lastans (semantic-tag-copy lastans nil lastfile))
+ ;; We used to do the below, but we would erroneously be putting
+ ;; attributes on tags being shred with other lists.
+ ;;(semantic--tag-put-property lastans :filename lastfile)
+ )
+ )
+
+ (if (and lastans calculated-scope)
+
+ ;; Put our discovered scope into the tag if we have a tag
+ (semantic-scope-tag-clone-with-scope
+ lastans (reverse (cdr calculated-scope)))
+
+ ;; Else, just return
+ lastans
+ ))))
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; BRUTISH Typecache
+;;
+;; Routines for a typecache that crosses all tables in a given database
+;; for a matching major-mode.
+(defmethod semanticdb-typecache-for-database ((db semanticdb-project-database)
+ &optional mode)
+ "Return the typecache for the project database DB.
+If there isn't one, create it.
+"
+ (let ((lmode (or mode major-mode))
+ (cache (semanticdb-get-typecache db))
+ (stream nil)
+ )
+ (dolist (table (semanticdb-get-database-tables db))
+ (when (eq lmode (oref table :major-mode))
+ (setq stream
+ (semanticdb-typecache-merge-streams
+ stream
+ (copy-sequence
+ (semanticdb-typecache-file-tags table))))
+ ))
+ (oset cache stream stream)
+ cache))
+
+(defun semanticdb-typecache-refresh-for-buffer (buffer)
+ "Refresh the typecache for BUFFER."
+ (save-excursion
+ (set-buffer buffer)
+ (let* ((tab semanticdb-current-table)
+ ;(idx (semanticdb-get-table-index tab))
+ (tc (semanticdb-get-typecache tab)))
+ (semanticdb-typecache-file-tags tab)
+ (semanticdb-typecache-include-tags tab)
+ tc)))
+
+\f
+;;; DEBUG
+;;
+(defun semanticdb-typecache-complete-flush ()
+ "Flush all typecaches referenced by the current buffer."
+ (interactive)
+ (let* ((path (semanticdb-find-translate-path nil nil)))
+ (dolist (P path)
+ (oset P pointmax nil)
+ (semantic-reset (semanticdb-get-typecache P)))))
+
+(defun semanticdb-typecache-dump ()
+ "Dump the typecache for the current buffer."
+ (interactive)
+ (require 'data-debug)
+ (let* ((start (current-time))
+ (tc (semanticdb-typecache-refresh-for-buffer (current-buffer)))
+ (end (current-time))
+ )
+ (data-debug-new-buffer "*TypeCache ADEBUG*")
+ (message "Calculating Cache took %.2f seconds."
+ (semantic-elapsed-time start end))
+
+ (data-debug-insert-thing tc "]" "")
+
+ ))
+
+(defun semanticdb-db-typecache-dump ()
+ "Dump the typecache for the current buffer's database."
+ (interactive)
+ (require 'data-debug)
+ (let* ((tab semanticdb-current-table)
+ (idx (semanticdb-get-table-index tab))
+ (junk (oset idx type-cache nil)) ;; flush!
+ (start (current-time))
+ (tc (semanticdb-typecache-for-database (oref tab parent-db)))
+ (end (current-time))
+ )
+ (data-debug-new-buffer "*TypeCache ADEBUG*")
+ (message "Calculating Cache took %.2f seconds."
+ (semantic-elapsed-time start end))
+
+ (data-debug-insert-thing tc "]" "")
+
+ ))
+
+
+(provide 'semantic/db-typecache)
+;;; semanticdb-typecache.el ends here
--- /dev/null
+;;; dep.el --- Methods for tracking dependencies (include files)
+
+;;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Keywords: syntax
+
+;; 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:
+;;
+;; Include tags (dependencies for a given source file) usually have
+;; some short name. The target file that it is dependent on is
+;; generally found on some sort of path controlled by the compiler or
+;; project.
+;;
+;; EDE or even ECB can control our project dependencies, and help us
+;; find file within the setting of a given project. For system
+;; dependencies, we need to depend on user supplied lists, which can
+;; manifest themselves in the form of system datatabases (from
+;; semanticdb.)
+;;
+;; Provide ways to track these different files here.
+
+(require 'semantic/tag)
+
+;;; Code:
+
+(defvar semantic-dependency-include-path nil
+ "Defines the include path used when searching for files.
+This should be a list of directories to search which is specific
+to the file being included.
+
+If `semantic-dependency-tag-file' is overridden for a given
+language, this path is most likely ignored.
+
+The above function, reguardless of being overriden, caches the
+located dependency file location in the tag property
+`dependency-file'. If you override this function, you do not
+need to implement your own cache. Each time the buffer is fully
+reparsed, the cache will be reset.
+
+TODO: use ffap.el to locate such items?
+
+NOTE: Obsolete this, or use as special user")
+(make-variable-buffer-local `semantic-dependency-include-path)
+
+(defvar semantic-dependency-system-include-path nil
+ "Defines the system include path.
+This should be set with either `defvar-mode-local', or with
+`semantic-add-system-include'.
+
+For mode authors, use
+`defcustom-mode-local-semantic-dependency-system-include-path'
+to create a mode-specific variable to control this.
+
+When searching for a file associated with a name found in an tag of
+class include, this path will be inspected for includes of type
+`system'. Some include tags are agnostic to this setting and will
+check both the project and system directories.")
+(make-variable-buffer-local `semantic-dependency-system-include-path)
+
+(defmacro defcustom-mode-local-semantic-dependency-system-include-path
+ (mode name value &optional docstring)
+ "Create a mode-local value of the system-dependency include path.
+MODE is the `major-mode' this name/value pairs is for.
+NAME is the name of the customizable value users will use.
+VALUE is the path (a list of strings) to add.
+DOCSTRING is a documentation string applied to the variable NAME
+users will customize.
+
+Creates a customizable variable users can customize that will
+keep semantic data structures up to date."
+ `(progn
+ ;; Create a variable users can customize.
+ (defcustom ,name ,value
+ ,docstring
+ :group (quote ,(intern (car (split-string (symbol-name mode) "-"))))
+ :group 'semantic
+ :type '(repeat (directory :tag "Directory"))
+ :set (lambda (sym val)
+ (set-default sym val)
+ (setq-mode-local ,mode
+ semantic-dependency-system-include-path
+ val)
+ (when (fboundp
+ 'semantic-decoration-unparsed-include-do-reset)
+ (mode-local-map-mode-buffers
+ 'semantic-decoration-unparsed-include-do-reset
+ (quote ,mode))))
+ )
+ ;; Set the variable to the default value.
+ (defvar-mode-local ,mode semantic-dependency-system-include-path
+ ,name
+ "System path to search for include files.")
+ ;; Bind NAME onto our variable so tools can customize it
+ ;; without knowing about it.
+ (put 'semantic-dependency-system-include-path
+ (quote ,mode) (quote ,name))
+ ))
+
+;;; PATH MANAGEMENT
+;;
+;; Some fcns to manage paths for a give mode.
+(defun semantic-add-system-include (dir &optional mode)
+ "Add a system include DIR to path for MODE.
+Modifies a mode-local version of `semantic-dependency-system-include-path'.
+
+Changes made by this function are not persistent."
+ (interactive "DNew Include Directory: ")
+ (if (not mode) (setq mode major-mode))
+ (let ((dirtmp (file-name-as-directory dir))
+ (value
+ (mode-local-value mode 'semantic-dependency-system-include-path))
+ )
+ (add-to-list 'value dirtmp t)
+ (eval `(setq-mode-local ,mode
+ semantic-dependency-system-include-path value))
+ ))
+
+(defun semantic-remove-system-include (dir &optional mode)
+ "Add a system include DIR to path for MODE.
+Modifies a mode-local version of`semantic-dependency-system-include-path'.
+
+Changes made by this function are not persistent."
+ (interactive (list
+ (completing-read
+ "Include Directory to Remove: "
+ semantic-dependency-system-include-path))
+ )
+ (if (not mode) (setq mode major-mode))
+ (let ((dirtmp (file-name-as-directory dir))
+ (value
+ (mode-local-value mode 'semantic-dependency-system-include-path))
+ )
+ (setq value (delete dirtmp value))
+ (eval `(setq-mode-local ,mode semantic-dependency-system-include-path
+ value))
+ ))
+
+(defun semantic-reset-system-include (&optional mode)
+ "Reset the system include list to empty for MODE.
+Modifies a mode-local version of
+`semantic-dependency-system-include-path'."
+ (interactive)
+ (if (not mode) (setq mode major-mode))
+ (eval `(setq-mode-local ,mode semantic-dependency-system-include-path
+ nil))
+ )
+
+(defun semantic-customize-system-include-path (&optional mode)
+ "Customize the include path for this `major-mode'.
+To create a customizable include path for a major MODE, use the
+macro `defcustom-mode-local-semantic-dependency-system-include-path'."
+ (interactive)
+ (let ((ips (get 'semantic-dependency-system-include-path
+ (or mode major-mode))))
+ ;; Do we have one?
+ (when (not ips)
+ (error "There is no customizable includepath variable for %s"
+ (or mode major-mode)))
+ ;; Customize it.
+ (customize-variable ips)))
+
+;;; PATH SEARCH
+;;
+;; methods for finding files on a provided path.
+(if (fboundp 'locate-file)
+ (defsubst semantic--dependency-find-file-on-path (file path)
+ "Return an expanded file name for FILE on PATH."
+ (locate-file file path))
+
+ ;; Else, older version of Emacs.
+
+ (defsubst semantic--dependency-find-file-on-path (file path)
+ "Return an expanded file name for FILE on PATH."
+ (let ((p path)
+ (found nil))
+ (while (and p (not found))
+ (let ((f (expand-file-name file (car p))))
+ (if (file-exists-p f)
+ (setq found f)))
+ (setq p (cdr p)))
+ found))
+
+ )
+
+(defun semantic-dependency-find-file-on-path (file systemp &optional mode)
+ "Return an expanded file name for FILE on available paths.
+If SYSTEMP is true, then only search system paths.
+If optional argument MODE is non-nil, then derive paths from the
+provided mode, not from the current major mode."
+ (if (not mode) (setq mode major-mode))
+ (let ((sysp (mode-local-value
+ mode 'semantic-dependency-system-include-path))
+ (edesys (when (and (featurep 'ede) ede-minor-mode
+ ede-object)
+ (ede-system-include-path ede-object)))
+ (locp (mode-local-value
+ mode 'semantic-dependency-include-path))
+ (found nil))
+ (when (file-exists-p file)
+ (setq found file))
+ (when (and (not found) (not systemp))
+ (setq found (semantic--dependency-find-file-on-path file locp)))
+ (when (and (not found) edesys)
+ (setq found (semantic--dependency-find-file-on-path file edesys)))
+ (when (not found)
+ (setq found (semantic--dependency-find-file-on-path file sysp)))
+ (if found (expand-file-name found))))
+
+
+(provide 'semantic/dep)
+
+;;; semantic-dep.el ends here
--- /dev/null
+;;; ia.el --- Interactive Analysis functions
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Keywords: syntax
+
+;; 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:
+;;
+;; Interactive access to `semantic-analyze'.
+;;
+;; These routines are fairly simple, and show how to use the Semantic
+;; analyzer to provide things such as completion lists, summaries,
+;; locations, or documentation.
+;;
+
+;;; TODO
+;;
+;; fast-jump. For a virtual method, offer some of the possible
+;; implementations in various sub-classes.
+
+(require 'senator)
+(require 'semantic/analyze)
+(require 'pulse)
+(eval-when-compile
+ (require 'semantic/analyze)
+ (require 'semantic/analyze/refs))
+
+;;; Code:
+
+;;; COMPLETION
+;;
+;; This set of routines provides some simplisting completion
+;; functions.
+
+(defcustom semantic-ia-completion-format-tag-function
+ 'semantic-prototype-nonterminal
+ "*Function used to convert a tag to a string during completion."
+ :group 'semantic
+ :type semantic-format-tag-custom-list)
+
+(defvar semantic-ia-cache nil
+ "Cache of the last completion request.
+Of the form ( POINT . COMPLETIONS ) where POINT is a location in the
+buffer where the completion was requested. COMPLETONS is the list
+of semantic tag names that provide logical completions from that
+location.")
+(make-variable-buffer-local 'semantic-ia-cache)
+
+(defun semantic-ia-get-completions (context point)
+ "Fetch the completion of CONTEXT at POINT.
+Supports caching."
+ ;; Cache the current set of symbols so that we can get at
+ ;; them quickly the second time someone presses the
+ ;; complete button.
+ (let ((symbols
+ (if (and semantic-ia-cache
+ (= point (car semantic-ia-cache)))
+ (cdr semantic-ia-cache)
+ (semantic-analyze-possible-completions context))))
+ ;; Set the cache
+ (setq semantic-ia-cache (cons point symbols))
+ symbols))
+
+(defun semantic-ia-complete-symbol (point)
+ "Complete the current symbol at POINT.
+Completion options are calculated with `semantic-analyze-possible-completions'."
+ (interactive "d")
+ ;; Calculating completions is a two step process.
+ ;;
+ ;; The first analyzer the current context, which finds tags
+ ;; for all the stuff that may be references by the code around
+ ;; POINT.
+ ;;
+ ;; The second step derives completions from that context.
+ (let* ((a (semantic-analyze-current-context point))
+ (syms (semantic-ia-get-completions a point))
+ (pre (car (reverse (oref a prefix))))
+ )
+ ;; If PRE was actually an already completed symbol, it doesn't
+ ;; come in as a string, but as a tag instead.
+ (if (semantic-tag-p pre)
+ ;; We will try completions on it anyway.
+ (setq pre (semantic-tag-name pre)))
+ ;; Complete this symbol.
+ (if (null syms)
+ (progn
+ ;(message "No smart completions found. Trying senator-complete-symbol.")
+ (if (semantic-analyze-context-p a)
+ ;; This is a clever hack. If we were unable to find any
+ ;; smart completions, lets divert to how senator derives
+ ;; completions.
+ ;;
+ ;; This is a way of making this fcn more useful since the
+ ;; smart completion engine sometimes failes.
+ (senator-complete-symbol)
+ ))
+ ;; Use try completion to seek a common substring.
+ (let ((tc (try-completion (or pre "") syms)))
+ (if (and (stringp tc) (not (string= tc (or pre ""))))
+ (let ((tok (semantic-find-first-tag-by-name
+ tc syms)))
+ ;; Delete what came before...
+ (when (and (car (oref a bounds)) (cdr (oref a bounds)))
+ (delete-region (car (oref a bounds))
+ (cdr (oref a bounds)))
+ (goto-char (car (oref a bounds))))
+ ;; We have some new text. Stick it in.
+ (if tok
+ (semantic-ia-insert-tag tok)
+ (insert tc)))
+ ;; We don't have new text. Show all completions.
+ (when (cdr (oref a bounds))
+ (goto-char (cdr (oref a bounds))))
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list
+ (mapcar semantic-ia-completion-format-tag-function syms))
+ ))))))
+
+(defcustom semantic-ia-completion-menu-format-tag-function
+ 'semantic-uml-concise-prototype-nonterminal
+ "*Function used to convert a tag to a string during completion."
+ :group 'semantic
+ :type semantic-format-tag-custom-list)
+
+(defun semantic-ia-complete-symbol-menu (point)
+ "Complete the current symbol via a menu based at POINT.
+Completion options are calculated with `semantic-analyze-possible-completions'."
+ (interactive "d")
+ (let* ((a (semantic-analyze-current-context point))
+ (syms (semantic-ia-get-completions a point))
+ )
+ ;; Complete this symbol.
+ (if (not syms)
+ (progn
+ (message "No smart completions found. Trying Senator.")
+ (when (semantic-analyze-context-p a)
+ ;; This is a quick way of getting a nice completion list
+ ;; in the menu if the regular context mechanism fails.
+ (senator-completion-menu-popup)))
+
+ (let* ((menu
+ (mapcar
+ (lambda (tag)
+ (cons
+ (funcall semantic-ia-completion-menu-format-tag-function tag)
+ (vector tag)))
+ syms))
+ (ans
+ (imenu--mouse-menu
+ ;; XEmacs needs that the menu has at least 2 items. So,
+ ;; include a nil item that will be ignored by imenu.
+ (cons nil menu)
+ (senator-completion-menu-point-as-event)
+ "Completions")))
+ (when ans
+ (if (not (semantic-tag-p ans))
+ (setq ans (aref (cdr ans) 0)))
+ (delete-region (car (oref a bounds)) (cdr (oref a bounds)))
+ (semantic-ia-insert-tag ans))
+ ))))
+
+;;; COMPLETION HELPER
+;;
+;; This overload function handles inserting a tag
+;; into a buffer for these local completion routines.
+;;
+;; By creating the functions as overloadable, it can be
+;; customized. For example, the default will put a paren "("
+;; character after function names. For Lisp, it might check
+;; to put a "(" in front of a function name.
+
+(define-overloadable-function semantic-ia-insert-tag (tag)
+ "Insert TAG into the current buffer based on completion.")
+
+(defun semantic-ia-insert-tag-default (tag)
+ "Insert TAG into the current buffer based on completion."
+ (insert (semantic-tag-name tag))
+ (let ((tt (semantic-tag-class tag)))
+ (cond ((eq tt 'function)
+ (insert "("))
+ (t nil))))
+
+;;; Completions Tip
+;;
+;; This functions shows how to get the list of completions,
+;; to place in a tooltip. It doesn't actually do any completion.
+
+(defun semantic-ia-complete-tip (point)
+ "Pop up a tooltip for completion at POINT."
+ (interactive "d")
+ (let* ((a (semantic-analyze-current-context point))
+ (syms (semantic-ia-get-completions a point))
+ (x (mod (- (current-column) (window-hscroll))
+ (window-width)))
+ (y (save-excursion
+ (save-restriction
+ (widen)
+ (narrow-to-region (window-start) (point))
+ (goto-char (point-min))
+ (1+ (vertical-motion (buffer-size))))))
+ (str (mapconcat #'semantic-tag-name
+ syms
+ "\n"))
+ )
+ (cond ((fboundp 'x-show-tip)
+ (x-show-tip str
+ (selected-frame)
+ nil
+ nil
+ x y)
+ )
+ (t (message str))
+ )))
+
+;;; Summary
+;;
+;; Like idle-summary-mode, this shows how to get something to
+;; show a summary on.
+
+(defun semantic-ia-show-summary (point)
+ "Display a summary for the symbol under POINT."
+ (interactive "P")
+ (let* ((ctxt (semantic-analyze-current-context point))
+ (pf (when ctxt
+ ;; The CTXT is an EIEIO object. The below
+ ;; method will attempt to pick the most interesting
+ ;; tag associated with the current context.
+ (semantic-analyze-interesting-tag ctxt)))
+ )
+ (when pf
+ (message "%s" (semantic-format-tag-summarize pf nil t)))))
+
+;;; FAST Jump
+;;
+;; Jump to a destination based on the local context.
+;;
+;; This shows how to use the analyzer context, and the
+;; analyer references objects to choose a good destination.
+
+(defun semantic-ia--fast-jump-helper (dest)
+ "Jump to DEST, a Semantic tag.
+This helper manages the mark, buffer switching, and pulsing."
+ ;; We have a tag, but in C++, we usually get a prototype instead
+ ;; because of header files. Lets try to find the actual
+ ;; implementaion instead.
+ (when (semantic-tag-prototype-p dest)
+ (let* ((refs (semantic-analyze-tag-references dest))
+ (impl (semantic-analyze-refs-impl refs t))
+ )
+ (when impl (setq dest (car impl)))))
+
+ ;; Make sure we have a place to go...
+ (if (not (and (or (semantic-tag-with-position-p dest)
+ (semantic-tag-get-attribute dest :line))
+ (semantic-tag-file-name dest)))
+ (error "Tag %s has no buffer information"
+ (semantic-format-tag-name dest)))
+
+ ;; Once we have the tag, we can jump to it. Here
+ ;; are the key bits to the jump:
+
+ ;; 1) Push the mark, so you can pop global mark back, or
+ ;; use semantic-mru-bookmark mode to do so.
+ (push-mark)
+ (when (fboundp 'push-tag-mark)
+ (push-tag-mark))
+ ;; 2) Visits the tag.
+ (semantic-go-to-tag dest)
+ ;; 3) go-to-tag doesn't switch the buffer in the current window,
+ ;; so it is like find-file-noselect. Bring it forward.
+ (switch-to-buffer (current-buffer))
+ ;; 4) Fancy pulsing.
+ (pulse-momentary-highlight-one-line (point))
+ )
+
+(defun semantic-ia-fast-jump (point)
+ "Jump to the tag referred to by the code at POINT.
+Uses `semantic-analyze-current-context' output to identify an accurate
+origin of the code at point."
+ (interactive "d")
+ (let* ((ctxt (semantic-analyze-current-context point))
+ (pf (and ctxt (reverse (oref ctxt prefix))))
+ ;; In the analyzer context, the PREFIX is the list of items
+ ;; that makes up the code context at point. Thus the c++ code
+ ;; this.that().theothe
+ ;; would make a list:
+ ;; ( ("this" variable ..) ("that" function ...) "theothe")
+ ;; Where the first two elements are the semantic tags of the prefix.
+ ;;
+ ;; PF is the reverse of this list. If the first item is a string,
+ ;; then it is an incomplete symbol, thus we pick the second.
+ ;; The second cannot be a string, as that would have been an error.
+ (first (car pf))
+ (second (nth 1 pf))
+ )
+ (cond
+ ((semantic-tag-p first)
+ ;; We have a match. Just go there.
+ (semantic-ia--fast-jump-helper first))
+
+ ((semantic-tag-p second)
+ ;; Because FIRST failed, we should visit our second tag.
+ ;; HOWEVER, the tag we actually want that was only an unfound
+ ;; string may be related to some take in the datatype that belongs
+ ;; to SECOND. Thus, instead of visiting second directly, we
+ ;; can offer to find the type of SECOND, and go there.
+ (let ((secondclass (car (reverse (oref ctxt prefixtypes)))))
+ (cond
+ ((and (semantic-tag-with-position-p secondclass)
+ (y-or-n-p (format "Could not find `%s'. Jump to %s? "
+ first (semantic-tag-name secondclass))))
+ (semantic-ia--fast-jump-helper secondclass)
+ )
+ ;; If we missed out on the class of the second item, then
+ ;; just visit SECOND.
+ ((and (semantic-tag-p second)
+ (y-or-n-p (format "Could not find `%s'. Jump to %s? "
+ first (semantic-tag-name second))))
+ (semantic-ia--fast-jump-helper second)
+ ))))
+
+ ((semantic-tag-of-class-p (semantic-current-tag) 'include)
+ ;; Just borrow this cool fcn.
+ (semantic-decoration-include-visit)
+ )
+
+ (t
+ (error "Could not find suitable jump point for %s"
+ first))
+ )))
+
+(defun semantic-ia-fast-mouse-jump (evt)
+ "Jump to the tag referred to by the point clicked on.
+See `semantic-ia-fast-jump' for details on how it works.
+ This command is meant to be bound to a mouse event."
+ (interactive "e")
+ (semantic-ia-fast-jump
+ (save-excursion
+ (posn-set-point (event-end evt))
+ (point))))
+
+;;; DOC/DESCRIBE
+;;
+;; These routines show how to get additional information about a tag
+;; for purposes of describing or showing documentation about them.
+(defun semantic-ia-show-doc (point)
+ "Display the code-level documentation for the symbol at POINT."
+ (interactive "d")
+ (let* ((ctxt (semantic-analyze-current-context point))
+ (pf (reverse (oref ctxt prefix)))
+ )
+ ;; If PF, the prefix is non-nil, then the last element is either
+ ;; a string (incomplete type), or a semantic TAG. If it is a TAG
+ ;; then we should be able to find DOC for it.
+ (cond
+ ((stringp (car pf))
+ (message "Incomplete symbol name."))
+ ((semantic-tag-p (car pf))
+ ;; The `semantic-documentation-for-tag' fcn is language
+ ;; specific. If it doesn't return what you expect, you may
+ ;; need to implement something for your language.
+ ;;
+ ;; The default tries to find a comment in front of the tag
+ ;; and then strings off comment prefixes.
+ (let ((doc (semantic-documentation-for-tag (car pf))))
+ (with-output-to-temp-buffer "*TAG DOCUMENTATION*"
+ (princ "Tag: ")
+ (princ (semantic-format-tag-prototype (car pf)))
+ (princ "\n")
+ (princ "\n")
+ (princ "Snarfed Documentation: ")
+ (princ "\n")
+ (princ "\n")
+ (if doc
+ (princ doc)
+ (princ " Documentation unavailable."))
+ )))
+ (t
+ (message "Unknown tag.")))
+ ))
+
+(defun semantic-ia-describe-class (typename)
+ "Display all known parts for the datatype TYPENAME.
+If the type in question is a class, all methods and other accessible
+parts of the parent classes are displayed."
+ ;; @todo - use a fancy completing reader.
+ (interactive "sType Name: ")
+
+ ;; When looking for a tag of any name there are a couple ways to do
+ ;; it. The simple `semanticdb-find-tag-by-...' are simple, and
+ ;; you need to pass it the exact name you want.
+ ;;
+ ;; The analyzer function `semantic-analyze-tag-name' will take
+ ;; more complex names, such as the cpp symbol foo::bar::baz,
+ ;; and break it up, and dive through the namespaces.
+ (let ((class (semantic-analyze-find-tag typename)))
+
+ (when (not (semantic-tag-p class))
+ (error "Cannot find class %s" class))
+ (with-output-to-temp-buffer "*TAG DOCUMENTATION*"
+ ;; There are many semantic-format-tag-* fcns.
+ ;; The summarize routine is a fairly generic one.
+ (princ (semantic-format-tag-summarize class))
+ (princ "\n")
+ (princ " Type Members:\n")
+ ;; The type tag contains all the parts of the type.
+ ;; In complex languages with inheritance, not all the
+ ;; parts are in the tag. This analyzer fcn will traverse
+ ;; the inheritance tree, and find all the pieces that
+ ;; are inherited.
+ (let ((parts (semantic-analyze-scoped-type-parts class)))
+ (while parts
+ (princ " ")
+ (princ (semantic-format-tag-summarize (car parts)))
+ (princ "\n")
+ (setq parts (cdr parts)))
+ )
+ )))
+
+(provide 'semantic/ia)
+
+;;; semantic-ia.el ends here
--- /dev/null
+;;; tag-file.el --- Routines that find files based on tags.
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Keywords: syntax
+
+;; 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:
+;;
+;; A tag, by itself, can have representations in several files.
+;; These routines will find those files.
+
+(require 'semantic/tag)
+
+;;; Code:
+
+;;; Location a TAG came from.
+;;
+(define-overloadable-function semantic-go-to-tag (tag &optional parent)
+ "Go to the location of TAG.
+TAG may be a stripped element, in which case PARENT specifies a
+parent tag that has position information.
+PARENT can also be a `semanticdb-table' object."
+ (:override
+ (cond ((semantic-tag-in-buffer-p tag)
+ ;; We have a linked tag, go to that buffer.
+ (set-buffer (semantic-tag-buffer tag)))
+ ((semantic-tag-file-name tag)
+ ;; If it didn't have a buffer, but does have a file
+ ;; name, then we need to get to that file so the tag
+ ;; location is made accurate.
+ (set-buffer (find-file-noselect (semantic-tag-file-name tag))))
+ ((and parent (semantic-tag-p parent) (semantic-tag-in-buffer-p parent))
+ ;; The tag had nothing useful, but we have a parent with
+ ;; a buffer, then go there.
+ (set-buffer (semantic-tag-buffer parent)))
+ ((and parent (semantic-tag-p parent) (semantic-tag-file-name parent))
+ ;; Tag had nothing, and the parent only has a file-name, then
+ ;; find that file, and switch to that buffer.
+ (set-buffer (find-file-noselect (semantic-tag-file-name parent))))
+ ((and parent (semanticdb-table-child-p parent))
+ (set-buffer (semanticdb-get-buffer parent)))
+ (t
+ ;; Well, just assume things are in the current buffer.
+ nil
+ ))
+ ;; We should be in the correct buffer now, try and figure out
+ ;; where the tag is.
+ (cond ((semantic-tag-with-position-p tag)
+ ;; If it's a number, go there
+ (goto-char (semantic-tag-start tag)))
+ ((semantic-tag-with-position-p parent)
+ ;; Otherwise, it's a trimmed vector, such as a parameter,
+ ;; or a structure part. If there is a parent, we can use it
+ ;; as a bounds for searching.
+ (goto-char (semantic-tag-start parent))
+ ;; Here we make an assumption that the text returned by
+ ;; the parser and concocted by us actually exists
+ ;; in the buffer.
+ (re-search-forward (semantic-tag-name tag)
+ (semantic-tag-end parent)
+ t))
+ ((semantic-tag-get-attribute tag :line)
+ ;; The tag has a line number in it. Go there.
+ (goto-line (semantic-tag-get-attribute tag :line)))
+ ((and (semantic-tag-p parent) (semantic-tag-get-attribute parent :line))
+ ;; The tag has a line number in it. Go there.
+ (goto-line (semantic-tag-get-attribute parent :line))
+ (re-search-forward (semantic-tag-name tag) nil t)
+ )
+ (t
+ ;; Take a guess that the tag has a unique name, and just
+ ;; search for it from the beginning of the buffer.
+ (goto-char (point-min))
+ (re-search-forward (semantic-tag-name tag) nil t)))
+ )
+ )
+
+(make-obsolete-overload 'semantic-find-nonterminal
+ 'semantic-go-to-tag)
+
+;;; Dependencies
+;;
+;; A tag which is of type 'include specifies a dependency.
+;; Dependencies usually represent a file of some sort.
+;; Find the file described by a dependency.
+
+(define-overloadable-function semantic-dependency-tag-file (&optional tag)
+ "Find the filename represented from TAG.
+Depends on `semantic-dependency-include-path' for searching. Always searches
+`.' first, then searches additional paths."
+ (or tag (setq tag (car (semantic-find-tag-by-overlay nil))))
+ (unless (semantic-tag-of-class-p tag 'include)
+ (signal 'wrong-type-argument (list tag 'include)))
+ (save-excursion
+ (let ((result nil)
+ (default-directory default-directory)
+ (edefind nil)
+ (tag-fname nil))
+ (cond ((semantic-tag-in-buffer-p tag)
+ ;; If the tag has an overlay and buffer associated with it,
+ ;; switch to that buffer so that we get the right override metohds.
+ (set-buffer (semantic-tag-buffer tag)))
+ ((semantic-tag-file-name tag)
+ ;; If it didn't have a buffer, but does have a file
+ ;; name, then we need to get to that file so the tag
+ ;; location is made accurate.
+ ;;(set-buffer (find-file-noselect (semantic-tag-file-name tag)))
+ ;;
+ ;; 2/3/08
+ ;; The above causes unnecessary buffer loads all over the place. Ick!
+ ;; All we really need is for 'default-directory' to be set correctly.
+ (setq default-directory (file-name-directory (semantic-tag-file-name tag)))
+ ))
+ ;; Setup the filename represented by this include
+ (setq tag-fname (semantic-tag-include-filename tag))
+
+ ;; First, see if this file exists in the current EDE project
+ (if (and (fboundp 'ede-expand-filename) ede-minor-mode
+ (setq edefind
+ (condition-case nil
+ (let ((proj (ede-toplevel)))
+ (when proj
+ (ede-expand-filename proj tag-fname)))
+ (error nil))))
+ (setq result edefind))
+ (if (not result)
+ (setq result
+ ;; I don't have a plan for refreshing tags with a dependency
+ ;; stuck on them somehow. I'm thinking that putting a cache
+ ;; onto the dependancy finding with a hash table might be best.
+ ;;(if (semantic--tag-get-property tag 'dependency-file)
+ ;; (semantic--tag-get-property tag 'dependency-file)
+ (:override
+ (save-excursion
+ (semantic-dependency-find-file-on-path
+ tag-fname (semantic-tag-include-system-p tag))))
+ ;; )
+ ))
+ (if (stringp result)
+ (progn
+ (semantic--tag-put-property tag 'dependency-file result)
+ result)
+ ;; @todo: Do something to make this get flushed w/
+ ;; when the path is changed.
+ ;; @undo: Just eliminate
+ ;; (semantic--tag-put-property tag 'dependency-file 'none)
+ nil)
+ )))
+
+(make-obsolete-overload 'semantic-find-dependency
+ 'semantic-dependency-tag-file)
+
+;;; PROTOTYPE FILE
+;;
+;; In C, a function in the .c file often has a representation in a
+;; corresponding .h file. This routine attempts to find the
+;; prototype file a given source file would be associated with.
+;; This can be used by prototype manager programs.
+(define-overloadable-function semantic-prototype-file (buffer)
+ "Return a file in which prototypes belonging to BUFFER should be placed.
+Default behavior (if not overridden) looks for a token specifying the
+prototype file, or the existence of an EDE variable indicating which
+file prototypes belong in."
+ (:override
+ ;; Perform some default behaviors
+ (if (and (fboundp 'ede-header-file) ede-minor-mode)
+ (save-excursion
+ (set-buffer buffer)
+ (ede-header-file))
+ ;; No EDE options for a quick answer. Search.
+ (save-excursion
+ (set-buffer buffer)
+ (if (re-search-forward "::Header:: \\([a-zA-Z0-9.]+\\)" nil t)
+ (match-string 1))))))
+
+(semantic-alias-obsolete 'semantic-find-nonterminal
+ 'semantic-go-to-tag)
+
+(semantic-alias-obsolete 'semantic-find-dependency
+ 'semantic-dependency-tag-file)
+
+
+(provide 'semantic/tag-file)
+
+;;; semantic-tag-file.el ends here
--- /dev/null
+;;; tag-ls.el --- Language Specific override functions for tags
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008
+;;; 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:
+;;
+;; There are some features of tags that are too langauge dependent to
+;; put in the core `semantic-tag' functionality. For instance, the
+;; protection of a tag (as specified by UML) could be almost anything.
+;; In Java, it is a type specifier. In C, there is a label. This
+;; informatin can be derived, and thus should not be stored in the tag
+;; itself. These are the functions that languages can use to derive
+;; the information.
+
+(require 'semantic/tag)
+
+;;; Code:
+
+;;; UML features:
+;;
+;; UML can represent several types of features of a tag
+;; such as the `protection' of a symbol, or if it is abstract,
+;; leaf, etc. Learn about UML to catch onto the lingo.
+
+(define-overloadable-function semantic-tag-calculate-parent (tag)
+ "Attempt to calculate the parent of TAG.
+The default behavior (if not overriden with `tag-calculate-parent')
+is to search a buffer found with TAG, and if externally defined,
+search locally, then semanticdb for that tag (when enabled.)")
+
+(defun semantic-tag-calculate-parent-default (tag)
+ "Attempt to calculate the parent of TAG."
+ (when (semantic-tag-in-buffer-p tag)
+ (save-excursion
+ (set-buffer (semantic-tag-buffer tag))
+ (save-excursion
+ (goto-char (semantic-tag-start tag))
+ (semantic-current-tag-parent))
+ )))
+
+(define-overloadable-function semantic-tag-protection (tag &optional parent)
+ "Return protection information about TAG with optional PARENT.
+This function returns on of the following symbols:
+ nil - No special protection. Language dependent.
+ 'public - Anyone can access this TAG.
+ 'private - Only methods in the local scope can access TAG.
+ 'protected - Like private for outside scopes, like public for child
+ classes.
+Some languages may choose to provide additional return symbols specific
+to themselves. Use of this function should allow for this.
+
+The default behavior (if not overridden with `tag-protection'
+is to return a symbol based on type modifiers."
+ (and (not parent)
+ (semantic-tag-overlay tag)
+ (semantic-tag-in-buffer-p tag)
+ (setq parent (semantic-tag-calculate-parent tag)))
+ (:override))
+
+(make-obsolete-overload 'semantic-nonterminal-protection
+ 'semantic-tag-protection)
+
+(defun semantic-tag-protection-default (tag &optional parent)
+ "Return the protection of TAG as a child of PARENT default action.
+See `semantic-tag-protection'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (prot nil))
+ (while (and (not prot) mods)
+ (if (stringp (car mods))
+ (let ((s (car mods)))
+ (setq prot
+ ;; A few silly defaults to get things started.
+ (cond ((or (string= s "public")
+ (string= s "extern")
+ (string= s "export"))
+ 'public)
+ ((string= s "private")
+ 'private)
+ ((string= s "protected")
+ 'protected)))))
+ (setq mods (cdr mods)))
+ prot))
+
+(defun semantic-tag-protected-p (tag protection &optional parent)
+ "Non-nil if TAG is is protected.
+PROTECTION is a symbol which can be returned by the method
+`semantic-tag-protection'.
+PARENT is the parent data type which contains TAG.
+
+For these PROTECTIONs, true is returned if TAG is:
+@table @asis
+@item nil
+ Always true
+@item private
+ True if nil.
+@item protected
+ True if private or nil.
+@item public
+ True if private, protected, or nil.
+@end table"
+ (if (null protection)
+ t
+ (let ((tagpro (semantic-tag-protection tag parent)))
+ (or (and (eq protection 'private)
+ (null tagpro))
+ (and (eq protection 'protected)
+ (or (null tagpro)
+ (eq tagpro 'private)))
+ (and (eq protection 'public)
+ (not (eq tagpro 'public)))))
+ ))
+
+(define-overloadable-function semantic-tag-abstract-p (tag &optional parent)
+ "Return non nil if TAG is abstract.
+Optional PARENT is the parent tag of TAG.
+In UML, abstract methods and classes have special meaning and behavior
+in how methods are overridden. In UML, abstract methods are italicized.
+
+The default behavior (if not overridden with `tag-abstract-p'
+is to return true if `abstract' is in the type modifiers.")
+
+(make-obsolete-overload 'semantic-nonterminal-abstract
+ 'semantic-tag-abstract-p)
+
+(defun semantic-tag-abstract-p-default (tag &optional parent)
+ "Return non-nil if TAG is abstract as a child of PARENT default action.
+See `semantic-tag-abstract-p'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (abs nil))
+ (while (and (not abs) mods)
+ (if (stringp (car mods))
+ (setq abs (or (string= (car mods) "abstract")
+ (string= (car mods) "virtual"))))
+ (setq mods (cdr mods)))
+ abs))
+
+(define-overloadable-function semantic-tag-leaf-p (tag &optional parent)
+ "Return non nil if TAG is leaf.
+Optional PARENT is the parent tag of TAG.
+In UML, leaf methods and classes have special meaning and behavior.
+
+The default behavior (if not overridden with `tag-leaf-p'
+is to return true if `leaf' is in the type modifiers.")
+
+(make-obsolete-overload 'semantic-nonterminal-leaf
+ 'semantic-tag-leaf-p)
+
+(defun semantic-tag-leaf-p-default (tag &optional parent)
+ "Return non-nil if TAG is leaf as a child of PARENT default action.
+See `semantic-tag-leaf-p'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (leaf nil))
+ (while (and (not leaf) mods)
+ (if (stringp (car mods))
+ ;; Use java FINAL as example default. There is none
+ ;; for C/C++
+ (setq leaf (string= (car mods) "final")))
+ (setq mods (cdr mods)))
+ leaf))
+
+(define-overloadable-function semantic-tag-static-p (tag &optional parent)
+ "Return non nil if TAG is static.
+Optional PARENT is the parent tag of TAG.
+In UML, static methods and attributes mean that they are allocated
+in the parent class, and are not instance specific.
+UML notation specifies that STATIC entries are underlined.")
+
+(defun semantic-tag-static-p-default (tag &optional parent)
+ "Return non-nil if TAG is static as a child of PARENT default action.
+See `semantic-tag-static-p'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (static nil))
+ (while (and (not static) mods)
+ (if (stringp (car mods))
+ (setq static (string= (car mods) "static")))
+ (setq mods (cdr mods)))
+ static))
+
+(define-overloadable-function semantic-tag-prototype-p (tag)
+ "Return non nil if TAG is a prototype.
+For some laguages, such as C, a prototype is a declaration of
+something without an implementation."
+ )
+
+(defun semantic-tag-prototype-p-default (tag)
+ "Non-nil if TAG is a prototype."
+ (let ((p (semantic-tag-get-attribute tag :prototype-flag)))
+ (cond
+ ;; Trust the parser author.
+ (p p)
+ ;; Empty types might be a prototype.
+ ;; @todo - make this better.
+ ((eq (semantic-tag-class tag) 'type)
+ (not (semantic-tag-type-members tag)))
+ ;; No other heuristics.
+ (t nil))
+ ))
+
+;;; FULL NAMES
+;;
+;; For programmer convenience, a full name is not specified in source
+;; code. Instead some abbreviation is made, and the local environment
+;; will contain the info needed to determine the full name.
+
+(define-overloadable-function semantic-tag-full-name (tag &optional stream-or-buffer)
+ "Return the fully qualified name of TAG in the package hierarchy.
+STREAM-OR-BUFFER can be anything convertable by `semantic-something-to-stream',
+but must be a toplevel semantic tag stream that contains TAG.
+A Package Hierarchy is defined in UML by the way classes and methods
+are organized on disk. Some language use this concept such that a
+class can be accessed via it's fully qualified name, (such as Java.)
+Other languages qualify names within a Namespace (such as C++) which
+result in a different package like structure. Languages which do not
+override this function with `tag-full-name' will use
+`semantic-tag-name'. Override functions only need to handle
+STREAM-OR-BUFFER with a tag stream value, or nil."
+ (let ((stream (semantic-something-to-tag-table
+ (or stream-or-buffer tag))))
+ (:override-with-args (tag stream))))
+
+(make-obsolete-overload 'semantic-nonterminal-full-name
+ 'semantic-tag-full-name)
+
+(defun semantic-tag-full-name-default (tag stream)
+ "Default method for `semantic-tag-full-name'.
+Return the name of TAG found in the toplevel STREAM."
+ (semantic-tag-name tag))
+
+;;; Compatibility aliases.
+;;
+(semantic-alias-obsolete 'semantic-nonterminal-protection
+ 'semantic-tag-protection)
+(semantic-alias-obsolete 'semantic-nonterminal-protection-default
+ 'semantic-tag-protection-default)
+(semantic-alias-obsolete 'semantic-nonterminal-abstract
+ 'semantic-tag-abstract-p)
+(semantic-alias-obsolete 'semantic-nonterminal-abstract-default
+ 'semantic-tag-abstract-p-default)
+(semantic-alias-obsolete 'semantic-nonterminal-leaf
+ 'semantic-tag-leaf-p)
+(semantic-alias-obsolete 'semantic-nonterminal-leaf-default
+ 'semantic-tag-leaf-p-default)
+(semantic-alias-obsolete 'semantic-nonterminal-static-default
+ 'semantic-tag-static-p-default)
+(semantic-alias-obsolete 'semantic-nonterminal-full-name
+ 'semantic-tag-full-name)
+(semantic-alias-obsolete 'semantic-nonterminal-full-name-default
+ 'semantic-tag-full-name-default)
+
+;; TEMPORARY within betas of CEDET 1.0
+(semantic-alias-obsolete 'semantic-tag-static 'semantic-tag-static-p)
+(semantic-alias-obsolete 'semantic-tag-leaf 'semantic-tag-leaf-p)
+(semantic-alias-obsolete 'semantic-tag-abstract 'semantic-tag-abstract-p)
+
+
+(provide 'semantic/tag-ls)
+
+;;; semantic-tag-ls.el ends here
projects / emacs.git / commitdiff