diff options
author | Chong Yidong <cyd@stupidchicken.com> | 2009-08-29 19:32:33 +0000 |
---|---|---|
committer | Chong Yidong <cyd@stupidchicken.com> | 2009-08-29 19:32:33 +0000 |
commit | f273dfc6ffeef2b3e3cbd1779cd3a6089858622c (patch) | |
tree | ed8eddfd22c7382995ad09a342535d8b2874a59f /lisp/cedet/semantic | |
parent | 9573e58b233ac4210a2801b1263f39843d4e48a0 (diff) | |
download | emacs-f273dfc6ffeef2b3e3cbd1779cd3a6089858622c.tar.gz |
cedet/semantic/adebug.el, cedet/semantic/chart.el,
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.
Diffstat (limited to 'lisp/cedet/semantic')
-rw-r--r-- | lisp/cedet/semantic/adebug.el | 423 | ||||
-rw-r--r-- | lisp/cedet/semantic/chart.el | 167 | ||||
-rw-r--r-- | lisp/cedet/semantic/db-debug.el | 108 | ||||
-rw-r--r-- | lisp/cedet/semantic/db-ebrowse.el | 706 | ||||
-rw-r--r-- | lisp/cedet/semantic/db-el.el | 343 | ||||
-rw-r--r-- | lisp/cedet/semantic/db-file.el | 438 | ||||
-rw-r--r-- | lisp/cedet/semantic/db-javascript.el | 310 | ||||
-rw-r--r-- | lisp/cedet/semantic/db-search.el | 451 | ||||
-rw-r--r-- | lisp/cedet/semantic/db-typecache.el | 585 | ||||
-rw-r--r-- | lisp/cedet/semantic/dep.el | 228 | ||||
-rw-r--r-- | lisp/cedet/semantic/ia.el | 439 | ||||
-rw-r--r-- | lisp/cedet/semantic/tag-file.el | 202 | ||||
-rw-r--r-- | lisp/cedet/semantic/tag-ls.el | 276 |
13 files changed, 4676 insertions, 0 deletions
diff --git a/lisp/cedet/semantic/adebug.el b/lisp/cedet/semantic/adebug.el new file mode 100644 index 00000000000..fe8e71b82e8 --- /dev/null +++ b/lisp/cedet/semantic/adebug.el @@ -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 diff --git a/lisp/cedet/semantic/chart.el b/lisp/cedet/semantic/chart.el new file mode 100644 index 00000000000..95c60a51365 --- /dev/null +++ b/lisp/cedet/semantic/chart.el @@ -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 diff --git a/lisp/cedet/semantic/db-debug.el b/lisp/cedet/semantic/db-debug.el new file mode 100644 index 00000000000..6db1cbfaae9 --- /dev/null +++ b/lisp/cedet/semantic/db-debug.el @@ -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 diff --git a/lisp/cedet/semantic/db-ebrowse.el b/lisp/cedet/semantic/db-ebrowse.el new file mode 100644 index 00000000000..3302afd83da --- /dev/null +++ b/lisp/cedet/semantic/db-ebrowse.el @@ -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 diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el new file mode 100644 index 00000000000..3db6c15570e --- /dev/null +++ b/lisp/cedet/semantic/db-el.el @@ -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 diff --git a/lisp/cedet/semantic/db-file.el b/lisp/cedet/semantic/db-file.el new file mode 100644 index 00000000000..a16f9bbf14a --- /dev/null +++ b/lisp/cedet/semantic/db-file.el @@ -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 diff --git a/lisp/cedet/semantic/db-javascript.el b/lisp/cedet/semantic/db-javascript.el new file mode 100644 index 00000000000..dca2c38d4a6 --- /dev/null +++ b/lisp/cedet/semantic/db-javascript.el @@ -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 diff --git a/lisp/cedet/semantic/db-search.el b/lisp/cedet/semantic/db-search.el new file mode 100644 index 00000000000..acfb788fe16 --- /dev/null +++ b/lisp/cedet/semantic/db-search.el @@ -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 diff --git a/lisp/cedet/semantic/db-typecache.el b/lisp/cedet/semantic/db-typecache.el new file mode 100644 index 00000000000..689e6d903f0 --- /dev/null +++ b/lisp/cedet/semantic/db-typecache.el @@ -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 diff --git a/lisp/cedet/semantic/dep.el b/lisp/cedet/semantic/dep.el new file mode 100644 index 00000000000..4c67c6674f2 --- /dev/null +++ b/lisp/cedet/semantic/dep.el @@ -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 diff --git a/lisp/cedet/semantic/ia.el b/lisp/cedet/semantic/ia.el new file mode 100644 index 00000000000..eadf89439ab --- /dev/null +++ b/lisp/cedet/semantic/ia.el @@ -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 diff --git a/lisp/cedet/semantic/tag-file.el b/lisp/cedet/semantic/tag-file.el new file mode 100644 index 00000000000..4187d3c0302 --- /dev/null +++ b/lisp/cedet/semantic/tag-file.el @@ -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 diff --git a/lisp/cedet/semantic/tag-ls.el b/lisp/cedet/semantic/tag-ls.el new file mode 100644 index 00000000000..634c41cf093 --- /dev/null +++ b/lisp/cedet/semantic/tag-ls.el @@ -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 |