mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-28 08:11:05 -08:00
Code Issues Projects Releases Wiki Activity

cedet/semantic/adebug.el, cedet/semantic/chart.el,

Browse source 
cedet/semantic/db-debug.el, cedet/semantic/db-ebrowse.el,
cedet/semantic/db-el.el, cedet/semantic/db-file.el,
cedet/semantic/db-javascript.el, cedet/semantic/db-search.el,
cedet/semantic/db-typecache.el, cedet/semantic/dep.el,
cedet/semantic/ia.el, cedet/semantic/tag-file.el,
cedet/semantic/tag-ls.el: New files.
This commit is contained in:
Chong Yidong 2009-08-29 19:32:33 +00:00
parent 9573e58b23
commit f273dfc6ff
13 changed files with 4676 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

423
lisp/cedet/semantic/adebug.el Normal file
View file

@ -0,0 +1,423 @@
;;; 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

167
lisp/cedet/semantic/chart.el Normal file
View file

@ -0,0 +1,167 @@
;;; 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

108
lisp/cedet/semantic/db-debug.el Normal file
View file

@ -0,0 +1,108 @@
;;; 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 "*")))
;;; 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

706
lisp/cedet/semantic/db-ebrowse.el Normal file
View file

@ -0,0 +1,706 @@
;;; 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

343
lisp/cedet/semantic/db-el.el Normal file
View file

@ -0,0 +1,343 @@
;;; 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

438
lisp/cedet/semantic/db-file.el Normal file
View file

@ -0,0 +1,438 @@
;;; 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

310
lisp/cedet/semantic/db-javascript.el Normal file
View file

@ -0,0 +1,310 @@
;;; 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

451
lisp/cedet/semantic/db-search.el Normal file
View file

@ -0,0 +1,451 @@
;;; 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

585
lisp/cedet/semantic/db-typecache.el Normal file
View file

@ -0,0 +1,585 @@
;;; 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:
;;; 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)))
;;; 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)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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))))
;;; 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)
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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
))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)))
;;; 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

228
lisp/cedet/semantic/dep.el Normal file
View file

@ -0,0 +1,228 @@
;;; 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

439
lisp/cedet/semantic/ia.el Normal file
View file

@ -0,0 +1,439 @@
;;; 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

202
lisp/cedet/semantic/tag-file.el Normal file
View file

@ -0,0 +1,202 @@
;;; 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

276
lisp/cedet/semantic/tag-ls.el Normal file
View file

@ -0,0 +1,276 @@
;;; 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