aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
authorChong Yidong2009-08-29 19:32:33 +0000
committerChong Yidong2009-08-29 19:32:33 +0000
commitf273dfc6ffeef2b3e3cbd1779cd3a6089858622c (patch)
treeed8eddfd22c7382995ad09a342535d8b2874a59f /lisp
parent9573e58b233ac4210a2801b1263f39843d4e48a0 (diff)
downloademacs-f273dfc6ffeef2b3e3cbd1779cd3a6089858622c.tar.gz
emacs-f273dfc6ffeef2b3e3cbd1779cd3a6089858622c.zip
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')
-rw-r--r--lisp/cedet/semantic/adebug.el423
-rw-r--r--lisp/cedet/semantic/chart.el167
-rw-r--r--lisp/cedet/semantic/db-debug.el108
-rw-r--r--lisp/cedet/semantic/db-ebrowse.el706
-rw-r--r--lisp/cedet/semantic/db-el.el343
-rw-r--r--lisp/cedet/semantic/db-file.el438
-rw-r--r--lisp/cedet/semantic/db-javascript.el310
-rw-r--r--lisp/cedet/semantic/db-search.el451
-rw-r--r--lisp/cedet/semantic/db-typecache.el585
-rw-r--r--lisp/cedet/semantic/dep.el228
-rw-r--r--lisp/cedet/semantic/ia.el439
-rw-r--r--lisp/cedet/semantic/tag-file.el202
-rw-r--r--lisp/cedet/semantic/tag-ls.el276
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 @@
1;;; adebug.el --- Semantic Application Debugger
2
3;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <zappo@gnu.org>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Semantic datastructure debugger for semantic applications.
25;; Uses data-debug for core implementation.
26;;
27;; Goals:
28;;
29;; Inspect all known details of a TAG in a buffer.
30;;
31;; Analyze the list of active semantic databases, and the tags therin.
32;;
33;; Allow interactive navigation of the analysis process, tags, etc.
34
35(require 'data-debug)
36(require 'eieio-datadebug)
37(require 'semantic/analyze)
38
39;;; Code:
40
41;;; SEMANTIC TAG STUFF
42;;
43(defun data-debug-insert-tag-parts (tag prefix &optional parent)
44 "Insert all the parts of TAG.
45PREFIX specifies what to insert at the start of each line.
46PARENT specifires any parent tag."
47 (data-debug-insert-thing (semantic-tag-name tag)
48 prefix
49 "Name: "
50 parent)
51 (insert prefix "Class: '" (format "%S" (semantic-tag-class tag)) "\n")
52 (when (semantic-tag-with-position-p tag)
53 (let ((ol (semantic-tag-overlay tag))
54 (file (semantic-tag-file-name tag))
55 (start (semantic-tag-start tag))
56 (end (semantic-tag-end tag))
57 )
58 (insert prefix "Position: "
59 (if (and (numberp start) (numberp end))
60 (format "%d -> %d in " start end)
61 "")
62 (if file (file-name-nondirectory file) "unknown-file")
63 (if (semantic-overlay-p ol)
64 " <live tag>"
65 "")
66 "\n")
67 (data-debug-insert-thing ol prefix
68 "Position Data: "
69 parent)
70 ))
71 (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")))
72 (insert prefix "Attributes:\n")
73 (data-debug-insert-property-list
74 (semantic-tag-attributes tag) attrprefix tag)
75 (insert prefix "Properties:\n")
76 (data-debug-insert-property-list
77 (semantic-tag-properties tag) attrprefix tag)
78 )
79
80 )
81
82(defun data-debug-insert-tag-parts-from-point (point)
83 "Call `data-debug-insert-tag-parts' based on text properties at POINT."
84 (let ((tag (get-text-property point 'ddebug))
85 (parent (get-text-property point 'ddebug-parent))
86 (indent (get-text-property point 'ddebug-indent))
87 start
88 )
89 (end-of-line)
90 (setq start (point))
91 (forward-char 1)
92 (data-debug-insert-tag-parts tag
93 (concat (make-string indent ? )
94 "| ")
95 parent)
96 (goto-char start)
97 ))
98
99(defun data-debug-insert-tag (tag prefix prebuttontext &optional parent)
100 "Insert TAG into the current buffer at the current point.
101PREFIX specifies text to insert in front of TAG.
102PREBUTTONTEXT is text appearing btewen the prefix and TAG.
103Optional PARENT is the parent tag containing TAG.
104Add text properties needed to allow tag expansion later."
105 (let ((start (point))
106 (end nil)
107 (str (semantic-format-tag-uml-abbreviate tag parent t))
108 (tip (semantic-format-tag-prototype tag parent t))
109 )
110 (insert prefix prebuttontext str "\n")
111 (setq end (point))
112 (put-text-property start end 'ddebug tag)
113 (put-text-property start end 'ddebug-parent parent)
114 (put-text-property start end 'ddebug-indent(length prefix))
115 (put-text-property start end 'ddebug-prefix prefix)
116 (put-text-property start end 'help-echo tip)
117 (put-text-property start end 'ddebug-function
118 'data-debug-insert-tag-parts-from-point)
119
120 ))
121
122;;; TAG LISTS
123;;
124(defun data-debug-insert-tag-list (taglist prefix &optional parent)
125 "Insert the tag list TAGLIST with PREFIX.
126Optional argument PARENT specifies the part of TAGLIST."
127 (condition-case nil
128 (while taglist
129 (cond ((and (consp taglist) (semantic-tag-p (car taglist)))
130 (data-debug-insert-tag (car taglist) prefix "" parent))
131 ((consp taglist)
132 (data-debug-insert-thing (car taglist) prefix "" parent))
133 (t (data-debug-insert-thing taglist prefix "" parent)))
134 (setq taglist (cdr taglist)))
135 (error nil)))
136
137(defun data-debug-insert-taglist-from-point (point)
138 "Insert the taglist found at the taglist button at POINT."
139 (let ((taglist (get-text-property point 'ddebug))
140 (parent (get-text-property point 'ddebug-parent))
141 (indent (get-text-property point 'ddebug-indent))
142 start
143 )
144 (end-of-line)
145 (setq start (point))
146 (forward-char 1)
147 (data-debug-insert-tag-list taglist
148 (concat (make-string indent ? )
149 "* ")
150 parent)
151 (goto-char start)
152
153 ))
154
155(defun data-debug-insert-tag-list-button (taglist prefix prebuttontext &optional parent)
156 "Insert a single summary of a TAGLIST.
157PREFIX is the text that preceeds the button.
158PREBUTTONTEXT is some text between PREFIX and the taglist button.
159PARENT is the tag that represents the parent of all the tags."
160 (let ((start (point))
161 (end nil)
162 (str (format "#<TAG LIST: %d entries>" (safe-length taglist)))
163 (tip nil))
164 (insert prefix prebuttontext str)
165 (setq end (point))
166 (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face)
167 (put-text-property start end 'ddebug taglist)
168 (put-text-property start end 'ddebug-parent parent)
169 (put-text-property start end 'ddebug-indent(length prefix))
170 (put-text-property start end 'ddebug-prefix prefix)
171 (put-text-property start end 'help-echo tip)
172 (put-text-property start end 'ddebug-function
173 'data-debug-insert-taglist-from-point)
174 (insert "\n")
175 ))
176
177;;; SEMANTICDB FIND RESULTS
178;;
179(defun data-debug-insert-find-results (findres prefix)
180 "Insert the find results FINDRES with PREFIX."
181 ;; ( (DBOBJ TAG TAG TAG) (DBOBJ TAG TAG TAG) ... )
182 (let ((cnt 1))
183 (while findres
184 (let* ((dbhit (car findres))
185 (db (car dbhit))
186 (tags (cdr dbhit)))
187 (data-debug-insert-thing db prefix (format "DB %d: " cnt))
188 (data-debug-insert-thing tags prefix (format "HITS %d: " cnt))
189 )
190 (setq findres (cdr findres)
191 cnt (1+ cnt)))))
192
193(defun data-debug-insert-find-results-from-point (point)
194 "Insert the find results found at the find results button at POINT."
195 (let ((findres (get-text-property point 'ddebug))
196 (indent (get-text-property point 'ddebug-indent))
197 start
198 )
199 (end-of-line)
200 (setq start (point))
201 (forward-char 1)
202 (data-debug-insert-find-results findres
203 (concat (make-string indent ? )
204 "!* ")
205 )
206 (goto-char start)
207 ))
208
209(defun data-debug-insert-find-results-button (findres prefix prebuttontext)
210 "Insert a single summary of a find results FINDRES.
211PREFIX is the text that preceeds the button.
212PREBUTTONTEXT is some text between prefix and the find results button."
213 (let ((start (point))
214 (end nil)
215 (str (semanticdb-find-result-prin1-to-string findres))
216 (tip nil))
217 (insert prefix prebuttontext str)
218 (setq end (point))
219 (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face)
220 (put-text-property start end 'ddebug findres)
221 (put-text-property start end 'ddebug-indent(length prefix))
222 (put-text-property start end 'ddebug-prefix prefix)
223 (put-text-property start end 'help-echo tip)
224 (put-text-property start end 'ddebug-function
225 'data-debug-insert-find-results-from-point)
226 (insert "\n")
227 ))
228
229(defun data-debug-insert-db-and-tag-button (dbtag prefix prebuttontext)
230 "Insert a single summary of short list DBTAG of format (DB . TAG).
231PREFIX is the text that preceeds the button.
232PREBUTTONTEXT is some text between prefix and the find results button."
233 (let ((start (point))
234 (end nil)
235 (str (concat "(#<db/tag "
236 (object-name-string (car dbtag))
237 " / "
238 (semantic-format-tag-name (cdr dbtag) nil t)
239 ")"))
240 (tip nil))
241 (insert prefix prebuttontext str)
242 (setq end (point))
243 (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face)
244 (put-text-property start end 'ddebug dbtag)
245 (put-text-property start end 'ddebug-indent(length prefix))
246 (put-text-property start end 'ddebug-prefix prefix)
247 (put-text-property start end 'help-echo tip)
248 (put-text-property start end 'ddebug-function
249 'data-debug-insert-db-and-tag-from-point)
250 (insert "\n")
251 ))
252
253(defun data-debug-insert-db-and-tag-from-point (point)
254 "Insert the find results found at the find results button at POINT."
255 (let ((dbtag (get-text-property point 'ddebug))
256 (indent (get-text-property point 'ddebug-indent))
257 start
258 )
259 (end-of-line)
260 (setq start (point))
261 (forward-char 1)
262 (data-debug-insert-thing (car dbtag) (make-string indent ? )
263 "| DB ")
264 (data-debug-insert-tag (cdr dbtag) (concat (make-string indent ? )
265 "| ")
266 "TAG ")
267 (goto-char start)
268 ))
269
270;;; DEBUG COMMANDS
271;;
272;; Various commands to output aspects of the current semantic environment.
273(defun semantic-adebug-bovinate ()
274 "The same as `bovinate'. Display the results in a debug buffer."
275 (interactive)
276 (let* ((start (current-time))
277 (out (semantic-fetch-tags))
278 (end (current-time)))
279
280 (message "Retrieving tags took %.2f seconds."
281 (semantic-elapsed-time start end))
282
283 (data-debug-new-buffer (concat "*" (buffer-name) " ADEBUG*"))
284 (data-debug-insert-tag-list out "* "))
285 )
286
287(defun semantic-adebug-searchdb (regex)
288 "Search the semanticdb for REGEX for the current buffer.
289Display the results as a debug list."
290 (interactive "sSymbol Regex: ")
291 (let ((start (current-time))
292 (fr (semanticdb-find-tags-by-name-regexp regex))
293 (end (current-time)))
294
295 (data-debug-new-buffer (concat "*SEMANTICDB SEARCH: "
296 regex
297 " ADEBUG*"))
298 (message "Search of tags took %.2f seconds."
299 (semantic-elapsed-time start end))
300
301 (data-debug-insert-find-results fr "*")))
302
303(defun semantic-adebug-analyze (&optional ctxt)
304 "Perform `semantic-analyze-current-context'.
305Display the results as a debug list.
306Optional argument CTXT is the context to show."
307 (interactive)
308 (let ((start (current-time))
309 (ctxt (or ctxt (semantic-analyze-current-context)))
310 (end (current-time)))
311 (if (not ctxt)
312 (message "No Analyzer Results")
313 (message "Analysis took %.2f seconds."
314 (semantic-elapsed-time start end))
315 (semantic-analyze-pulse ctxt)
316 (if ctxt
317 (progn
318 (data-debug-new-buffer "*Analyzer ADEBUG*")
319 (data-debug-insert-object-slots ctxt "]"))
320 (message "No Context to analyze here.")))))
321
322(defun semantic-adebug-edebug-expr (expr)
323 "Dump out the contets of some expression EXPR in edebug with adebug."
324 (interactive "sExpression: ")
325 (let ((v (eval (read expr))))
326 (if (not v)
327 (message "Expression %s is nil." expr)
328 (data-debug-new-buffer "*expression ADEBUG*")
329 (data-debug-insert-thing v "?" "")
330 )))
331
332(defun semanticdb-debug-file-tag-check (startfile)
333 "Report debug info for checking STARTFILE for up-to-date tags."
334 (interactive "FFile to Check (default = current-buffer): ")
335 (let* ((file (file-truename startfile))
336 (default-directory (file-name-directory file))
337 (db (or
338 ;; This line will pick up system databases.
339 (semanticdb-directory-loaded-p default-directory)
340 ;; this line will make a new one if needed.
341 (semanticdb-get-database default-directory)))
342 (tab (semanticdb-file-table db file))
343 )
344 (with-output-to-temp-buffer "*DEBUG STUFF*"
345 (princ "Starting file is: ")
346 (princ startfile)
347 (princ "\nTrueName is: ")
348 (princ file)
349 (when (not (file-exists-p file))
350 (princ "\nFile does not exist!"))
351 (princ "\nDirectory Part is: ")
352 (princ default-directory)
353 (princ "\nFound Database is: ")
354 (princ (object-print db))
355 (princ "\nFound Table is: ")
356 (if tab (princ (object-print tab)) (princ "nil"))
357 (princ "\n\nAction Summary: ")
358 (cond
359 ((and tab
360 ;; Is this in a buffer?
361 (find-buffer-visiting (semanticdb-full-filename tab))
362 )
363 (princ "Found Buffer: ")
364 (prin1 (find-buffer-visiting (semanticdb-full-filename tab)))
365 )
366 ((and tab
367 ;; Is table fully loaded, or just a proxy?
368 (number-or-marker-p (oref tab pointmax))
369 ;; Is this table up to date with the file?
370 (not (semanticdb-needs-refresh-p tab)))
371 (princ "Found table, no refresh needed.\n Pointmax is: ")
372 (prin1 (oref tab pointmax))
373 )
374 (t
375 (princ "Found table that needs refresh.")
376 (if (not tab)
377 (princ "\n No Saved Point.")
378 (princ "\n Saved pointmax: ")
379 (prin1 (oref tab pointmax))
380 (princ " Needs Refresh: ")
381 (prin1 (semanticdb-needs-refresh-p tab))
382 )
383 ))
384 ;; Buffer isn't loaded. The only clue we have is if the file
385 ;; is somehow different from our mark in the semanticdb table.
386 (let* ((stats (file-attributes file))
387 (actualsize (nth 7 stats))
388 (actualmod (nth 5 stats))
389 )
390
391 (if (or (not tab)
392 (not (slot-boundp tab 'tags))
393 (not (oref tab tags)))
394 (princ "\n No tags in table.")
395 (princ "\n Number of known tags: ")
396 (prin1 (length (oref tab tags))))
397
398 (princ "\n File Size is: ")
399 (prin1 actualsize)
400 (princ "\n File Mod Time is: ")
401 (princ (format-time-string "%Y-%m-%d %T" actualmod))
402 (when tab
403 (princ "\n Saved file size is: ")
404 (prin1 (oref tab fsize))
405 (princ "\n Saved Mod time is: ")
406 (princ (format-time-string "%Y-%m-%d %T"
407 (oref tab lastmodtime)))
408 )
409 )
410 )
411 ;; Force load
412 (semanticdb-file-table-object file)
413 nil
414 ))
415
416;; (semanticdb-debug-file-tag-check "/usr/lib/gcc/i486-linux-gnu/4.2/include/stddef.h")
417;; (semanticdb-debug-file-tag-check "/usr/include/stdlib.h")
418
419
420
421(provide 'semantic/adebug)
422
423;;; 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 @@
1;;; chart.el --- Utilities for use with semantic tag tables
2
3;;; Copyright (C) 1999, 2000, 2001, 2003, 2005, 2008, 2009
4;;; Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; A set of simple functions for charting details about a file based on
26;; the output of the semantic parser.
27;;
28
29(require 'semantic)
30(require 'chart)
31
32;;; Code:
33
34(defun semantic-chart-tags-by-class (&optional tagtable)
35 "Create a bar chart representing the number of tags for a given tag class.
36Each bar represents how many toplevel tags in TAGTABLE
37exist with a given class. See `semantic-symbol->name-assoc-list'
38for tokens which will be charted.
39TAGTABLE is passedto `semantic-something-to-tag-table'."
40 (interactive)
41 (let* ((stream (semantic-something-to-tag-table
42 (or tagtable (current-buffer))))
43 (names (mapcar 'cdr semantic-symbol->name-assoc-list))
44 (nums (mapcar
45 (lambda (symname)
46 (length
47 (semantic-brute-find-tag-by-class (car symname)
48 stream)
49 ))
50 semantic-symbol->name-assoc-list)))
51 (chart-bar-quickie 'vertical
52 "Semantic Toplevel Tag Volume"
53 names "Tag Class"
54 nums "Volume")
55 ))
56
57(defun semantic-chart-database-size (&optional tagtable)
58 "Create a bar chart representing the size of each file in semanticdb.
59Each bar represents how many toplevel tags in TAGTABLE
60exist in each database entry.
61TAGTABLE is passed to `semantic-something-to-tag-table'."
62 (interactive)
63 (if (or (not (fboundp 'semanticdb-minor-mode-p))
64 (not (semanticdb-minor-mode-p)))
65 (error "Semanticdb is not enabled"))
66 (let* ((db semanticdb-current-database)
67 (dbt (semanticdb-get-database-tables db))
68 (names (mapcar 'car
69 (object-assoc-list
70 'file
71 dbt)))
72 (numnuts (mapcar (lambda (dba)
73 (prog1
74 (cons
75 (if (slot-boundp dba 'tags)
76 (length (oref dba tags))
77 1)
78 (car names))
79 (setq names (cdr names))))
80 dbt))
81 (nums nil)
82 (fh (/ (- (frame-height) 7) 4)))
83 (setq numnuts (sort numnuts (lambda (a b) (> (car a) (car b)))))
84 (setq names (mapcar 'cdr numnuts)
85 nums (mapcar 'car numnuts))
86 (if (> (length names) fh)
87 (progn
88 (setcdr (nthcdr fh names) nil)
89 (setcdr (nthcdr fh nums) nil)))
90 (chart-bar-quickie 'horizontal
91 "Semantic DB Toplevel Tag Volume"
92 names "File"
93 nums "Volume")
94 ))
95
96(defun semantic-chart-token-complexity (tok)
97 "Calculate the `complexity' of token TOK."
98 (count-lines
99 (semantic-tag-end tok)
100 (semantic-tag-start tok)))
101
102(defun semantic-chart-tag-complexity
103 (&optional class tagtable)
104 "Create a bar chart representing the complexity of some tags.
105Complexity is calculated for tags of CLASS. Each bar represents
106the complexity of some tag in TAGTABLE. Only the most complex
107items are charted. TAGTABLE is passedto
108`semantic-something-to-tag-table'."
109 (interactive)
110 (let* ((sym (if (not class) 'function))
111 (stream
112 (semantic-find-tags-by-class
113 sym (semantic-something-to-tag-table (or tagtable
114 (current-buffer)))
115 ))
116 (name (cond ((semantic-tag-with-position-p (car stream))
117 (buffer-name (semantic-tag-buffer (car stream))))
118 (t "")))
119 (cplx (mapcar (lambda (tok)
120 (cons tok (semantic-chart-token-complexity tok)))
121 stream))
122 (namelabel (cdr (assoc 'function semantic-symbol->name-assoc-list)))
123 (names nil)
124 (nums nil))
125 (setq cplx (sort cplx (lambda (a b) (> (cdr a) (cdr b)))))
126 (while (and cplx (<= (length names) (/ (- (frame-height) 7) 4)))
127 (setq names (cons (semantic-tag-name (car (car cplx)))
128 names)
129 nums (cons (cdr (car cplx)) nums)
130 cplx (cdr cplx)))
131;; ;; (setq names (mapcar (lambda (str)
132;; ;; (substring str (- (length str) 10)))
133;; ;; names))
134 (chart-bar-quickie 'horizontal
135 (format "%s Complexity in %s"
136 (capitalize (symbol-name sym))
137 name)
138 names namelabel
139 nums "Complexity (Lines of code)")
140 ))
141
142(defun semantic-chart-analyzer ()
143 "Chart the extent of the context analysis."
144 (interactive)
145 (let* ((p (semanticdb-find-translate-path nil nil))
146 (plen (length p))
147 (tab semanticdb-current-table)
148 (tc (semanticdb-get-typecache tab))
149 (tclen (+ (length (oref tc filestream))
150 (length (oref tc includestream))))
151 (scope (semantic-calculate-scope))
152 (fslen (length (oref scope fullscope)))
153 (lvarlen (length (oref scope localvar)))
154 )
155 (chart-bar-quickie 'vertical
156 (format "Analyzer Overhead in %s" (buffer-name))
157 '("includes" "typecache" "scopelen" "localvar")
158 "Overhead Entries"
159 (list plen tclen fslen lvarlen)
160 "Number of tags")
161 ))
162
163
164
165(provide 'semantic/chart)
166
167;;; 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 @@
1;;; db-debug.el --- Extra level debugging routines for Semantic
2
3;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Various routines for debugging SemanticDB issues, or viewing
25;; semanticdb state.
26
27(require 'semantic/db)
28
29;;; Code:
30;;
31(defun semanticdb-dump-all-table-summary ()
32 "Dump a list of all databases in Emacs memory."
33 (interactive)
34 (require 'data-debug)
35 (let ((db semanticdb-database-list))
36 (data-debug-new-buffer "*SEMANTICDB*")
37 (data-debug-insert-stuff-list db "*")))
38
39(defalias 'semanticdb-adebug-database-list 'semanticdb-dump-all-table-summary)
40
41(defun semanticdb-adebug-current-database ()
42 "Run ADEBUG on the current database."
43 (interactive)
44 (require 'data-debug)
45 (let ((p semanticdb-current-database)
46 )
47 (data-debug-new-buffer "*SEMANTICDB ADEBUG*")
48 (data-debug-insert-stuff-list p "*")))
49
50(defun semanticdb-adebug-current-table ()
51 "Run ADEBUG on the current database."
52 (interactive)
53 (require 'data-debug)
54 (let ((p semanticdb-current-table))
55 (data-debug-new-buffer "*SEMANTICDB ADEBUG*")
56 (data-debug-insert-stuff-list p "*")))
57
58
59(defun semanticdb-adebug-project-database-list ()
60 "Run ADEBUG on the current database."
61 (interactive)
62 (require 'data-debug)
63 (let ((p (semanticdb-current-database-list)))
64 (data-debug-new-buffer "*SEMANTICDB ADEBUG*")
65 (data-debug-insert-stuff-list p "*")))
66
67
68
69;;; Sanity Checks
70;;
71
72(defun semanticdb-table-oob-sanity-check (cache)
73 "Validate that CACHE tags do not have any overlays in them."
74 (while cache
75 (when (semantic-overlay-p (semantic-tag-overlay cache))
76 (message "Tag %s has an erroneous overlay!"
77 (semantic-format-tag-summarize (car cache))))
78 (semanticdb-table-oob-sanity-check
79 (semantic-tag-components-with-overlays (car cache)))
80 (setq cache (cdr cache))))
81
82(defun semanticdb-table-sanity-check (&optional table)
83 "Validate the current semanticdb TABLE."
84 (interactive)
85 (if (not table) (setq table semanticdb-current-table))
86 (let* ((full-filename (semanticdb-full-filename table))
87 (buff (find-buffer-visiting full-filename)))
88 (if buff
89 (save-excursion
90 (set-buffer buff)
91 (semantic-sanity-check))
92 ;; We can't use the usual semantic validity check, so hack our own.
93 (semanticdb-table-oob-sanity-check (semanticdb-get-tags table)))))
94
95(defun semanticdb-database-sanity-check ()
96 "Validate the current semantic database."
97 (interactive)
98 (let ((tables (semanticdb-get-database-tables
99 semanticdb-current-database)))
100 (while tables
101 (semanticdb-table-sanity-check (car tables))
102 (setq tables (cdr tables)))
103 ))
104
105
106
107(provide 'semantic/db-debug)
108;;; 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 @@
1;;; db-ebrowse.el --- Semanticdb backend using ebrowse.
2
3;;; Copyright (C) 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Authors: Eric M. Ludlam <zappo@gnu.org>, Joakim Verona
6;; Keywords: tags
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; This program was started by Eric Ludlam, and Joakim Verona finished
26;; the implementation by adding searches and fixing bugs.
27;;
28;; Read in custom-created ebrowse BROWSE files into a semanticdb back
29;; end.
30;;
31;; Add these databases to the 'system' search.
32;; Possibly use ebrowse for local parsing too.
33;;
34;; When real details are needed out of the tag system from ebrowse,
35;; we will need to delve into the originating source and parse those
36;; files the usual way.
37;;
38;; COMMANDS:
39;; `semanticdb-create-ebrowse-database' - Call EBROWSE to create a
40;; system database for some directory. In general, use this for
41;; system libraries, such as /usr/include, or include directories
42;; large software projects.
43;; Customize `semanticdb-ebrowse-file-match' to make sure the correct
44;; file extensions are matched.
45;;
46;; `semanticdb-load-ebrowse-caches' - Load all the EBROWSE caches from
47;; your semanticdb system database directory. Once they are
48;; loaded, they become searchable as omnipotent databases for
49;; all C++ files. This is called automatically by semantic-load.
50;; Call it a second time to refresh the Emacs DB with the file.
51;;
52
53(eval-when-compile
54 ;; For generic function searching.
55 (require 'eieio)
56 (require 'eieio-opt)
57 )
58(require 'semantic/db-file)
59
60(eval-and-compile
61 ;; Hopefully, this will allow semanticdb-ebrowse to compile under
62 ;; XEmacs, it just won't run if a user attempts to use it.
63 (condition-case nil
64 (require 'ebrowse)
65 (error nil)))
66
67;;; Code:
68(defvar semanticdb-ebrowse-default-file-name "BROWSE"
69 "The EBROWSE file name used for system caches.")
70
71(defcustom semanticdb-ebrowse-file-match "\\.\\(hh?\\|HH?\\|hpp\\)"
72 "Regular expression matching file names for ebrowse to parse.
73This expression should exclude C++ headers that have no extension.
74By default, include only headers since the semantic use of EBrowse
75is only for searching via semanticdb, and thus only headers would
76be searched."
77 :group 'semanticdb
78 :type 'string)
79
80(defun semanticdb-ebrowse-C-file-p (file)
81 "Is FILE a C or C++ file?"
82 (or (string-match semanticdb-ebrowse-file-match file)
83 (and (string-match "/\\w+$" file)
84 (not (file-directory-p file))
85 (let ((tmp (get-buffer-create "*semanticdb-ebrowse-tmp*")))
86 (save-excursion
87 (set-buffer tmp)
88 (condition-case nil
89 (insert-file-contents file nil 0 100 t)
90 (error (insert-file-contents file nil nil nil t)))
91 (goto-char (point-min))
92 (looking-at "\\s-*/\\(\\*\\|/\\)")
93 ))
94 )))
95
96(defun semanticdb-create-ebrowse-database (dir)
97 "Create an EBROSE database for directory DIR.
98The database file is stored in ~/.semanticdb, or whichever directory
99is specified by `semanticdb-default-save-directory'."
100 (interactive "DDirectory: ")
101 (setq dir (file-name-as-directory dir)) ;; for / on end
102 (let* ((savein (semanticdb-ebrowse-file-for-directory dir))
103 (filebuff (get-buffer-create "*SEMANTICDB EBROWSE TMP*"))
104 (files (directory-files (expand-file-name dir) t))
105 (mma auto-mode-alist)
106 (regexp nil)
107 )
108 ;; Create the input to the ebrowse command
109 (save-excursion
110 (set-buffer filebuff)
111 (buffer-disable-undo filebuff)
112 (setq default-directory (expand-file-name dir))
113
114 ;;; @TODO - convert to use semanticdb-collect-matching-filenames
115 ;; to get the file names.
116
117
118 (mapcar (lambda (f)
119 (when (semanticdb-ebrowse-C-file-p f)
120 (insert f)
121 (insert "\n")))
122 files)
123 ;; Cleanup the ebrowse output buffer.
124 (save-excursion
125 (set-buffer (get-buffer-create "*EBROWSE OUTPUT*"))
126 (erase-buffer))
127 ;; Call the EBROWSE command.
128 (message "Creating ebrowse file: %s ..." savein)
129 (call-process-region (point-min) (point-max)
130 "ebrowse" nil "*EBROWSE OUTPUT*" nil
131 (concat "--output-file=" savein)
132 "--very-verbose")
133 )
134 ;; Create a short LOADER program for loading in this database.
135 (let* ((lfn (concat savein "-load.el"))
136 (lf (find-file-noselect lfn)))
137 (save-excursion
138 (set-buffer lf)
139 (erase-buffer)
140 (insert "(semanticdb-ebrowse-load-helper \""
141 (expand-file-name dir)
142 "\")\n")
143 (save-buffer)
144 (kill-buffer (current-buffer)))
145 (message "Creating ebrowse file: %s ... done" savein)
146 ;; Reload that database
147 (load lfn nil t)
148 )))
149
150(defun semanticdb-load-ebrowse-caches ()
151 "Load all semanticdb controlled EBROWSE caches."
152 (interactive)
153 (let ((f (directory-files semanticdb-default-save-directory
154 t (concat semanticdb-ebrowse-default-file-name "-load.el$") t)))
155 (while f
156 (load (car f) nil t)
157 (setq f (cdr f)))
158 ))
159
160(defun semanticdb-ebrowse-load-helper (directory)
161 "Create the semanticdb database via ebrowse for directory.
162If DIRECTORY is found to be defunct, it won't load the DB, and will
163warn instead."
164 (if (file-directory-p directory)
165 (semanticdb-create-database semanticdb-project-database-ebrowse
166 directory)
167 (let* ((BF (semanticdb-ebrowse-file-for-directory directory))
168 (BFL (concat BF "-load.el"))
169 (BFLB (concat BF "-load.el~")))
170 (save-window-excursion
171 (with-output-to-temp-buffer "*FILES TO DELETE*"
172 (princ "The following BROWSE files are obsolete.\n\n")
173 (princ BF)
174 (princ "\n")
175 (princ BFL)
176 (princ "\n")
177 (when (file-exists-p BFLB)
178 (princ BFLB)
179 (princ "\n"))
180 )
181 (when (y-or-n-p (format
182 "Warning: Obsolete BROWSE file for: %s\nDelete? "
183 directory))
184 (delete-file BF)
185 (delete-file BFL)
186 (when (file-exists-p BFLB)
187 (delete-file BFLB))
188 )))))
189
190;;; SEMANTIC Database related Code
191;;; Classes:
192(defclass semanticdb-table-ebrowse (semanticdb-table)
193 ((major-mode :initform c++-mode)
194 (ebrowse-tree :initform nil
195 :initarg :ebrowse-tree
196 :documentation
197 "The raw ebrowse tree for this file."
198 )
199 (global-extract :initform nil
200 :initarg :global-extract
201 :documentation
202 "Table of ebrowse tags specific to this file.
203This table is compisited from the ebrowse *Globals* section.")
204 )
205 "A table for returning search results from ebrowse.")
206
207(defclass semanticdb-project-database-ebrowse
208 (semanticdb-project-database)
209 ((new-table-class :initform semanticdb-table-ebrowse
210 :type class
211 :documentation
212 "New tables created for this database are of this class.")
213 (system-include-p :initform nil
214 :initarg :system-include
215 :documentation
216 "Flag indicating this database represents a system include directory.")
217 (ebrowse-struct :initform nil
218 :initarg :ebrowse-struct
219 )
220 )
221 "Semantic Database deriving tags using the EBROWSE tool.
222EBROWSE is a C/C++ parser for use with `ebrowse' Emacs program.")
223
224;JAVE this just instantiates a default empty ebrowse struct?
225; how would new instances wind up here?
226; the ebrowse class isnt singleton, unlike the emacs lisp one
227(defvar-mode-local c++-mode semanticdb-project-system-databases
228 ()
229 "Search Ebrowse for symbols.")
230
231(defmethod semanticdb-needs-refresh-p ((table semanticdb-table-ebrowse))
232 "EBROWSE database do not need to be refreshed.
233
234JAVE: stub for needs-refresh, because, how do we know if BROWSE files
235 are out of date?
236
237EML: Our database should probably remember the timestamp/checksum of
238 the most recently read EBROWSE file, and use that."
239 nil
240)
241
242
243;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
244
245
246
247;;; EBROWSE code
248;;
249;; These routines deal with part of the ebrowse interface.
250(defun semanticdb-ebrowse-file-for-directory (dir)
251 "Return the file name for DIR where the ebrowse BROWSE file is.
252This file should reside in `semanticdb-default-save-directory'."
253 (let* ((semanticdb-default-save-directory
254 semanticdb-default-save-directory)
255 (B (semanticdb-file-name-directory
256 'semanticdb-project-database-file
257 (concat (expand-file-name dir)
258 semanticdb-ebrowse-default-file-name)))
259 )
260 B))
261
262(defun semanticdb-ebrowse-get-ebrowse-structure (dir)
263 "Return the ebrowse structure for directory DIR.
264This assumes semantic manages the BROWSE files, so they are assumed to live
265where semantic cache files live, depending on your settings.
266
267For instance: /home/<username>/.semanticdb/!usr!include!BROWSE"
268 (let* ((B (semanticdb-ebrowse-file-for-directory dir))
269 (buf (get-buffer-create "*semanticdb ebrowse*")))
270 (message "semanticdb-ebrowse %s" B)
271 (when (file-exists-p B)
272 (set-buffer buf)
273 (buffer-disable-undo buf)
274 (erase-buffer)
275 (insert-file-contents B)
276 (let ((ans nil)
277 (efcn (symbol-function 'ebrowse-show-progress)))
278 (fset 'ebrowse-show-progress #'(lambda (&rest junk) nil))
279 (unwind-protect ;; Protect against errors w/ ebrowse
280 (setq ans (list B (ebrowse-read)))
281 ;; These items must always happen
282 (erase-buffer)
283 (fset 'ebrowse-show-fcn efcn)
284 )
285 ans))))
286
287;;; Methods for creating a database or tables
288;;
289(defmethod semanticdb-create-database :STATIC ((dbeC semanticdb-project-database-ebrowse)
290 directory)
291 "Create a new semantic database for DIRECTORY based on ebrowse.
292If there is no database for DIRECTORY available, then
293{not implemented yet} create one. Return nil if that is not possible."
294 ;; MAKE SURE THAT THE FILE LOADED DOESN'T ALREADY EXIST.
295 (let ((dbs semanticdb-database-list)
296 (found nil))
297 (while (and (not found) dbs)
298 (when (semanticdb-project-database-ebrowse-p (car dbs))
299 (when (string= (oref (car dbs) reference-directory) directory)
300 (setq found (car dbs))))
301 (setq dbs (cdr dbs)))
302 ;;STATIC means DBE cant be used as object, only as a class
303 (let* ((ebrowse-data (semanticdb-ebrowse-get-ebrowse-structure directory))
304 (dat (car (cdr ebrowse-data)))
305 (ebd (car dat))
306 (db nil)
307 (default-directory directory)
308 )
309 (if found
310 (setq db found)
311 (setq db (make-instance
312 dbeC
313 directory
314 :ebrowse-struct ebd
315 ))
316 (oset db reference-directory directory))
317
318 ;; Once we recycle or make a new DB, refresh the
319 ;; contents from the BROWSE file.
320 (oset db tables nil)
321 ;; only possible after object creation, tables inited to nil.
322 (semanticdb-ebrowse-strip-trees db dat)
323
324 ;; Once our database is loaded, if we are a system DB, we
325 ;; add ourselves to the include list for C++.
326 (semantic-add-system-include directory 'c++-mode)
327 (semantic-add-system-include directory 'c-mode)
328
329 db)))
330
331(defmethod semanticdb-ebrowse-strip-trees ((dbe semanticdb-project-database-ebrowse)
332 data)
333 "For the ebrowse database DBE, strip all tables from DATA."
334;JAVE what it actually seems to do is split the original tree in "tables" associated with files
335; im not sure it actually works:
336; the filename slot sometimes gets to be nil,
337; apparently for classes which definition cant be found, yet needs to be included in the tree
338; like library baseclasses
339; a file can define several classes
340 (let ((T (car (cdr data))));1st comes a header, then the tree
341 (while T
342
343 (let* ((tree (car T))
344 (class (ebrowse-ts-class tree)); root class of tree
345 ;; Something funny going on with this file thing...
346 (filename (or (ebrowse-cs-source-file class)
347 (ebrowse-cs-file class)))
348 )
349 (cond
350 ((ebrowse-globals-tree-p tree)
351 ;; We have the globals tree.. save this special.
352 (semanticdb-ebrowse-add-globals-to-table dbe tree)
353 )
354 (t
355 ;; ebrowse will collect all the info from multiple files
356 ;; into one tree. Semantic wants all the bits to be tied
357 ;; into different files. We need to do a full dissociation
358 ;; into semantic parsable tables.
359 (semanticdb-ebrowse-add-tree-to-table dbe tree)
360 ))
361 (setq T (cdr T))))
362 ))
363
364;;; Filename based methods
365;;
366(defun semanticdb-ebrowse-add-globals-to-table (dbe tree)
367 "For database DBE, add the ebrowse TREE into the table."
368 (if (or (not (ebrowse-ts-p tree))
369 (not (ebrowse-globals-tree-p tree)))
370 (signal 'wrong-type-argument (list 'ebrowse-ts-p tree)))
371
372 (let* ((class (ebrowse-ts-class tree))
373 (fname (or (ebrowse-cs-source-file class)
374 (ebrowse-cs-file class)
375 ;; Not def'd here, assume our current
376 ;; file
377 (concat default-directory "/unknown-proxy.hh")))
378 (vars (ebrowse-ts-member-functions tree))
379 (fns (ebrowse-ts-member-variables tree))
380 (toks nil)
381 )
382 (while vars
383 (let ((nt (semantic-tag (ebrowse-ms-name (car vars))
384 'variable))
385 (defpoint (ebrowse-bs-point class)))
386 (when defpoint
387 (semantic--tag-set-overlay nt
388 (vector defpoint defpoint)))
389 (setq toks (cons nt toks)))
390 (setq vars (cdr vars)))
391 (while fns
392 (let ((nt (semantic-tag (ebrowse-ms-name (car fns))
393 'function))
394 (defpoint (ebrowse-bs-point class)))
395 (when defpoint
396 (semantic--tag-set-overlay nt
397 (vector defpoint defpoint)))
398 (setq toks (cons nt toks)))
399 (setq fns (cdr fns)))
400
401 ))
402
403(defun semanticdb-ebrowse-add-tree-to-table (dbe tree &optional fname baseclasses)
404 "For database DBE, add the ebrowse TREE into the table for FNAME.
405Optional argument BASECLASSES specifyies a baseclass to the tree being provided."
406 (if (not (ebrowse-ts-p tree))
407 (signal 'wrong-type-argument (list 'ebrowse-ts-p tree)))
408
409 ;; Strategy overview:
410 ;; 1) Calculate the filename for this tree.
411 ;; 2) Find a matching namespace in TAB, or create a new one.
412 ;; 3) Fabricate a tag proxy for CLASS
413 ;; 4) Add it to the namespace
414 ;; 5) Add subclasses
415
416 ;; 1 - Find the filename
417 (if (not fname)
418 (setq fname (or (ebrowse-cs-source-file (ebrowse-ts-class tree))
419 (ebrowse-cs-file (ebrowse-ts-class tree))
420 ;; Not def'd here, assume our current
421 ;; file
422 (concat default-directory "/unknown-proxy.hh"))))
423
424 (let* ((tab (or (semanticdb-file-table dbe fname)
425 (semanticdb-create-table dbe fname)))
426 (class (ebrowse-ts-class tree))
427 (scope (ebrowse-cs-scope class))
428 (ns (when scope (cedet-split-string scope ":" t)))
429 (nst nil)
430 (cls nil)
431 )
432
433 ;; 2 - Get the namespace tag
434 (when ns
435 (let ((taglst (if (slot-boundp tab 'tags) (oref tab tags) nil)))
436 (setq nst (semantic-find-first-tag-by-name (car ns) taglst))
437 (when (not nst)
438 (setq nst (semantic-tag (car ns) 'type :type "namespace"))
439 (oset tab tags (cons nst taglst))
440 )))
441
442 ;; 3 - Create a proxy tg.
443 (setq cls (semantic-tag (ebrowse-cs-name class)
444 'type
445 :type "class"
446 :superclasses baseclasses
447 :faux t
448 :filename fname
449 ))
450 (let ((defpoint (ebrowse-bs-point class)))
451 (when defpoint
452 (semantic--tag-set-overlay cls
453 (vector defpoint defpoint))))
454
455 ;; 4 - add to namespace
456 (if nst
457 (semantic-tag-put-attribute
458 nst :members (cons cls (semantic-tag-get-attribute nst :members)))
459 (oset tab tags (cons cls (when (slot-boundp tab 'tags)
460 (oref tab tags)))))
461
462 ;; 5 - Subclasses
463 (let* ((subclass (ebrowse-ts-subclasses tree))
464 (pname (ebrowse-cs-name class)))
465 (when (ebrowse-cs-scope class)
466 (setq pname (concat (mapconcat (lambda (a) a) (cdr ns) "::") "::" pname)))
467
468 (while subclass
469 (let* ((scc (ebrowse-ts-class (car subclass)))
470 (fname (or (ebrowse-cs-source-file scc)
471 (ebrowse-cs-file scc)
472 ;; Not def'd here, assume our current
473 ;; file
474 fname
475 )))
476 (when fname
477 (semanticdb-ebrowse-add-tree-to-table
478 dbe (car subclass) fname pname)))
479 (setq subclass (cdr subclass))))
480 ))
481
482;;;
483;; Overload for converting the simple faux tag into something better.
484;;
485(defmethod semanticdb-normalize-tags ((obj semanticdb-table-ebrowse) tags)
486 "Convert in Ebrowse database OBJ a list of TAGS into a complete tag.
487The default tag provided by searches exclude many features of a
488semantic parsed tag. Look up the file for OBJ, and match TAGS
489against a semantic parsed tag that has all the info needed, and
490return that."
491 (let ((tagret nil)
492 )
493 ;; SemanticDB will automatically create a regular database
494 ;; on top of the file just loaded by ebrowse during the set
495 ;; buffer. Fetch that table, and use it's tag list to look
496 ;; up the tag we just got, and thus turn it into a full semantic
497 ;; tag.
498 (while tags
499 (let ((tag (car tags)))
500 (save-excursion
501 (semanticdb-set-buffer obj)
502 (let ((ans nil))
503 ;; Gee, it would be nice to do this, but ebrowse LIES. Oi.
504 (when (semantic-tag-with-position-p tag)
505 (goto-char (semantic-tag-start tag))
506 (let ((foundtag (semantic-current-tag)))
507 ;; Make sure the discovered tag is the same as what we started with.
508 (when (string= (semantic-tag-name tag)
509 (semantic-tag-name foundtag))
510 ;; We have a winner!
511 (setq ans foundtag))))
512 ;; Sometimes ebrowse lies. Do a generic search
513 ;; to find it within this file.
514 (when (not ans)
515 ;; We might find multiple hits for this tag, and we have no way
516 ;; of knowing which one the user wanted. Return the first one.
517 (setq ans (semantic-deep-find-tags-by-name
518 (semantic-tag-name tag)
519 (semantic-fetch-tags))))
520 (if (semantic-tag-p ans)
521 (setq tagret (cons ans tagret))
522 (setq tagret (append ans tagret)))
523 ))
524 (setq tags (cdr tags))))
525 tagret))
526
527(defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-ebrowse) tag)
528 "Convert in Ebrowse database OBJ one TAG into a complete tag.
529The default tag provided by searches exclude many features of a
530semantic parsed tag. Look up the file for OBJ, and match TAG
531against a semantic parsed tag that has all the info needed, and
532return that."
533 (let ((tagret nil)
534 (objret nil))
535 ;; SemanticDB will automatically create a regular database
536 ;; on top of the file just loaded by ebrowse during the set
537 ;; buffer. Fetch that table, and use it's tag list to look
538 ;; up the tag we just got, and thus turn it into a full semantic
539 ;; tag.
540 (save-excursion
541 (semanticdb-set-buffer obj)
542 (setq objret semanticdb-current-table)
543 (when (not objret)
544 ;; What to do??
545 (debug))
546 (let ((ans nil))
547 ;; Gee, it would be nice to do this, but ebrowse LIES. Oi.
548 (when (semantic-tag-with-position-p tag)
549 (goto-char (semantic-tag-start tag))
550 (let ((foundtag (semantic-current-tag)))
551 ;; Make sure the discovered tag is the same as what we started with.
552 (when (string= (semantic-tag-name tag)
553 (semantic-tag-name foundtag))
554 ;; We have a winner!
555 (setq ans foundtag))))
556 ;; Sometimes ebrowse lies. Do a generic search
557 ;; to find it within this file.
558 (when (not ans)
559 ;; We might find multiple hits for this tag, and we have no way
560 ;; of knowing which one the user wanted. Return the first one.
561 (setq ans (semantic-deep-find-tags-by-name
562 (semantic-tag-name tag)
563 (semantic-fetch-tags))))
564 (if (semantic-tag-p ans)
565 (setq tagret ans)
566 (setq tagret (car ans)))
567 ))
568 (cons objret tagret)))
569
570;;; Search Overrides
571;;
572;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining
573;; how your new search routines are implemented.
574;;
575(defmethod semanticdb-find-tags-by-name-method
576 ((table semanticdb-table-ebrowse) name &optional tags)
577 "Find all tags named NAME in TABLE.
578Return a list of tags."
579 ;;(message "semanticdb-find-tags-by-name-method name -- %s" name)
580 (if tags
581 ;; If TAGS are passed in, then we don't need to do work here.
582 (call-next-method)
583 ;; If we ever need to do something special, add here.
584 ;; Since ebrowse tags are converted into semantic tags, we can
585 ;; get away with this sort of thing.
586 (call-next-method)
587 )
588 )
589
590(defmethod semanticdb-find-tags-by-name-regexp-method
591 ((table semanticdb-table-ebrowse) regex &optional tags)
592 "Find all tags with name matching REGEX in TABLE.
593Optional argument TAGS is a list of tags to search.
594Return a list of tags."
595 (if tags (call-next-method)
596 ;; YOUR IMPLEMENTATION HERE
597 (call-next-method)
598 ))
599
600(defmethod semanticdb-find-tags-for-completion-method
601 ((table semanticdb-table-ebrowse) prefix &optional tags)
602 "In TABLE, find all occurances of tags matching PREFIX.
603Optional argument TAGS is a list of tags to search.
604Returns a table of all matching tags."
605 (if tags (call-next-method)
606 ;; YOUR IMPLEMENTATION HERE
607 (call-next-method)
608 ))
609
610(defmethod semanticdb-find-tags-by-class-method
611 ((table semanticdb-table-ebrowse) class &optional tags)
612 "In TABLE, find all occurances of tags of CLASS.
613Optional argument TAGS is a list of tags to search.
614Returns a table of all matching tags."
615 (if tags (call-next-method)
616 (call-next-method)))
617
618;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
619
620;;; Deep Searches
621;;
622;; If your language does not have a `deep' concept, these can be left
623;; alone, otherwise replace with implementations similar to those
624;; above.
625;;
626
627(defmethod semanticdb-deep-find-tags-by-name-method
628 ((table semanticdb-table-ebrowse) name &optional tags)
629 "Find all tags name NAME in TABLE.
630Optional argument TAGS is a list of tags t
631Like `semanticdb-find-tags-by-name-method' for ebrowse."
632 ;;(semanticdb-find-tags-by-name-method table name tags)
633 (call-next-method))
634
635(defmethod semanticdb-deep-find-tags-by-name-regexp-method
636 ((table semanticdb-table-ebrowse) regex &optional tags)
637 "Find all tags with name matching REGEX in TABLE.
638Optional argument TAGS is a list of tags to search.
639Like `semanticdb-find-tags-by-name-method' for ebrowse."
640 ;;(semanticdb-find-tags-by-name-regexp-method table regex tags)
641 (call-next-method))
642
643(defmethod semanticdb-deep-find-tags-for-completion-method
644 ((table semanticdb-table-ebrowse) prefix &optional tags)
645 "In TABLE, find all occurances of tags matching PREFIX.
646Optional argument TAGS is a list of tags to search.
647Like `semanticdb-find-tags-for-completion-method' for ebrowse."
648 ;;(semanticdb-find-tags-for-completion-method table prefix tags)
649 (call-next-method))
650
651;;; Advanced Searches
652;;
653(defmethod semanticdb-find-tags-external-children-of-type-method
654 ((table semanticdb-table-ebrowse) type &optional tags)
655 "Find all nonterminals which are child elements of TYPE
656Optional argument TAGS is a list of tags to search.
657Return a list of tags."
658 (if tags (call-next-method)
659 ;; Ebrowse collects all this type of stuff together for us.
660 ;; but we can't use it.... yet.
661 nil
662 ))
663
664;;; TESTING
665;;
666;; This is a complex bit of stuff. Here are some tests for the
667;; system.
668
669(defun semanticdb-ebrowse-run-tests ()
670 "Run some tests of the semanticdb-ebrowse system.
671All systems are different. Ask questions along the way."
672 (interactive)
673 (let ((doload nil))
674 (when (y-or-n-p "Create a system database to test with? ")
675 (call-interactively 'semanticdb-create-ebrowse-database)
676 (setq doload t))
677 ;; Should we load in caches
678 (when (if doload
679 (y-or-n-p "New database created. Reload system databases? ")
680 (y-or-n-p "Load in all system databases? "))
681 (semanticdb-load-ebrowse-caches)))
682 ;; Ok, databases were creatd. Lets try some searching.
683 (when (not (or (eq major-mode 'c-mode)
684 (eq major-mode 'c++-mode)))
685 (error "Please make your default buffer be a C or C++ file, then
686run the test again..")
687 )
688
689 )
690
691(defun semanticdb-ebrowse-dump ()
692 "Find the first loaded ebrowse table, and dump out the contents."
693 (interactive)
694 (let ((db semanticdb-database-list)
695 (ab nil))
696 (while db
697 (when (semanticdb-project-database-ebrowse-p (car db))
698 (setq ab (data-debug-new-buffer "*EBROWSE Database*"))
699 (data-debug-insert-thing (car db) "*" "")
700 (setq db nil)
701 )
702 (setq db (cdr db)))))
703
704(provide 'semantic/db-ebrowse)
705
706;;; 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 @@
1;;; db-el.el --- Semantic database extensions for Emacs Lisp
2
3;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
4;;; Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Keywords: tags
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25;;
26;; There are a lot of Emacs Lisp functions and variables available for
27;; the asking. This adds on to the semanticdb programming interface to
28;; allow all loaded Emacs Lisp functions to be queried via semanticdb.
29;;
30;; This allows you to use programs written for Semantic using the database
31;; to also work in Emacs Lisp with no compromises.
32;;
33
34(require 'semantic/db-search)
35(eval-when-compile
36 ;; For generic function searching.
37 (require 'eieio)
38 (require 'eieio-opt)
39 (require 'eieio-base)
40 )
41;;; Code:
42
43;;; Classes:
44(defclass semanticdb-table-emacs-lisp (semanticdb-abstract-table)
45 ((major-mode :initform emacs-lisp-mode)
46 )
47 "A table for returning search results from Emacs.")
48
49(defmethod semanticdb-refresh-table ((obj semanticdb-table-emacs-lisp) &optional force)
50 "Do not refresh Emacs Lisp table.
51It does not need refreshing."
52 nil)
53
54(defmethod semanticdb-needs-refresh-p ((obj semanticdb-table-emacs-lisp))
55 "Return nil, we never need a refresh."
56 nil)
57
58(defclass semanticdb-project-database-emacs-lisp
59 (semanticdb-project-database eieio-singleton)
60 ((new-table-class :initform semanticdb-table-emacs-lisp
61 :type class
62 :documentation
63 "New tables created for this database are of this class.")
64 )
65 "Database representing Emacs core.")
66
67;; Create the database, and add it to searchable databases for Emacs Lisp mode.
68(defvar-mode-local emacs-lisp-mode semanticdb-project-system-databases
69 (list
70 (semanticdb-project-database-emacs-lisp "Emacs"))
71 "Search Emacs core for symbols.")
72
73(defvar-mode-local emacs-lisp-mode semanticdb-find-default-throttle
74 '(project omniscience)
75 "Search project files, then search this omniscience database.
76It is not necessary to to system or recursive searching because of
77the omniscience database.")
78
79;;; Filename based methods
80;;
81(defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-emacs-lisp))
82 "For an Emacs Lisp database, there are no explicit tables.
83Create one of our special tables that can act as an intermediary."
84 ;; We need to return something since there is always the "master table"
85 ;; The table can then answer file name type questions.
86 (when (not (slot-boundp obj 'tables))
87 (let ((newtable (semanticdb-table-emacs-lisp "Emacs System Table")))
88 (oset obj tables (list newtable))
89 (oset newtable parent-db obj)
90 (oset newtable tags nil)
91 ))
92 (call-next-method))
93
94(defmethod semanticdb-file-table ((obj semanticdb-project-database-emacs-lisp) filename)
95 "From OBJ, return FILENAME's associated table object.
96For Emacs Lisp, creates a specialized table."
97 (car (semanticdb-get-database-tables obj))
98 )
99
100(defmethod semanticdb-get-tags ((table semanticdb-table-emacs-lisp ))
101 "Return the list of tags belonging to TABLE."
102 ;; specialty table ? Probably derive tags at request time.
103 nil)
104
105(defmethod semanticdb-equivalent-mode ((table semanticdb-table-emacs-lisp) &optional buffer)
106 "Return non-nil if TABLE's mode is equivalent to BUFFER.
107Equivalent modes are specified by by `semantic-equivalent-major-modes'
108local variable."
109 (save-excursion
110 (set-buffer buffer)
111 (eq (or mode-local-active-mode major-mode) 'emacs-lisp-mode)))
112
113(defmethod semanticdb-full-filename ((obj semanticdb-table-emacs-lisp))
114 "Fetch the full filename that OBJ refers to.
115For Emacs Lisp system DB, there isn't one."
116 nil)
117
118;;; Conversion
119;;
120(defmethod semanticdb-normalize-tags ((obj semanticdb-table-emacs-lisp) tags)
121 "Convert tags, originating from Emacs OBJ, into standardized form."
122 (let ((newtags nil))
123 (dolist (T tags)
124 (let* ((ot (semanticdb-normalize-one-tag obj T))
125 (tag (cdr ot)))
126 (setq newtags (cons tag newtags))))
127 ;; There is no promise to have files associated.
128 (nreverse newtags)))
129
130(defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-emacs-lisp) tag)
131 "Convert one TAG, originating from Emacs OBJ, into standardized form.
132If Emacs cannot resolve this symbol to a particular file, then return nil."
133 ;; Here's the idea. For each tag, get the name, then use
134 ;; Emacs' `symbol-file' to get the source. Once we have that,
135 ;; we can use more typical semantic searching techniques to
136 ;; get a regularly parsed tag.
137 (let* ((type (cond ((semantic-tag-of-class-p tag 'function)
138 'defun)
139 ((semantic-tag-of-class-p tag 'variable)
140 'defvar)
141 ))
142 (sym (intern (semantic-tag-name tag)))
143 (file (condition-case err
144 (symbol-file sym type)
145 ;; Older [X]Emacs don't have a 2nd argument.
146 (error (symbol-file sym))))
147 )
148 (if (or (not file) (not (file-exists-p file)))
149 ;; The file didn't exist. Return nil.
150 ;; We can't normalize this tag. Fake it out.
151 (cons obj tag)
152 (when (string-match "\\.elc" file)
153 (setq file (concat (file-name-sans-extension file)
154 ".el"))
155 (when (and (not (file-exists-p file))
156 (file-exists-p (concat file ".gz")))
157 ;; Is it a .gz file?
158 (setq file (concat file ".gz"))))
159
160 (let* ((tab (semanticdb-file-table-object file))
161 (alltags (semanticdb-get-tags tab))
162 (newtags (semanticdb-find-tags-by-name-method
163 tab (semantic-tag-name tag)))
164 (match nil))
165 ;; Find the best match.
166 (dolist (T newtags)
167 (when (semantic-tag-similar-p T tag)
168 (setq match T)))
169 ;; Backup system.
170 (when (not match)
171 (setq match (car newtags)))
172 ;; Return it.
173 (cons tab match)))))
174
175(defun semanticdb-elisp-sym-function-arglist (sym)
176 "Get the argument list for SYM.
177Deal with all different forms of function.
178This was snarfed out of eldoc."
179 (let* ((prelim-def
180 (let ((sd (and (fboundp sym)
181 (symbol-function sym))))
182 (and (symbolp sd)
183 (condition-case err
184 (setq sd (indirect-function sym))
185 (error (setq sd nil))))
186 sd))
187 (def (if (eq (car-safe prelim-def) 'macro)
188 (cdr prelim-def)
189 prelim-def))
190 (arglist (cond ((null def) nil)
191 ((byte-code-function-p def)
192 ;; This is an eieio compatibility function.
193 ;; We depend on EIEIO, so use this.
194 (eieio-compiled-function-arglist def))
195 ((eq (car-safe def) 'lambda)
196 (nth 1 def))
197 (t nil))))
198 arglist))
199
200(defun semanticdb-elisp-sym->tag (sym &optional toktype)
201 "Convert SYM into a semantic tag.
202TOKTYPE is a hint to the type of tag desired."
203 (if (stringp sym)
204 (setq sym (intern-soft sym)))
205 (when sym
206 (cond ((and (eq toktype 'function) (fboundp sym))
207 (semantic-tag-new-function
208 (symbol-name sym)
209 nil ;; return type
210 (semantic-elisp-desymbolify
211 (semanticdb-elisp-sym-function-arglist sym)) ;; arg-list
212 :user-visible-flag (condition-case nil
213 (interactive-form sym)
214 (error nil))
215 ))
216 ((and (eq toktype 'variable) (boundp sym))
217 (semantic-tag-new-variable
218 (symbol-name sym)
219 nil ;; type
220 nil ;; value - ignore for now
221 ))
222 ((and (eq toktype 'type) (class-p sym))
223 (semantic-tag-new-type
224 (symbol-name sym)
225 "class"
226 (semantic-elisp-desymbolify
227 (aref (class-v semanticdb-project-database)
228 class-public-a)) ;; slots
229 (semantic-elisp-desymbolify (class-parents sym)) ;; parents
230 ))
231 ((not toktype)
232 ;; Figure it out on our own.
233 (cond ((class-p sym)
234 (semanticdb-elisp-sym->tag sym 'type))
235 ((fboundp sym)
236 (semanticdb-elisp-sym->tag sym 'function))
237 ((boundp sym)
238 (semanticdb-elisp-sym->tag sym 'variable))
239 (t nil))
240 )
241 (t nil))))
242
243;;; Search Overrides
244;;
245(defvar semanticdb-elisp-mapatom-collector nil
246 "Variable used to collect mapatoms output.")
247
248(defmethod semanticdb-find-tags-by-name-method
249 ((table semanticdb-table-emacs-lisp) name &optional tags)
250 "Find all tags name NAME in TABLE.
251Uses `inter-soft' to match NAME to emacs symbols.
252Return a list of tags."
253 (if tags (call-next-method)
254 ;; No need to search. Use `intern-soft' which does the same thing for us.
255 (let* ((sym (intern-soft name))
256 (fun (semanticdb-elisp-sym->tag sym 'function))
257 (var (semanticdb-elisp-sym->tag sym 'variable))
258 (typ (semanticdb-elisp-sym->tag sym 'type))
259 (taglst nil)
260 )
261 (when (or fun var typ)
262 ;; If the symbol is any of these things, build the search table.
263 (when var (setq taglst (cons var taglst)))
264 (when typ (setq taglst (cons typ taglst)))
265 (when fun (setq taglst (cons fun taglst)))
266 taglst
267 ))))
268
269(defmethod semanticdb-find-tags-by-name-regexp-method
270 ((table semanticdb-table-emacs-lisp) regex &optional tags)
271 "Find all tags with name matching REGEX in TABLE.
272Optional argument TAGS is a list of tags to search.
273Uses `apropos-internal' to find matches.
274Return a list of tags."
275 (if tags (call-next-method)
276 (delq nil (mapcar 'semanticdb-elisp-sym->tag
277 (apropos-internal regex)))))
278
279(defmethod semanticdb-find-tags-for-completion-method
280 ((table semanticdb-table-emacs-lisp) prefix &optional tags)
281 "In TABLE, find all occurances of tags matching PREFIX.
282Optional argument TAGS is a list of tags to search.
283Returns a table of all matching tags."
284 (if tags (call-next-method)
285 (delq nil (mapcar 'semanticdb-elisp-sym->tag
286 (all-completions prefix obarray)))))
287
288(defmethod semanticdb-find-tags-by-class-method
289 ((table semanticdb-table-emacs-lisp) class &optional tags)
290 "In TABLE, find all occurances of tags of CLASS.
291Optional argument TAGS is a list of tags to search.
292Returns a table of all matching tags."
293 (if tags (call-next-method)
294 ;; We could implement this, but it could be messy.
295 nil))
296
297;;; Deep Searches
298;;
299;; For Emacs Lisp deep searches are like top level searches.
300(defmethod semanticdb-deep-find-tags-by-name-method
301 ((table semanticdb-table-emacs-lisp) name &optional tags)
302 "Find all tags name NAME in TABLE.
303Optional argument TAGS is a list of tags to search.
304Like `semanticdb-find-tags-by-name-method' for Emacs Lisp."
305 (semanticdb-find-tags-by-name-method table name tags))
306
307(defmethod semanticdb-deep-find-tags-by-name-regexp-method
308 ((table semanticdb-table-emacs-lisp) regex &optional tags)
309 "Find all tags with name matching REGEX in TABLE.
310Optional argument TAGS is a list of tags to search.
311Like `semanticdb-find-tags-by-name-method' for Emacs Lisp."
312 (semanticdb-find-tags-by-name-regexp-method table regex tags))
313
314(defmethod semanticdb-deep-find-tags-for-completion-method
315 ((table semanticdb-table-emacs-lisp) prefix &optional tags)
316 "In TABLE, find all occurances of tags matching PREFIX.
317Optional argument TAGS is a list of tags to search.
318Like `semanticdb-find-tags-for-completion-method' for Emacs Lisp."
319 (semanticdb-find-tags-for-completion-method table prefix tags))
320
321;;; Advanced Searches
322;;
323(defmethod semanticdb-find-tags-external-children-of-type-method
324 ((table semanticdb-table-emacs-lisp) type &optional tags)
325 "Find all nonterminals which are child elements of TYPE
326Optional argument TAGS is a list of tags to search.
327Return a list of tags."
328 (if tags (call-next-method)
329 ;; EIEIO is the only time this matters
330 (when (featurep 'eieio)
331 (let* ((class (intern-soft type))
332 (taglst (when class
333 (delq nil
334 (mapcar 'semanticdb-elisp-sym->tag
335 ;; Fancy eieio function that knows all about
336 ;; built in methods belonging to CLASS.
337 (eieio-all-generic-functions class)))))
338 )
339 taglst))))
340
341(provide 'semantic/db-el)
342
343;;; 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 @@
1;;; db-file.el --- Save a semanticdb to a cache file.
2
3;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
4;;; Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Keywords: tags
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25;;
26;; A set of semanticdb classes for persistently saving caches on disk.
27;;
28
29(require 'semantic)
30(require 'semantic/db)
31(require 'cedet-files)
32
33(defvar semanticdb-file-version semantic-version
34 "Version of semanticdb we are writing files to disk with.")
35(defvar semanticdb-file-incompatible-version "1.4"
36 "Version of semanticdb we are not reverse compatible with.")
37
38;;; Settings
39;;
40(defcustom semanticdb-default-file-name "semantic.cache"
41 "*File name of the semantic tag cache."
42 :group 'semanticdb
43 :type 'string)
44
45(defcustom semanticdb-default-save-directory (expand-file-name "~/.semanticdb")
46 "*Directory name where semantic cache files are stored.
47If this value is nil, files are saved in the current directory. If the value
48is a valid directory, then it overrides `semanticdb-default-file-name' and
49stores caches in a coded file name in this directory."
50 :group 'semanticdb
51 :type '(choice :tag "Default-Directory"
52 :menu-tag "Default-Directory"
53 (const :tag "Use current directory" :value nil)
54 (directory)))
55
56(defcustom semanticdb-persistent-path '(always)
57 "*List of valid paths that semanticdb will cache tags to.
58When `global-semanticdb-minor-mode' is active, tag lists will
59be saved to disk when Emacs exits. Not all directories will have
60tags that should be saved.
61The value should be a list of valid paths. A path can be a string,
62indicating a directory in which to save a variable. An element in the
63list can also be a symbol. Valid symbols are `never', which will
64disable any saving anywhere, `always', which enables saving
65everywhere, or `project', which enables saving in any directory that
66passes a list of predicates in `semanticdb-project-predicate-functions'."
67 :group 'semanticdb
68 :type nil)
69
70(defcustom semanticdb-save-database-hooks nil
71 "*Hooks run after a database is saved.
72Each function is called with one argument, the object representing
73the database recently written."
74 :group 'semanticdb
75 :type 'hook)
76
77(defvar semanticdb-dir-sep-char (if (boundp 'directory-sep-char)
78 (symbol-value 'directory-sep-char)
79 ?/)
80 "Character used for directory separation.
81Obsoleted in some versions of Emacs. Needed in others.
82NOTE: This should get deleted from semantic soon.")
83
84(defun semanticdb-fix-pathname (dir)
85 "If DIR is broken, fix it.
86Force DIR to end with a /.
87Note: Same as `file-name-as-directory'.
88NOTE: This should get deleted from semantic soon."
89 (file-name-as-directory dir))
90;; I didn't initially know about the above fcn. Keep the below as a
91;; reference. Delete it someday once I've proven everything is the same.
92;; (if (not (= semanticdb-dir-sep-char (aref path (1- (length path)))))
93;; (concat path (list semanticdb-dir-sep-char))
94;; path))
95
96;;; Classes
97;;
98(defclass semanticdb-project-database-file (semanticdb-project-database
99 eieio-persistent)
100 ((file-header-line :initform ";; SEMANTICDB Tags save file")
101 (do-backups :initform nil)
102 (semantic-tag-version :initarg :semantic-tag-version
103 :initform "1.4"
104 :documentation
105 "The version of the tags saved.
106The default value is 1.4. In semantic 1.4 there was no versioning, so
107when those files are loaded, this becomes the version number.
108To save the version number, we must hand-set this version string.")
109 (semanticdb-version :initarg :semanticdb-version
110 :initform "1.4"
111 :documentation
112 "The version of the object system saved.
113The default value is 1.4. In semantic 1.4, there was no versioning,
114so when those files are loaded, this becomes the version number.
115To save the version number, we must hand-set this version string.")
116 )
117 "Database of file tables saved to disk.")
118
119;;; Code:
120;;
121(defmethod semanticdb-create-database :STATIC ((dbc semanticdb-project-database-file)
122 directory)
123 "Create a new semantic database for DIRECTORY and return it.
124If a database for DIRECTORY has already been loaded, return it.
125If a database for DIRECTORY exists, then load that database, and return it.
126If DIRECTORY doesn't exist, create a new one."
127 ;; Make sure this is fully expanded so we don't get duplicates.
128 (setq directory (file-truename directory))
129 (let* ((fn (semanticdb-cache-filename dbc directory))
130 (db (or (semanticdb-file-loaded-p fn)
131 (if (file-exists-p fn)
132 (progn
133 (semanticdb-load-database fn))))))
134 (unless db
135 (setq db (make-instance
136 dbc ; Create the database requested. Perhaps
137 (concat (file-name-nondirectory
138 (directory-file-name
139 directory))
140 "/")
141 :file fn :tables nil
142 :semantic-tag-version semantic-version
143 :semanticdb-version semanticdb-file-version)))
144 ;; Set this up here. We can't put it in the constructor because it
145 ;; would be saved, and we want DB files to be portable.
146 (oset db reference-directory directory)
147 db))
148
149;;; File IO
150(defun semanticdb-load-database (filename)
151 "Load the database FILENAME."
152 (require 'inversion)
153 (condition-case foo
154 (let* ((r (eieio-persistent-read filename))
155 (c (semanticdb-get-database-tables r))
156 (tv (oref r semantic-tag-version))
157 (fv (oref r semanticdb-version))
158 )
159 ;; Restore the parent-db connection
160 (while c
161 (oset (car c) parent-db r)
162 (setq c (cdr c)))
163 (if (not (inversion-test 'semanticdb-file fv))
164 (when (inversion-test 'semantic-tag tv)
165 ;; Incompatible version. Flush tables.
166 (semanticdb-flush-database-tables r)
167 ;; Reset the version to new version.
168 (oset r semantic-tag-version semantic-tag-version)
169 ;; Warn user
170 (message "Semanticdb file is old. Starting over for %s"
171 filename)
172 )
173 ;; Version is not ok. Flush whole system
174 (message "semanticdb file is old. Starting over for %s"
175 filename)
176 ;; This database is so old, we need to replace it.
177 ;; We also need to delete it from the instance tracker.
178 (delete-instance r)
179 (setq r nil))
180 r)
181 (error (message "Cache Error: [%s] %s, Restart"
182 filename foo)
183 nil)))
184
185(defun semanticdb-file-loaded-p (filename)
186 "Return the project belonging to FILENAME if it was already loaded."
187 (eieio-instance-tracker-find filename 'file 'semanticdb-database-list))
188
189(defmethod semanticdb-file-directory-exists-p ((DB semanticdb-project-database-file)
190 &optional supress-questions)
191 "Does the directory the database DB needs to write to exist?
192If SUPRESS-QUESTIONS, then do not ask to create the directory."
193 (let ((dest (file-name-directory (oref DB file)))
194 )
195 (cond ((null dest)
196 ;; @TODO - If it was never set up... what should we do ?
197 nil)
198 ((file-exists-p dest) t)
199 (supress-questions nil)
200 ((y-or-n-p (format "Create directory %s for SemanticDB? "
201 dest))
202 (make-directory dest t)
203 t)
204 (t nil))
205 ))
206
207(defmethod semanticdb-save-db ((DB semanticdb-project-database-file)
208 &optional
209 supress-questions)
210 "Write out the database DB to its file.
211If DB is not specified, then use the current database."
212 (let ((objname (oref DB file)))
213 (when (and (semanticdb-dirty-p DB)
214 (semanticdb-live-p DB)
215 (semanticdb-file-directory-exists-p DB supress-questions)
216 (semanticdb-write-directory-p DB)
217 )
218 ;;(message "Saving tag summary for %s..." objname)
219 (condition-case foo
220 (eieio-persistent-save (or DB semanticdb-current-database))
221 (file-error ; System error saving? Ignore it.
222 (message "%S: %s" foo objname))
223 (error
224 (cond
225 ((and (listp foo)
226 (stringp (nth 1 foo))
227 (string-match "write[- ]protected" (nth 1 foo)))
228 (message (nth 1 foo)))
229 ((and (listp foo)
230 (stringp (nth 1 foo))
231 (string-match "no such directory" (nth 1 foo)))
232 (message (nth 1 foo)))
233 (t
234 ;; @todo - It should ask if we are not called from a hook.
235 ;; How?
236 (if (or supress-questions
237 (y-or-n-p (format "Skip Error: %S ?" (car (cdr foo)))))
238 (message "Save Error: %S: %s" (car (cdr foo))
239 objname)
240 (error "%S" (car (cdr foo))))))))
241 (run-hook-with-args 'semanticdb-save-database-hooks
242 (or DB semanticdb-current-database))
243 ;;(message "Saving tag summary for %s...done" objname)
244 )
245 ))
246
247(defmethod semanticdb-live-p ((obj semanticdb-project-database))
248 "Return non-nil if the file associated with OBJ is live.
249Live databases are objects associated with existing directories."
250 (and (slot-boundp obj 'reference-directory)
251 (file-exists-p (oref obj reference-directory))))
252
253(defmethod semanticdb-live-p ((obj semanticdb-table))
254 "Return non-nil if the file associated with OBJ is live.
255Live files are either buffers in Emacs, or files existing on the filesystem."
256 (let ((full-filename (semanticdb-full-filename obj)))
257 (or (find-buffer-visiting full-filename)
258 (file-exists-p full-filename))))
259
260(defvar semanticdb-data-debug-on-write-error nil
261 "Run the data debugger on tables that issue errors.
262This variable is set to nil after the first error is encountered
263to prevent overload.")
264
265(defmethod object-write ((obj semanticdb-table))
266 "When writing a table, we have to make sure we deoverlay it first.
267Restore the overlays after writting.
268Argument OBJ is the object to write."
269 (when (semanticdb-live-p obj)
270 (when (semanticdb-in-buffer-p obj)
271 (save-excursion
272 (set-buffer (semanticdb-in-buffer-p obj))
273
274 ;; Make sure all our tag lists are up to date.
275 (semantic-fetch-tags)
276
277 ;; Try to get an accurate unmatched syntax table.
278 (when (and (boundp semantic-show-unmatched-syntax-mode)
279 semantic-show-unmatched-syntax-mode)
280 ;; Only do this if the user runs unmatched syntax
281 ;; mode display enties.
282 (oset obj unmatched-syntax
283 (semantic-show-unmatched-lex-tokens-fetch))
284 )
285
286 ;; Make sure pointmax is up to date
287 (oset obj pointmax (point-max))
288 ))
289
290 ;; Make sure that the file size and other attributes are
291 ;; up to date.
292 (let ((fattr (file-attributes (semanticdb-full-filename obj))))
293 (oset obj fsize (nth 7 fattr))
294 (oset obj lastmodtime (nth 5 fattr))
295 )
296
297 ;; Do it!
298 (condition-case tableerror
299 (call-next-method)
300 (error
301 (when semanticdb-data-debug-on-write-error
302 (require 'data-debug)
303 (data-debug-new-buffer (concat "*SEMANTICDB ERROR*"))
304 (data-debug-insert-thing obj "*" "")
305 (setq semanticdb-data-debug-on-write-error nil))
306 (message "Error Writing Table: %s" (object-name obj))
307 (error "%S" (car (cdr tableerror)))))
308
309 ;; Clear the dirty bit.
310 (oset obj dirty nil)
311 ))
312
313;;; State queries
314;;
315(defmethod semanticdb-write-directory-p ((obj semanticdb-project-database-file))
316 "Return non-nil if OBJ should be written to disk.
317Uses `semanticdb-persistent-path' to determine the return value."
318 (let ((path semanticdb-persistent-path))
319 (catch 'found
320 (while path
321 (cond ((stringp (car path))
322 (if (string= (oref obj reference-directory) (car path))
323 (throw 'found t)))
324 ((eq (car path) 'project)
325 ;; @TODO - EDE causes us to go in here and disable
326 ;; the old default 'always save' setting.
327 ;;
328 ;; With new default 'always' should I care?
329 (if semanticdb-project-predicate-functions
330 (if (run-hook-with-args-until-success
331 'semanticdb-project-predicate-functions
332 (oref obj reference-directory))
333 (throw 'found t))
334 ;; If the mode is 'project, and there are no project
335 ;; modes, then just always save the file. If users
336 ;; wish to restrict the search, modify
337 ;; `semanticdb-persistent-path' to include desired paths.
338 (if (= (length semanticdb-persistent-path) 1)
339 (throw 'found t))
340 ))
341 ((eq (car path) 'never)
342 (throw 'found nil))
343 ((eq (car path) 'always)
344 (throw 'found t))
345 (t (error "Invalid path %S" (car path))))
346 (setq path (cdr path)))
347 (call-next-method))
348 ))
349
350;;; Filename manipulation
351;;
352(defmethod semanticdb-file-table ((obj semanticdb-project-database-file) filename)
353 "From OBJ, return FILENAME's associated table object."
354 ;; Cheater option. In this case, we always have files directly
355 ;; under ourselves. The main project type may not.
356 (object-assoc (file-name-nondirectory filename) 'file (oref obj tables)))
357
358(defmethod semanticdb-file-name-non-directory :STATIC
359 ((dbclass semanticdb-project-database-file))
360 "Return the file name DBCLASS will use.
361File name excludes any directory part."
362 semanticdb-default-file-name)
363
364(defmethod semanticdb-file-name-directory :STATIC
365 ((dbclass semanticdb-project-database-file) directory)
366 "Return the relative directory to where DBCLASS will save its cache file.
367The returned path is related to DIRECTORY."
368 (if semanticdb-default-save-directory
369 (let ((file (cedet-directory-name-to-file-name directory)))
370 ;; Now create a filename for the cache file in
371 ;; ;`semanticdb-default-save-directory'.
372 (expand-file-name
373 file (file-name-as-directory semanticdb-default-save-directory)))
374 directory))
375
376(defmethod semanticdb-cache-filename :STATIC
377 ((dbclass semanticdb-project-database-file) path)
378 "For DBCLASS, return a file to a cache file belonging to PATH.
379This could be a cache file in the current directory, or an encoded file
380name in a secondary directory."
381 ;; Use concat and not expand-file-name, because the dir part
382 ;; may include some of the file name.
383 (concat (semanticdb-file-name-directory dbclass path)
384 (semanticdb-file-name-non-directory dbclass)))
385
386(defmethod semanticdb-full-filename ((obj semanticdb-project-database-file))
387 "Fetch the full filename that OBJ refers to."
388 (oref obj file))
389
390;;; FLUSH OLD FILES
391;;
392(defun semanticdb-cleanup-cache-files (&optional noerror)
393 "Cleanup any cache files associated with directories that no longer exist.
394Optional NOERROR prevents errors from being displayed."
395 (interactive)
396 (when (and (not semanticdb-default-save-directory)
397 (not noerror))
398 (error "No default save directory for semantic-save files"))
399
400 (when semanticdb-default-save-directory
401
402 ;; Calculate all the cache files we have.
403 (let* ((regexp (regexp-quote semanticdb-default-file-name))
404 (files (directory-files semanticdb-default-save-directory
405 t regexp))
406 (orig nil)
407 (to-delete nil))
408 (dolist (F files)
409 (setq orig (cedet-file-name-to-directory-name
410 (file-name-nondirectory F)))
411 (when (not (file-exists-p (file-name-directory orig)))
412 (setq to-delete (cons F to-delete))
413 ))
414 (if to-delete
415 (save-window-excursion
416 (let ((buff (get-buffer-create "*Semanticdb Delete*")))
417 (with-current-buffer buff
418 (erase-buffer)
419 (insert "The following Cache files appear to be obsolete.\n\n")
420 (dolist (F to-delete)
421 (insert F "\n")))
422 (pop-to-buffer buff t t)
423 (fit-window-to-buffer (get-buffer-window buff) nil 1)
424 (when (y-or-n-p "Delete Old Cache Files? ")
425 (mapc (lambda (F)
426 (message "Deleting to %s..." F)
427 (delete-file F))
428 to-delete)
429 (message "done."))
430 ))
431 ;; No files to delete
432 (when (not noerror)
433 (message "No obsolete semanticdb.cache files."))
434 ))))
435
436(provide 'semantic/db-file)
437
438;;; 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 @@
1;;; db-javascript.el --- Semantic database extensions for javascript
2
3;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4;;; Free Software Foundation, Inc.
5
6;; Author: Joakim Verona
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; Semanticdb database for Javascript.
26;;
27;; This is an omniscient database with a hard-coded list of symbols for
28;; Javascript. See the doc at the end of this file for adding or modifying
29;; the list of tags.
30;;
31
32(require 'semantic/db-search)
33(eval-when-compile
34 ;; For generic function searching.
35 (require 'eieio)
36 (require 'eieio-opt)
37 )
38;;; Code:
39(defvar semanticdb-javascript-tags
40 '(("eval" function
41 (:arguments
42 (("x" variable nil nil nil)))
43 nil nil)
44 ("parseInt" function
45 (:arguments
46 (("string" variable nil nil nil)
47 ("radix" variable nil nil nil)))
48 nil nil)
49 ("parseFloat" function
50 (:arguments
51 (("string" variable nil nil nil)))
52 nil nil)
53 ("isNaN" function
54 (:arguments
55 (("number" variable nil nil nil)))
56 nil nil)
57 ("isFinite" function
58 (:arguments
59 (("number" variable nil nil nil)))
60 nil nil)
61 ("decodeURI" function
62 (:arguments
63 (("encodedURI" variable nil nil nil)))
64 nil nil)
65 ("decodeURIComponent" function
66 (:arguments
67 (("encodedURIComponent" variable nil nil nil)))
68 nil nil)
69 ("encodeURI" function
70 (:arguments
71 (("uri" variable nil nil nil)))
72 nil nil)
73 ("encodeURIComponent" function
74 (:arguments
75 (("uriComponent" variable nil nil nil)))
76 nil nil))
77 "Hard-coded list of javascript tags for semanticdb.
78See bottom of this file for instruction on managing this list.")
79
80;;; Classes:
81(defclass semanticdb-table-javascript (semanticdb-search-results-table)
82 ((major-mode :initform javascript-mode)
83 )
84 "A table for returning search results from javascript.")
85
86(defclass semanticdb-project-database-javascript
87 (semanticdb-project-database
88 eieio-singleton ;this db is for js globals, so singleton is apropriate
89 )
90 ((new-table-class :initform semanticdb-table-javascript
91 :type class
92 :documentation
93 "New tables created for this database are of this class.")
94 )
95 "Database representing javascript.")
96
97;; Create the database, and add it to searchable databases for javascript mode.
98(defvar-mode-local javascript-mode semanticdb-project-system-databases
99 (list
100 (semanticdb-project-database-javascript "Javascript"))
101 "Search javascript for symbols.")
102
103;; NOTE: Be sure to modify this to the best advantage of your
104;; language.
105(defvar-mode-local javascript-mode semanticdb-find-default-throttle
106 '(project omniscience)
107 "Search project files, then search this omniscience database.
108It is not necessary to to system or recursive searching because of
109the omniscience database.")
110
111;;; Filename based methods
112;;
113(defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-javascript))
114 "For a javascript database, there are no explicit tables.
115Create one of our special tables that can act as an intermediary."
116 ;; NOTE: This method overrides an accessor for the `tables' slot in
117 ;; a database. You can either construct your own (like tmp here
118 ;; or you can manage any number of tables.
119
120 ;; We need to return something since there is always the "master table"
121 ;; The table can then answer file name type questions.
122 (when (not (slot-boundp obj 'tables))
123 (let ((newtable (semanticdb-table-javascript "tmp")))
124 (oset obj tables (list newtable))
125 (oset newtable parent-db obj)
126 (oset newtable tags nil)
127 ))
128 (call-next-method)
129 )
130
131(defmethod semanticdb-file-table ((obj semanticdb-project-database-javascript) filename)
132 "From OBJ, return FILENAME's associated table object."
133 ;; NOTE: See not for `semanticdb-get-database-tables'.
134 (car (semanticdb-get-database-tables obj))
135 )
136
137(defmethod semanticdb-get-tags ((table semanticdb-table-javascript ))
138 "Return the list of tags belonging to TABLE."
139 ;; NOTE: Omniscient databases probably don't want to keep large tabes
140 ;; lolly-gagging about. Keep internal Emacs tables empty and
141 ;; refer to alternate databases when you need something.
142 semanticdb-javascript-tags)
143
144(defmethod semanticdb-equivalent-mode ((table semanticdb-table-javascript) &optional buffer)
145 "Return non-nil if TABLE's mode is equivalent to BUFFER.
146Equivalent modes are specified by by `semantic-equivalent-major-modes'
147local variable."
148 (save-excursion
149 (set-buffer buffer)
150 (eq (or mode-local-active-mode major-mode) 'javascript-mode)))
151
152;;; Usage
153;;
154;; Unlike other tables, an omniscent database does not need to
155;; be associated with a path. Use this routine to always add ourselves
156;; to a search list.
157(define-mode-local-override semanticdb-find-translate-path javascript-mode
158 (path brutish)
159 "Return a list of semanticdb tables asociated with PATH.
160If brutish, do the default action.
161If not brutish, do the default action, and append the system
162database (if available.)"
163 (let ((default
164 ;; When we recurse, disable searching of system databases
165 ;; so that our Javascript database only shows up once when
166 ;; we append it in this iteration.
167 (let ((semanticdb-search-system-databases nil)
168 )
169 (semanticdb-find-translate-path-default path brutish))))
170 ;; Don't add anything if BRUTISH is on (it will be added in that fcn)
171 ;; or if we aren't supposed to search the system.
172 (if (or brutish (not semanticdb-search-system-databases))
173 default
174 (let ((tables (apply #'append
175 (mapcar
176 (lambda (db) (semanticdb-get-database-tables db))
177 semanticdb-project-system-databases))))
178 (append default tables)))))
179
180;;; Search Overrides
181;;
182;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining
183;; how your new search routines are implemented.
184;;
185(defun semanticdb-javascript-regexp-search (regexp)
186 "Search for REGEXP in our fixed list of javascript tags."
187 (let* ((tags semanticdb-javascript-tags)
188 (result nil))
189 (while tags
190 (if (string-match regexp (caar tags))
191 (setq result (cons (car tags) result)))
192 (setq tags (cdr tags)))
193 result))
194
195(defmethod semanticdb-find-tags-by-name-method
196 ((table semanticdb-table-javascript) name &optional tags)
197 "Find all tags named NAME in TABLE.
198Return a list of tags."
199 (if tags
200 ;; If TAGS are passed in, then we don't need to do work here.
201 (call-next-method)
202 (assoc-string name semanticdb-javascript-tags)
203 ))
204
205(defmethod semanticdb-find-tags-by-name-regexp-method
206 ((table semanticdb-table-javascript) regex &optional tags)
207 "Find all tags with name matching REGEX in TABLE.
208Optional argument TAGS is a list of tags to search.
209Return a list of tags."
210 (if tags (call-next-method)
211 ;; YOUR IMPLEMENTATION HERE
212 (semanticdb-javascript-regexp-search regex)
213
214 ))
215
216(defmethod semanticdb-find-tags-for-completion-method
217 ((table semanticdb-table-javascript) prefix &optional tags)
218 "In TABLE, find all occurances of tags matching PREFIX.
219Optional argument TAGS is a list of tags to search.
220Returns a table of all matching tags."
221 (if tags (call-next-method)
222 ;; YOUR IMPLEMENTATION HERE
223 (semanticdb-javascript-regexp-search (concat "^" prefix ".*"))
224 ))
225
226(defmethod semanticdb-find-tags-by-class-method
227 ((table semanticdb-table-javascript) class &optional tags)
228 "In TABLE, find all occurances of tags of CLASS.
229Optional argument TAGS is a list of tags to search.
230Returns a table of all matching tags."
231 (if tags (call-next-method)
232 ;; YOUR IMPLEMENTATION HERE
233 ;;
234 ;; Note: This search method could be considered optional in an
235 ;; omniscient database. It may be unwise to return all tags
236 ;; that exist for a language that are a variable or function.
237 ;;
238 ;; If it is optional, you can just delete this method.
239 nil))
240
241;;; Deep Searches
242;;
243;; If your language does not have a `deep' concept, these can be left
244;; alone, otherwise replace with implementations similar to those
245;; above.
246;;
247(defmethod semanticdb-deep-find-tags-by-name-method
248 ((table semanticdb-table-javascript) name &optional tags)
249 "Find all tags name NAME in TABLE.
250Optional argument TAGS is a list of tags t
251Like `semanticdb-find-tags-by-name-method' for javascript."
252 (semanticdb-find-tags-by-name-method table name tags))
253
254(defmethod semanticdb-deep-find-tags-by-name-regexp-method
255 ((table semanticdb-table-javascript) regex &optional tags)
256 "Find all tags with name matching REGEX in TABLE.
257Optional argument TAGS is a list of tags to search.
258Like `semanticdb-find-tags-by-name-method' for javascript."
259 (semanticdb-find-tags-by-name-regexp-method table regex tags))
260
261(defmethod semanticdb-deep-find-tags-for-completion-method
262 ((table semanticdb-table-javascript) prefix &optional tags)
263 "In TABLE, find all occurances of tags matching PREFIX.
264Optional argument TAGS is a list of tags to search.
265Like `semanticdb-find-tags-for-completion-method' for javascript."
266 (semanticdb-find-tags-for-completion-method table prefix tags))
267
268;;; Advanced Searches
269;;
270(defmethod semanticdb-find-tags-external-children-of-type-method
271 ((table semanticdb-table-javascript) type &optional tags)
272 "Find all nonterminals which are child elements of TYPE
273Optional argument TAGS is a list of tags to search.
274Return a list of tags."
275 (if tags (call-next-method)
276 ;; YOUR IMPLEMENTATION HERE
277 ;;
278 ;; OPTIONAL: This could be considered an optional function. It is
279 ;; used for `semantic-adopt-external-members' and may not
280 ;; be possible to do in your language.
281 ;;
282 ;; If it is optional, you can just delete this method.
283 ))
284
285;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
286(defun semanticdb-javascript-strip-tags (tags)
287 "Strip TAGS from overlays and reparse symbols."
288 (cond ((and (consp tags) (eq 'reparse-symbol (car tags)))
289 nil)
290 ((overlayp tags) nil)
291 ((atom tags) tags)
292 (t (cons (semanticdb-javascript-strip-tags
293 (car tags)) (semanticdb-javascript-strip-tags
294 (cdr tags))))))
295
296;this list was made from a javascript file, and the above function
297;; function eval(x){}
298;; function parseInt(string,radix){}
299;; function parseFloat(string){}
300;; function isNaN(number){}
301;; function isFinite(number){}
302;; function decodeURI(encodedURI){}
303;; function decodeURIComponent (encodedURIComponent){}
304;; function encodeURI (uri){}
305;; function encodeURIComponent (uriComponent){}
306
307
308(provide 'semantic/db-el)
309
310;;; 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 @@
1;;; db-search.el --- Searching through semantic databases.
2
3;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2008, 2009
4;;; Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; NOTE: THESE APIs ARE OBSOLETE:
26;;
27;; Databases of various forms can all be searched. These routines
28;; cover many common forms of searching.
29;;
30;; There are three types of searches that can be implemented:
31;;
32;; Basic Search:
33;; These searches allow searching on specific attributes of tags,
34;; such as name or type.
35;;
36;; Advanced Search:
37;; These are searches that were needed to accomplish some tasks
38;; during in utilities. Advanced searches include matching methods
39;; defined outside some parent class.
40;;
41;; The reason for advanced searches are so that external
42;; repositories such as the Emacs obarray, or java .class files can
43;; quickly answer these needed questions without dumping the entire
44;; symbol list into Emacs for a regular semanticdb search.
45;;
46;; Generic Search:
47;; The generic search, `semanticdb-find-nonterminal-by-function'
48;; accepts a Emacs Lisp predicate that tests tags in Semantic
49;; format. Most external searches cannot perform this search.
50
51(require 'semantic/db)
52(require 'semantic/find)
53
54;;; Code:
55;;
56;;; Classes:
57
58;; @TODO MOVE THIS CLASS?
59(defclass semanticdb-search-results-table (semanticdb-abstract-table)
60 (
61 )
62 "Table used for search results when there is no file or table association.
63Examples include search results from external sources such as from
64Emacs' own symbol table, or from external libraries.")
65
66(defmethod semanticdb-refresh-table ((obj semanticdb-search-results-table) &optional force)
67 "If the tag list associated with OBJ is loaded, refresh it.
68This will call `semantic-fetch-tags' if that file is in memory."
69 nil)
70
71;;; Utils
72;;
73;; Convenience routines for searches
74(defun semanticdb-collect-find-results (result-in-databases
75 result-finding-function
76 ignore-system
77 find-file-on-match)
78 "OBSOLETE:
79Collect results across RESULT-IN-DATABASES for RESULT-FINDING-FUNCTION.
80If RESULT-IN-DATABASES is nil, search a range of associated databases
81calculated by `semanticdb-current-database-list'.
82RESULT-IN-DATABASES is a list of variable `semanticdb-project-database'
83objects.
84RESULT-FINDING-FUNCTION should accept one argument, the database being searched.
85Argument IGNORE-SYSTEM specifies if any available system databases should
86be ignored, or searched.
87Argument FIND-FILE-ON-MATCH indicates that the found databases
88should be capable of doing so."
89 (if (not (listp result-in-databases))
90 (signal 'wrong-type-argument (list 'listp result-in-databases)))
91 (let* ((semanticdb-search-system-databases
92 (if ignore-system
93 nil
94 semanticdb-search-system-databases))
95 (dbs (or result-in-databases
96 ;; Calculate what database to use.
97 ;; Something simple and dumb for now.
98 (or (semanticdb-current-database-list)
99 (list (semanticdb-current-database)))))
100 (case-fold-search semantic-case-fold)
101 (res (mapcar
102 (lambda (db)
103 (if (or (not find-file-on-match)
104 (not (child-of-class-p
105 (oref db new-table-class)
106 semanticdb-search-results-table)))
107 (funcall result-finding-function db)))
108 dbs))
109 out)
110 ;; Flatten the list. The DB is unimportant at this stage.
111 (setq res (apply 'append res))
112 (setq out nil)
113 ;; Move across results, and throw out empties.
114 (while res
115 (if (car res)
116 (setq out (cons (car res) out)))
117 (setq res (cdr res)))
118 ;; Results
119 out))
120
121;;; Programatic interfaces
122;;
123;; These routines all perform different types of searches, and are
124;; interfaces to the database methods used to also perform those searches.
125
126(defun semanticdb-find-nonterminal-by-token
127 (token &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
128 "OBSOLETE:
129Find all occurances of nonterminals with token TOKEN in databases.
130See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
131SEARCH-PARTS, SEARCH-INCLUDES, DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
132Return a list ((DB-TABLE . TOKEN-LIST) ...)."
133 (semanticdb-collect-find-results
134 databases
135 (lambda (db)
136 (semanticdb-find-nonterminal-by-token-method
137 db token search-parts search-includes diff-mode find-file-match))
138 ignore-system
139 find-file-match))
140(make-obsolete 'semanticdb-find-nonterminal-by-token
141 "Please don't use this function")
142
143(defun semanticdb-find-nonterminal-by-name
144 (name &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
145 "OBSOLETE:
146Find all occurances of nonterminals with name NAME in databases.
147See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
148SEARCH-PARTS, SEARCH-INCLUDES, DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
149Return a list ((DB-TABLE . TOKEN) ...)."
150 (semanticdb-collect-find-results
151 databases
152 (lambda (db)
153 (semanticdb-find-nonterminal-by-name-method
154 db name search-parts search-includes diff-mode find-file-match))
155 ignore-system
156 find-file-match))
157(make-obsolete 'semanticdb-find-nonterminal-by-name
158 "Please don't use this function")
159
160(defun semanticdb-find-nonterminal-by-name-regexp
161 (regex &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
162 "OBSOLETE:
163Find all occurances of nonterminals with name matching REGEX in databases.
164See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
165SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
166Return a list ((DB-TABLE . TOKEN-LIST) ...)."
167 (semanticdb-collect-find-results
168 databases
169 (lambda (db)
170 (semanticdb-find-nonterminal-by-name-regexp-method
171 db regex search-parts search-includes diff-mode find-file-match))
172 ignore-system
173 find-file-match))
174(make-obsolete 'semanticdb-find-nonterminal-by-name-regexp
175 "Please don't use this function")
176
177
178(defun semanticdb-find-nonterminal-by-type
179 (type &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
180 "OBSOLETE:
181Find all nonterminals with a type of TYPE in databases.
182See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
183SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
184Return a list ((DB-TABLE . TOKEN-LIST) ...)."
185 (semanticdb-collect-find-results
186 databases
187 (lambda (db)
188 (semanticdb-find-nonterminal-by-type-method
189 db type search-parts search-includes diff-mode find-file-match))
190 ignore-system
191 find-file-match))
192(make-obsolete 'semanticdb-find-nonterminal-by-type
193 "Please don't use this function")
194
195
196(defun semanticdb-find-nonterminal-by-property
197 (property value &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
198 "OBSOLETE:
199Find all nonterminals with a PROPERTY equal to VALUE in databases.
200See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
201SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
202Return a list ((DB-TABLE . TOKEN-LIST) ...)."
203 (semanticdb-collect-find-results
204 databases
205 (lambda (db)
206 (semanticdb-find-nonterminal-by-property-method
207 db property value search-parts search-includes diff-mode find-file-match))
208 ignore-system
209 find-file-match))
210(make-obsolete 'semanticdb-find-nonterminal-by-property
211 "Please don't use this function")
212
213(defun semanticdb-find-nonterminal-by-extra-spec
214 (spec &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
215 "OBSOLETE:
216Find all nonterminals with a SPEC in databases.
217See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
218SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
219Return a list ((DB-TABLE . TOKEN-LIST) ...)."
220 (semanticdb-collect-find-results
221 databases
222 (lambda (db)
223 (semanticdb-find-nonterminal-by-extra-spec-method
224 db spec search-parts search-includes diff-mode find-file-match))
225 ignore-system
226 find-file-match))
227(make-obsolete 'semanticdb-find-nonterminal-by-extra-spec
228 "Please don't use this function")
229
230(defun semanticdb-find-nonterminal-by-extra-spec-value
231 (spec value &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
232 "OBSOLETE:
233Find all nonterminals with a SPEC equal to VALUE in databases.
234See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
235SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
236Return a list ((DB-TABLE . TOKEN-LIST) ...)."
237 (semanticdb-collect-find-results
238 databases
239 (lambda (db)
240 (semanticdb-find-nonterminal-by-extra-spec-value-method
241 db spec value search-parts search-includes diff-mode find-file-match))
242 ignore-system
243 find-file-match))
244(make-obsolete 'semanticdb-find-nonterminal-by-extra-spec-value
245 "Please don't use this function")
246
247;;; Advanced Search Routines
248;;
249(defun semanticdb-find-nonterminal-external-children-of-type
250 (type &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
251 "OBSOLETE:
252Find all nonterminals which are child elements of TYPE.
253See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
254SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
255Return a list ((DB-TABLE . TOKEN-LIST) ...)."
256 (semanticdb-collect-find-results
257 databases
258 (lambda (db)
259 (semanticdb-find-nonterminal-external-children-of-type-method
260 db type search-parts search-includes diff-mode find-file-match))
261 ignore-system
262 find-file-match))
263
264;;; Generic Search routine
265;;
266
267(defun semanticdb-find-nonterminal-by-function
268 (function &optional databases search-parts search-includes diff-mode find-file-match ignore-system)
269 "OBSOLETE:
270Find all occurances of nonterminals which match FUNCTION.
271Search in all DATABASES. If DATABASES is nil, search a range of
272associated databases calculated `semanticdb-current-database-list' and
273DATABASES is a list of variable `semanticdb-project-database' objects.
274When SEARCH-PARTS is non-nil the search will include children of tags.
275When SEARCH-INCLUDES is non-nil, the search will include dependency files.
276When DIFF-MODE is non-nil, search databases which are of a different mode.
277A Mode is the `major-mode' that file was in when it was last parsed.
278When FIND-FILE-MATCH is non-nil, the make sure any found token's file is
279in an Emacs buffer.
280When IGNORE-SYSTEM is non-nil, system libraries are not searched.
281Return a list ((DB-TABLE . TOKEN-OR-TOKEN-LIST) ...)."
282 (semanticdb-collect-find-results
283 databases
284 (lambda (db)
285 (semanticdb-find-nonterminal-by-function-method
286 db function search-parts search-includes diff-mode find-file-match))
287 ignore-system
288 find-file-match))
289
290;;; Search Methods
291;;
292;; These are the base routines for searching semantic databases.
293;; Overload these with your subclasses to participate in the searching
294;; mechanism.
295(defmethod semanticdb-find-nonterminal-by-token-method
296 ((database semanticdb-project-database) token search-parts search-includes diff-mode find-file-match)
297 "OBSOLETE:
298In DB, find all occurances of nonterminals with token TOKEN in databases.
299See `semanticdb-find-nonterminal-by-function-method' for details on,
300SEARCH-PARTS, SEARCH-INCLUDES, DIFF-MODE, and FIND-FILE-MATCH.
301Return a list ((DB-TABLE . TOKEN-LIST) ...)."
302 (let ((goofy-token-name token))
303 (semanticdb-find-nonterminal-by-function-method
304 database (lambda (stream sp si)
305 (semantic-brute-find-tag-by-class goofy-token-name stream sp si))
306 search-parts search-includes diff-mode find-file-match)))
307
308(defmethod semanticdb-find-nonterminal-by-name-method
309 ((database semanticdb-project-database) name search-parts search-includes diff-mode find-file-match)
310 "OBSOLETE:
311Find all occurances of nonterminals with name NAME in databases.
312See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
313SEARCH-PARTS, SEARCH-INCLUDES, DIFF-MODE, and FIND-FILE-MATCH.
314Return a list ((DB-TABLE . TOKEN) ...)."
315 (semanticdb-find-nonterminal-by-function-method
316 database
317 (lambda (stream sp si)
318 (semantic-brute-find-first-tag-by-name name stream sp si))
319 search-parts search-includes diff-mode find-file-match))
320
321(defmethod semanticdb-find-nonterminal-by-name-regexp-method
322 ((database semanticdb-project-database) regex search-parts search-includes diff-mode find-file-match)
323 "OBSOLETE:
324Find all occurances of nonterminals with name matching REGEX in databases.
325See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
326SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH.
327Return a list ((DB-TABLE . TOKEN-LIST) ...)."
328 (semanticdb-find-nonterminal-by-function-method
329 database
330 (lambda (stream sp si)
331 (semantic-brute-find-tag-by-name-regexp regex stream sp si))
332 search-parts search-includes diff-mode find-file-match))
333
334(defmethod semanticdb-find-nonterminal-by-type-method
335 ((database semanticdb-project-database) type search-parts search-includes diff-mode find-file-match)
336 "OBSOLETE:
337Find all nonterminals with a type of TYPE in databases.
338See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
339SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH.
340Return a list ((DB-TABLE . TOKEN-LIST) ...)."
341 (semanticdb-find-nonterminal-by-function-method
342 database
343 (lambda (stream sp si)
344 (semantic-brute-find-tag-by-type type stream sp si))
345 search-parts search-includes diff-mode find-file-match))
346
347(defmethod semanticdb-find-nonterminal-by-property-method
348 ((database semanticdb-project-database) property value search-parts search-includes diff-mode find-file-match)
349 "OBSOLETE:
350Find all nonterminals with a PROPERTY equal to VALUE in databases.
351See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
352SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH.
353Return a list ((DB-TABLE . TOKEN-LIST) ...)."
354 (semanticdb-find-nonterminal-by-function-method
355 database
356 (lambda (stream sp si)
357 (semantic-brute-find-tag-by-property property value stream sp si))
358 search-parts search-includes diff-mode find-file-match))
359
360(defmethod semanticdb-find-nonterminal-by-extra-spec-method
361 ((database semanticdb-project-database) spec search-parts search-includes diff-mode find-file-match)
362 "OBSOLETE:
363Find all nonterminals with a SPEC in databases.
364See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
365SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH.
366Return a list ((DB-TABLE . TOKEN-LIST) ...)."
367 (semanticdb-find-nonterminal-by-function-method
368 database
369 (lambda (stream sp si)
370 (semantic-brute-find-tag-by-attribute spec stream sp si))
371 search-parts search-includes diff-mode find-file-match))
372
373(defmethod semanticdb-find-nonterminal-by-extra-spec-value-method
374 ((database semanticdb-project-database) spec value search-parts search-includes diff-mode find-file-match)
375 "OBSOLETE:
376Find all nonterminals with a SPEC equal to VALUE in databases.
377See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
378SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, and FIND-FILE-MATCH.
379Return a list ((DB-TABLE . TOKEN-LIST) ...)."
380 (semanticdb-find-nonterminal-by-function-method
381 database
382 (lambda (stream sp si)
383 (semantic-brute-find-tag-by-attribute-value spec value stream sp si))
384 search-parts search-includes diff-mode find-file-match))
385
386;;; Advanced Searches
387;;
388(defmethod semanticdb-find-nonterminal-external-children-of-type-method
389 ((database semanticdb-project-database) type search-parts search-includes diff-mode find-file-match)
390 "OBSOLETE:
391Find all nonterminals which are child elements of TYPE
392See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
393SEARCH-PARTS, SEARCH-INCLUDES DIFF-MODE, FIND-FILE-MATCH and IGNORE-SYSTEM.
394Return a list ((DB-TABLE . TOKEN-LIST) ...)."
395 (semanticdb-find-nonterminal-by-function-method
396 database
397 `(lambda (stream sp si)
398 (semantic-brute-find-tag-by-function
399 (lambda (tok)
400 (let ((p (semantic-nonterminal-external-member-parent tok)))
401 (and (stringp p) (string= ,type p)))
402 )
403 stream sp si))
404 nil nil t))
405
406;;; Generic Search
407;;
408(defmethod semanticdb-find-nonterminal-by-function-method
409 ((database semanticdb-project-database)
410 function &optional search-parts search-includes diff-mode find-file-match)
411 "OBSOLETE:
412In DATABASE, find all occurances of nonterminals which match FUNCTION.
413When SEARCH-PARTS is non-nil the search will include children of tags.
414When SEARCH-INCLUDES is non-nil, the search will include dependency files.
415When DIFF-MODE is non-nil, search databases which are of a different mode.
416A mode is the `major-mode' that file was in when it was last parsed.
417When FIND-FILE-MATCH is non-nil, the make sure any found token's file is
418in an Emacs buffer.
419Return a list of matches."
420 (let* ((ret nil)
421 (files (semanticdb-get-database-tables database))
422 (found nil)
423 (orig-buffer (current-buffer)))
424 (while files
425 (when (or diff-mode
426 (semanticdb-equivalent-mode (car files) orig-buffer))
427 ;; This can cause unneeded refreshes while typing with
428 ;; senator-eldoc mode.
429 ;;(semanticdb-refresh-table (car files))
430 (setq found (funcall function
431 (semanticdb-get-tags (car files))
432 search-parts
433 search-includes
434 )))
435 (if found
436 (progn
437 ;; When something is found, make sure we read in that buffer if it
438 ;; had not already been loaded.
439 (if find-file-match
440 (save-excursion (semanticdb-set-buffer (car files))))
441 ;; In theory, the database is up-to-date with what is in the file, and
442 ;; these tags are ready to go.
443 ;; There is a bug lurking here I don't have time to fix.
444 (setq ret (cons (cons (car files) found) ret))
445 (setq found nil)))
446 (setq files (cdr files)))
447 (nreverse ret)))
448
449(provide 'semantic/db-search)
450
451;;; 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 @@
1;;; db-typecache.el --- Manage Datatypes
2
3;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <eric@siege-engine.com>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Manage a datatype cache.
25;;
26;; For typed languages like C++ collect all known types from various
27;; headers, merge namespaces, and expunge duplicates.
28;;
29;; It is likely this feature will only be needed for C/C++.
30
31(require 'semantic/db)
32(require 'semantic/db-find)
33
34;;; Code:
35
36
37;;; TABLE TYPECACHE
38(defclass semanticdb-typecache ()
39 ((filestream :initform nil
40 :documentation
41 "Fully sorted/merged list of tags within this buffer.")
42 (includestream :initform nil
43 :documentation
44 "Fully sorted/merged list of tags from this file's includes list.")
45 (stream :initform nil
46 :documentation
47 "The searchable tag stream for this cache.
48NOTE: Can I get rid of this? Use a hashtable instead?")
49 (dependants :initform nil
50 :documentation
51 "Any other object that is dependent on typecache results.
52Said object must support `semantic-reset' methods.")
53 ;; @todo - add some sort of fast-hash.
54 ;; @note - Rebuilds in large projects already take a while, and the
55 ;; actual searches are pretty fast. Really needed?
56 )
57 "Structure for maintaining a typecache.")
58
59(defmethod semantic-reset ((tc semanticdb-typecache))
60 "Reset the object IDX."
61 (oset tc filestream nil)
62 (oset tc includestream nil)
63
64 (oset tc stream nil)
65
66 (mapc 'semantic-reset (oref tc dependants))
67 (oset tc dependants nil)
68 )
69
70(defmethod semanticdb-typecache-notify-reset ((tc semanticdb-typecache))
71 "Do a reset from a notify from a table we depend on."
72 (oset tc includestream nil)
73 (mapc 'semantic-reset (oref tc dependants))
74 (oset tc dependants nil)
75 )
76
77(defmethod semanticdb-partial-synchronize ((tc semanticdb-typecache)
78 new-tags)
79 "Reset the typecache based on a partial reparse."
80 (when (semantic-find-tags-by-class 'include new-tags)
81 (oset tc includestream nil)
82 (mapc 'semantic-reset (oref tc dependants))
83 (oset tc dependants nil)
84 )
85
86 (when (semantic-find-tags-by-class 'type new-tags)
87 ;; Reset our index
88 (oset tc filestream nil)
89 t ;; Return true, our core file tags have changed in a relavant way.
90 )
91
92 ;; NO CODE HERE
93 )
94
95(defun semanticdb-typecache-add-dependant (dep)
96 "Add into the local typecache a dependant DEP."
97 (let* ((table semanticdb-current-table)
98 ;;(idx (semanticdb-get-table-index table))
99 (cache (semanticdb-get-typecache table))
100 )
101 (object-add-to-list cache 'dependants dep)))
102
103(defun semanticdb-typecache-length(thing)
104 "How long is THING?
105Debugging function."
106 (cond ((semanticdb-typecache-child-p thing)
107 (length (oref thing stream)))
108 ((semantic-tag-p thing)
109 (length (semantic-tag-type-members thing)))
110 ((and (listp thing) (semantic-tag-p (car thing)))
111 (length thing))
112 ((null thing)
113 0)
114 (t -1) ))
115
116
117(defmethod semanticdb-get-typecache ((table semanticdb-abstract-table))
118 "Retrieve the typecache from the semanticdb TABLE.
119If there is no table, create one, and fill it in."
120 (semanticdb-refresh-table table)
121 (let* ((idx (semanticdb-get-table-index table))
122 (cache (oref idx type-cache))
123 )
124
125 ;; Make sure we have a cache object in the DB index.
126 (when (not cache)
127 ;; The object won't change as we fill it with stuff.
128 (setq cache (semanticdb-typecache (semanticdb-full-filename table)))
129 (oset idx type-cache cache))
130
131 cache))
132
133(defmethod semanticdb-have-typecache-p ((table semanticdb-abstract-table))
134 "Return non-nil (the typecache) if TABLE has a pre-calculated typecache."
135 (let* ((idx (semanticdb-get-table-index table)))
136 (oref idx type-cache)))
137
138
139;;; DATABASE TYPECACHE
140;;
141;; A full database can cache the types across its files.
142;;
143;; Unlike file based caches, this one is a bit simpler, and just needs
144;; to get reset when a table gets updated.
145
146(defclass semanticdb-database-typecache (semanticdb-abstract-db-cache)
147 ((stream :initform nil
148 :documentation
149 "The searchable tag stream for this cache.")
150 )
151 "Structure for maintaining a typecache.")
152
153(defmethod semantic-reset ((tc semanticdb-database-typecache))
154 "Reset the object IDX."
155 (oset tc stream nil)
156 )
157
158(defmethod semanticdb-synchronize ((cache semanticdb-database-typecache)
159 new-tags)
160 "Synchronize a CACHE with some NEW-TAGS."
161 )
162
163(defmethod semanticdb-partial-synchronize ((cache semanticdb-database-typecache)
164 new-tags)
165 "Synchronize a CACHE with some changed NEW-TAGS."
166 )
167
168(defmethod semanticdb-get-typecache ((db semanticdb-project-database))
169 "Retrieve the typecache from the semantic database DB.
170If there is no table, create one, and fill it in."
171 (semanticdb-cache-get db semanticdb-database-typecache)
172 )
173
174
175;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
176
177;;; MERGING
178;;
179;; Managing long streams of tags representing data types.
180;;
181(defun semanticdb-typecache-apply-filename (file stream)
182 "Apply the filename FILE to all tags in STREAM."
183 (let ((new nil))
184 (while stream
185 (setq new (cons (semantic-tag-copy (car stream) nil file)
186 new))
187 ;The below is handled by the tag-copy fcn.
188 ;(semantic--tag-put-property (car new) :filename file)
189 (setq stream (cdr stream)))
190 (nreverse new)))
191
192
193(defsubst semanticdb-typecache-safe-tag-members (tag)
194 "Return a list of members for TAG that are safe to permute."
195 (let ((mem (semantic-tag-type-members tag))
196 (fname (semantic-tag-file-name tag)))
197 (if fname
198 (setq mem (semanticdb-typecache-apply-filename fname mem))
199 (copy-sequence mem))))
200
201(defsubst semanticdb-typecache-safe-tag-list (tags table)
202 "Make the tag list TAGS found in TABLE safe for the typecache.
203Adds a filename and copies the tags."
204 (semanticdb-typecache-apply-filename
205 (semanticdb-full-filename table)
206 tags))
207
208(defun semanticdb-typecache-merge-streams (cache1 cache2)
209 "Merge into CACHE1 and CACHE2 together. The Caches will be merged in place."
210 (if (or (and (not cache1) (not cache2))
211 (and (not (cdr cache1)) (not cache2))
212 (and (not cache1) (not (cdr cache2))))
213 ;; If all caches are empty OR
214 ;; cache1 is length 1 and no cache2 OR
215 ;; no cache1 and length 1 cache2
216 ;;
217 ;; then just return the cache, and skip all this merging stuff.
218 (or cache1 cache2)
219
220 ;; Assume we always have datatypes, as this typecache isn't really
221 ;; useful without a typed language.
222 (let ((S (semantic-sort-tags-by-name-then-type-increasing
223 ;; I used to use append, but it copied cache1 but not cache2.
224 ;; Since sort was permuting cache2, I already had to make sure
225 ;; the caches were permute-safe. Might as well use nconc here.
226 (nconc cache1 cache2)))
227 (ans nil)
228 (next nil)
229 (prev nil)
230 (type nil))
231 ;; With all the tags in order, we can loop over them, and when
232 ;; two have the same name, we can either throw one away, or construct
233 ;; a fresh new tag merging the items together.
234 (while S
235 (setq prev (car ans))
236 (setq next (car S))
237 (if (or
238 ;; CASE 1 - First item
239 (null prev)
240 ;; CASE 2 - New name
241 (not (string= (semantic-tag-name next)
242 (semantic-tag-name prev))))
243 (setq ans (cons next ans))
244 ;; ELSE - We have a NAME match.
245 (setq type (semantic-tag-type next))
246 (if (semantic-tag-of-type-p prev type) ; Are they the same datatype
247 ;; Same Class, we can do a merge.
248 (cond
249 ((and (semantic-tag-of-class-p next 'type)
250 (string= type "namespace"))
251 ;; Namespaces - merge the children together.
252 (setcar ans
253 (semantic-tag-new-type
254 (semantic-tag-name prev) ; - they are the same
255 "namespace" ; - we know this as fact
256 (semanticdb-typecache-merge-streams
257 (semanticdb-typecache-safe-tag-members prev)
258 (semanticdb-typecache-safe-tag-members next))
259 nil ; - no attributes
260 ))
261 ;; Make sure we mark this as a fake tag.
262 (semantic-tag-set-faux (car ans))
263 )
264 ((semantic-tag-prototype-p next)
265 ;; NEXT is a prototype... so keep previous.
266 nil ; - keep prev, do nothing
267 )
268 ((semantic-tag-prototype-p prev)
269 ;; PREV is a prototype, but not next.. so keep NEXT.
270 ;; setcar - set by side-effect on top of prev
271 (setcar ans next)
272 )
273 (t
274 ;;(message "Don't know how to merge %s. Keeping first entry." (semantic-tag-name next))
275 ))
276 ;; Not same class... but same name
277 ;(message "Same name, different type: %s, %s!=%s"
278 ; (semantic-tag-name next)
279 ; (semantic-tag-type next)
280 ; (semantic-tag-type prev))
281 (setq ans (cons next ans))
282 ))
283 (setq S (cdr S)))
284 (nreverse ans))))
285
286;;; Refresh / Query API
287;;
288;; Queries that can be made for the typecache.
289(defmethod semanticdb-typecache-file-tags ((table semanticdb-abstract-table))
290 "No tags available from non-file based tables."
291 nil)
292
293(defmethod semanticdb-typecache-file-tags ((table semanticdb-table))
294 "Update the typecache for TABLE, and return the file-tags.
295File-tags are those that belong to this file only, and excludes
296all included files."
297 (let* (;(idx (semanticdb-get-table-index table))
298 (cache (semanticdb-get-typecache table))
299 )
300
301 ;; Make sure our file-tags list is up to date.
302 (when (not (oref cache filestream))
303 (let ((tags (semantic-find-tags-by-class 'type table)))
304 (when tags
305 (setq tags (semanticdb-typecache-safe-tag-list tags table))
306 (oset cache filestream (semanticdb-typecache-merge-streams tags nil)))))
307
308 ;; Return our cache.
309 (oref cache filestream)
310 ))
311
312(defmethod semanticdb-typecache-include-tags ((table semanticdb-abstract-table))
313 "No tags available from non-file based tables."
314 nil)
315
316(defmethod semanticdb-typecache-include-tags ((table semanticdb-table))
317 "Update the typecache for TABLE, and return the merged types from the include tags.
318Include-tags are the tags brought in via includes, all merged together into
319a master list."
320 (let* ((cache (semanticdb-get-typecache table))
321 )
322
323 ;; Make sure our file-tags list is up to date.
324 (when (not (oref cache includestream))
325 (let (;; Calc the path first. This will have a nice side -effect of
326 ;; getting the cache refreshed if a refresh is needed. Most of the
327 ;; time this value is itself cached, so the query is fast.
328 (incpath (semanticdb-find-translate-path table nil))
329 (incstream nil))
330 ;; Get the translated path, and extract all the type tags, then merge
331 ;; them all together.
332 (dolist (i incpath)
333 ;; don't include ourselves in this crazy list.
334 (when (and i (not (eq i table))
335 ;; @todo - This eieio fcn can be slow! Do I need it?
336 ;; (semanticdb-table-child-p i)
337 )
338 (setq incstream
339 (semanticdb-typecache-merge-streams
340 incstream
341 ;; Getting the cache from this table will also cause this
342 ;; file to update it's cache from it's decendants.
343 ;;
344 ;; In theory, caches are only built for most includes
345 ;; only once (in the loop before this one), so this ends
346 ;; up being super fast as we edit our file.
347 (copy-sequence
348 (semanticdb-typecache-file-tags i))))
349 ))
350
351 ;; Save...
352 (oset cache includestream incstream)))
353
354 ;; Return our cache.
355 (oref cache includestream)
356 ))
357
358
359;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
360
361;;; Search Routines
362;;
363(define-overloadable-function semanticdb-typecache-find (type &optional path find-file-match)
364 "Search the typecache for TYPE in PATH.
365If type is a string, split the string, and search for the parts.
366If type is a list, treat the type as a pre-split string.
367PATH can be nil for the current buffer, or a semanticdb table.
368FIND-FILE-MATCH is non-nil to force all found tags to be loaded into a buffer.")
369
370(defun semanticdb-typecache-find-default (type &optional path find-file-match)
371 "Default implementation of `semanticdb-typecache-find'.
372TYPE is the datatype to find.
373PATH is the search path.. which should be one table object.
374If FIND-FILE-MATCH is non-nil, then force the file belonging to the
375found tag to be loaded."
376 (semanticdb-typecache-find-method (or path semanticdb-current-table)
377 type find-file-match))
378
379(defun semanticdb-typecache-find-by-name-helper (name table)
380 "Find the tag with NAME in TABLE, which is from a typecache.
381If more than one tag has NAME in TABLE, we will prefer the tag that
382is of class 'type."
383 (let* ((names (semantic-find-tags-by-name name table))
384 (types (semantic-find-tags-by-class 'type names)))
385 (or (car-safe types) (car-safe names))))
386
387(defmethod semanticdb-typecache-find-method ((table semanticdb-abstract-table)
388 type find-file-match)
389 "Search the typecache in TABLE for the datatype TYPE.
390If type is a string, split the string, and search for the parts.
391If type is a list, treat the type as a pre-split string.
392If FIND-FILE-MATCH is non-nil, then force the file belonging to the
393found tag to be loaded."
394 ;; convert string to a list.
395 (when (stringp type) (setq type (semantic-analyze-split-name type)))
396 (when (stringp type) (setq type (list type)))
397
398 ;; Search for the list in our typecache.
399 (let* ((file (semanticdb-typecache-file-tags table))
400 (inc (semanticdb-typecache-include-tags table))
401 (stream nil)
402 (f-ans nil)
403 (i-ans nil)
404 (ans nil)
405 (notdone t)
406 (lastfile nil)
407 (thisfile nil)
408 (lastans nil)
409 (calculated-scope nil)
410 )
411 ;; 1) Find first symbol in the two master lists and then merge
412 ;; the found streams.
413
414 ;; We stripped duplicates, so these will be super-fast!
415 (setq f-ans (semantic-find-first-tag-by-name (car type) file))
416 (setq i-ans (semantic-find-first-tag-by-name (car type) inc))
417 (if (and f-ans i-ans)
418 (progn
419 ;; This trick merges the two identified tags, making sure our lists are
420 ;; complete. The second find then gets the new 'master' from the list of 2.
421 (setq ans (semanticdb-typecache-merge-streams (list f-ans) (list i-ans)))
422 (setq ans (semantic-find-first-tag-by-name (car type) ans))
423 )
424
425 ;; The answers are already sorted and merged, so if one misses,
426 ;; no need to do any special work.
427 (setq ans (or f-ans i-ans)))
428
429 ;; 2) Loop over the remaining parts.
430 (while (and type notdone)
431
432 ;; For pass > 1, stream will be non-nil, so do a search, otherwise
433 ;; ans is from outside the loop.
434 (when stream
435 (setq ans (semanticdb-typecache-find-by-name-helper (car type) stream))
436
437 ;; NOTE: The below test to make sure we get a type is only relevant
438 ;; for the SECOND pass or later. The first pass can only ever
439 ;; find a type/namespace because everything else is excluded.
440
441 ;; If this is not the last entry from the list, then it
442 ;; must be a type or a namespace. Lets double check.
443 (when (cdr type)
444
445 ;; From above, there is only one tag in ans, and we prefer
446 ;; types.
447 (when (not (semantic-tag-of-class-p ans 'type))
448
449 (setq ans nil)))
450 )
451
452 (push ans calculated-scope)
453
454 ;; Track most recent file.
455 (setq thisfile (semantic-tag-file-name ans))
456 (when (and thisfile (stringp thisfile))
457 (setq lastfile thisfile))
458
459 ;; If we have a miss, exit, otherwise, update the stream to
460 ;; the next set of members.
461 (if (not ans)
462 (setq notdone nil)
463 (setq stream (semantic-tag-type-members ans)))
464
465 (setq lastans ans
466 ans nil
467 type (cdr type)))
468
469 (if (or type (not notdone))
470 ;; If there is stuff left over, then we failed. Just return
471 ;; nothing.
472 nil
473
474 ;; We finished, so return everything.
475
476 (if (and find-file-match lastfile)
477 ;; This won't liven up the tag since we have a copy, but
478 ;; we ought to be able to get there and go to the right line.
479 (find-file-noselect lastfile)
480 ;; We don't want to find-file match, so instead lets
481 ;; push the filename onto the return tag.
482 (when lastans
483 (setq lastans (semantic-tag-copy lastans nil lastfile))
484 ;; We used to do the below, but we would erroneously be putting
485 ;; attributes on tags being shred with other lists.
486 ;;(semantic--tag-put-property lastans :filename lastfile)
487 )
488 )
489
490 (if (and lastans calculated-scope)
491
492 ;; Put our discovered scope into the tag if we have a tag
493 (semantic-scope-tag-clone-with-scope
494 lastans (reverse (cdr calculated-scope)))
495
496 ;; Else, just return
497 lastans
498 ))))
499
500;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
501
502;;; BRUTISH Typecache
503;;
504;; Routines for a typecache that crosses all tables in a given database
505;; for a matching major-mode.
506(defmethod semanticdb-typecache-for-database ((db semanticdb-project-database)
507 &optional mode)
508 "Return the typecache for the project database DB.
509If there isn't one, create it.
510"
511 (let ((lmode (or mode major-mode))
512 (cache (semanticdb-get-typecache db))
513 (stream nil)
514 )
515 (dolist (table (semanticdb-get-database-tables db))
516 (when (eq lmode (oref table :major-mode))
517 (setq stream
518 (semanticdb-typecache-merge-streams
519 stream
520 (copy-sequence
521 (semanticdb-typecache-file-tags table))))
522 ))
523 (oset cache stream stream)
524 cache))
525
526(defun semanticdb-typecache-refresh-for-buffer (buffer)
527 "Refresh the typecache for BUFFER."
528 (save-excursion
529 (set-buffer buffer)
530 (let* ((tab semanticdb-current-table)
531 ;(idx (semanticdb-get-table-index tab))
532 (tc (semanticdb-get-typecache tab)))
533 (semanticdb-typecache-file-tags tab)
534 (semanticdb-typecache-include-tags tab)
535 tc)))
536
537
538;;; DEBUG
539;;
540(defun semanticdb-typecache-complete-flush ()
541 "Flush all typecaches referenced by the current buffer."
542 (interactive)
543 (let* ((path (semanticdb-find-translate-path nil nil)))
544 (dolist (P path)
545 (oset P pointmax nil)
546 (semantic-reset (semanticdb-get-typecache P)))))
547
548(defun semanticdb-typecache-dump ()
549 "Dump the typecache for the current buffer."
550 (interactive)
551 (require 'data-debug)
552 (let* ((start (current-time))
553 (tc (semanticdb-typecache-refresh-for-buffer (current-buffer)))
554 (end (current-time))
555 )
556 (data-debug-new-buffer "*TypeCache ADEBUG*")
557 (message "Calculating Cache took %.2f seconds."
558 (semantic-elapsed-time start end))
559
560 (data-debug-insert-thing tc "]" "")
561
562 ))
563
564(defun semanticdb-db-typecache-dump ()
565 "Dump the typecache for the current buffer's database."
566 (interactive)
567 (require 'data-debug)
568 (let* ((tab semanticdb-current-table)
569 (idx (semanticdb-get-table-index tab))
570 (junk (oset idx type-cache nil)) ;; flush!
571 (start (current-time))
572 (tc (semanticdb-typecache-for-database (oref tab parent-db)))
573 (end (current-time))
574 )
575 (data-debug-new-buffer "*TypeCache ADEBUG*")
576 (message "Calculating Cache took %.2f seconds."
577 (semantic-elapsed-time start end))
578
579 (data-debug-insert-thing tc "]" "")
580
581 ))
582
583
584(provide 'semantic/db-typecache)
585;;; 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 @@
1;;; dep.el --- Methods for tracking dependencies (include files)
2
3;;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <zappo@gnu.org>
6;; Keywords: syntax
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; Include tags (dependencies for a given source file) usually have
26;; some short name. The target file that it is dependent on is
27;; generally found on some sort of path controlled by the compiler or
28;; project.
29;;
30;; EDE or even ECB can control our project dependencies, and help us
31;; find file within the setting of a given project. For system
32;; dependencies, we need to depend on user supplied lists, which can
33;; manifest themselves in the form of system datatabases (from
34;; semanticdb.)
35;;
36;; Provide ways to track these different files here.
37
38(require 'semantic/tag)
39
40;;; Code:
41
42(defvar semantic-dependency-include-path nil
43 "Defines the include path used when searching for files.
44This should be a list of directories to search which is specific
45to the file being included.
46
47If `semantic-dependency-tag-file' is overridden for a given
48language, this path is most likely ignored.
49
50The above function, reguardless of being overriden, caches the
51located dependency file location in the tag property
52`dependency-file'. If you override this function, you do not
53need to implement your own cache. Each time the buffer is fully
54reparsed, the cache will be reset.
55
56TODO: use ffap.el to locate such items?
57
58NOTE: Obsolete this, or use as special user")
59(make-variable-buffer-local `semantic-dependency-include-path)
60
61(defvar semantic-dependency-system-include-path nil
62 "Defines the system include path.
63This should be set with either `defvar-mode-local', or with
64`semantic-add-system-include'.
65
66For mode authors, use
67`defcustom-mode-local-semantic-dependency-system-include-path'
68to create a mode-specific variable to control this.
69
70When searching for a file associated with a name found in an tag of
71class include, this path will be inspected for includes of type
72`system'. Some include tags are agnostic to this setting and will
73check both the project and system directories.")
74(make-variable-buffer-local `semantic-dependency-system-include-path)
75
76(defmacro defcustom-mode-local-semantic-dependency-system-include-path
77 (mode name value &optional docstring)
78 "Create a mode-local value of the system-dependency include path.
79MODE is the `major-mode' this name/value pairs is for.
80NAME is the name of the customizable value users will use.
81VALUE is the path (a list of strings) to add.
82DOCSTRING is a documentation string applied to the variable NAME
83users will customize.
84
85Creates a customizable variable users can customize that will
86keep semantic data structures up to date."
87 `(progn
88 ;; Create a variable users can customize.
89 (defcustom ,name ,value
90 ,docstring
91 :group (quote ,(intern (car (split-string (symbol-name mode) "-"))))
92 :group 'semantic
93 :type '(repeat (directory :tag "Directory"))
94 :set (lambda (sym val)
95 (set-default sym val)
96 (setq-mode-local ,mode
97 semantic-dependency-system-include-path
98 val)
99 (when (fboundp
100 'semantic-decoration-unparsed-include-do-reset)
101 (mode-local-map-mode-buffers
102 'semantic-decoration-unparsed-include-do-reset
103 (quote ,mode))))
104 )
105 ;; Set the variable to the default value.
106 (defvar-mode-local ,mode semantic-dependency-system-include-path
107 ,name
108 "System path to search for include files.")
109 ;; Bind NAME onto our variable so tools can customize it
110 ;; without knowing about it.
111 (put 'semantic-dependency-system-include-path
112 (quote ,mode) (quote ,name))
113 ))
114
115;;; PATH MANAGEMENT
116;;
117;; Some fcns to manage paths for a give mode.
118(defun semantic-add-system-include (dir &optional mode)
119 "Add a system include DIR to path for MODE.
120Modifies a mode-local version of `semantic-dependency-system-include-path'.
121
122Changes made by this function are not persistent."
123 (interactive "DNew Include Directory: ")
124 (if (not mode) (setq mode major-mode))
125 (let ((dirtmp (file-name-as-directory dir))
126 (value
127 (mode-local-value mode 'semantic-dependency-system-include-path))
128 )
129 (add-to-list 'value dirtmp t)
130 (eval `(setq-mode-local ,mode
131 semantic-dependency-system-include-path value))
132 ))
133
134(defun semantic-remove-system-include (dir &optional mode)
135 "Add a system include DIR to path for MODE.
136Modifies a mode-local version of`semantic-dependency-system-include-path'.
137
138Changes made by this function are not persistent."
139 (interactive (list
140 (completing-read
141 "Include Directory to Remove: "
142 semantic-dependency-system-include-path))
143 )
144 (if (not mode) (setq mode major-mode))
145 (let ((dirtmp (file-name-as-directory dir))
146 (value
147 (mode-local-value mode 'semantic-dependency-system-include-path))
148 )
149 (setq value (delete dirtmp value))
150 (eval `(setq-mode-local ,mode semantic-dependency-system-include-path
151 value))
152 ))
153
154(defun semantic-reset-system-include (&optional mode)
155 "Reset the system include list to empty for MODE.
156Modifies a mode-local version of
157`semantic-dependency-system-include-path'."
158 (interactive)
159 (if (not mode) (setq mode major-mode))
160 (eval `(setq-mode-local ,mode semantic-dependency-system-include-path
161 nil))
162 )
163
164(defun semantic-customize-system-include-path (&optional mode)
165 "Customize the include path for this `major-mode'.
166To create a customizable include path for a major MODE, use the
167macro `defcustom-mode-local-semantic-dependency-system-include-path'."
168 (interactive)
169 (let ((ips (get 'semantic-dependency-system-include-path
170 (or mode major-mode))))
171 ;; Do we have one?
172 (when (not ips)
173 (error "There is no customizable includepath variable for %s"
174 (or mode major-mode)))
175 ;; Customize it.
176 (customize-variable ips)))
177
178;;; PATH SEARCH
179;;
180;; methods for finding files on a provided path.
181(if (fboundp 'locate-file)
182 (defsubst semantic--dependency-find-file-on-path (file path)
183 "Return an expanded file name for FILE on PATH."
184 (locate-file file path))
185
186 ;; Else, older version of Emacs.
187
188 (defsubst semantic--dependency-find-file-on-path (file path)
189 "Return an expanded file name for FILE on PATH."
190 (let ((p path)
191 (found nil))
192 (while (and p (not found))
193 (let ((f (expand-file-name file (car p))))
194 (if (file-exists-p f)
195 (setq found f)))
196 (setq p (cdr p)))
197 found))
198
199 )
200
201(defun semantic-dependency-find-file-on-path (file systemp &optional mode)
202 "Return an expanded file name for FILE on available paths.
203If SYSTEMP is true, then only search system paths.
204If optional argument MODE is non-nil, then derive paths from the
205provided mode, not from the current major mode."
206 (if (not mode) (setq mode major-mode))
207 (let ((sysp (mode-local-value
208 mode 'semantic-dependency-system-include-path))
209 (edesys (when (and (featurep 'ede) ede-minor-mode
210 ede-object)
211 (ede-system-include-path ede-object)))
212 (locp (mode-local-value
213 mode 'semantic-dependency-include-path))
214 (found nil))
215 (when (file-exists-p file)
216 (setq found file))
217 (when (and (not found) (not systemp))
218 (setq found (semantic--dependency-find-file-on-path file locp)))
219 (when (and (not found) edesys)
220 (setq found (semantic--dependency-find-file-on-path file edesys)))
221 (when (not found)
222 (setq found (semantic--dependency-find-file-on-path file sysp)))
223 (if found (expand-file-name found))))
224
225
226(provide 'semantic/dep)
227
228;;; 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 @@
1;;; ia.el --- Interactive Analysis functions
2
3;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
4;;; 2008, 2009 Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Keywords: syntax
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25;;
26;; Interactive access to `semantic-analyze'.
27;;
28;; These routines are fairly simple, and show how to use the Semantic
29;; analyzer to provide things such as completion lists, summaries,
30;; locations, or documentation.
31;;
32
33;;; TODO
34;;
35;; fast-jump. For a virtual method, offer some of the possible
36;; implementations in various sub-classes.
37
38(require 'senator)
39(require 'semantic/analyze)
40(require 'pulse)
41(eval-when-compile
42 (require 'semantic/analyze)
43 (require 'semantic/analyze/refs))
44
45;;; Code:
46
47;;; COMPLETION
48;;
49;; This set of routines provides some simplisting completion
50;; functions.
51
52(defcustom semantic-ia-completion-format-tag-function
53 'semantic-prototype-nonterminal
54 "*Function used to convert a tag to a string during completion."
55 :group 'semantic
56 :type semantic-format-tag-custom-list)
57
58(defvar semantic-ia-cache nil
59 "Cache of the last completion request.
60Of the form ( POINT . COMPLETIONS ) where POINT is a location in the
61buffer where the completion was requested. COMPLETONS is the list
62of semantic tag names that provide logical completions from that
63location.")
64(make-variable-buffer-local 'semantic-ia-cache)
65
66(defun semantic-ia-get-completions (context point)
67 "Fetch the completion of CONTEXT at POINT.
68Supports caching."
69 ;; Cache the current set of symbols so that we can get at
70 ;; them quickly the second time someone presses the
71 ;; complete button.
72 (let ((symbols
73 (if (and semantic-ia-cache
74 (= point (car semantic-ia-cache)))
75 (cdr semantic-ia-cache)
76 (semantic-analyze-possible-completions context))))
77 ;; Set the cache
78 (setq semantic-ia-cache (cons point symbols))
79 symbols))
80
81(defun semantic-ia-complete-symbol (point)
82 "Complete the current symbol at POINT.
83Completion options are calculated with `semantic-analyze-possible-completions'."
84 (interactive "d")
85 ;; Calculating completions is a two step process.
86 ;;
87 ;; The first analyzer the current context, which finds tags
88 ;; for all the stuff that may be references by the code around
89 ;; POINT.
90 ;;
91 ;; The second step derives completions from that context.
92 (let* ((a (semantic-analyze-current-context point))
93 (syms (semantic-ia-get-completions a point))
94 (pre (car (reverse (oref a prefix))))
95 )
96 ;; If PRE was actually an already completed symbol, it doesn't
97 ;; come in as a string, but as a tag instead.
98 (if (semantic-tag-p pre)
99 ;; We will try completions on it anyway.
100 (setq pre (semantic-tag-name pre)))
101 ;; Complete this symbol.
102 (if (null syms)
103 (progn
104 ;(message "No smart completions found. Trying senator-complete-symbol.")
105 (if (semantic-analyze-context-p a)
106 ;; This is a clever hack. If we were unable to find any
107 ;; smart completions, lets divert to how senator derives
108 ;; completions.
109 ;;
110 ;; This is a way of making this fcn more useful since the
111 ;; smart completion engine sometimes failes.
112 (senator-complete-symbol)
113 ))
114 ;; Use try completion to seek a common substring.
115 (let ((tc (try-completion (or pre "") syms)))
116 (if (and (stringp tc) (not (string= tc (or pre ""))))
117 (let ((tok (semantic-find-first-tag-by-name
118 tc syms)))
119 ;; Delete what came before...
120 (when (and (car (oref a bounds)) (cdr (oref a bounds)))
121 (delete-region (car (oref a bounds))
122 (cdr (oref a bounds)))
123 (goto-char (car (oref a bounds))))
124 ;; We have some new text. Stick it in.
125 (if tok
126 (semantic-ia-insert-tag tok)
127 (insert tc)))
128 ;; We don't have new text. Show all completions.
129 (when (cdr (oref a bounds))
130 (goto-char (cdr (oref a bounds))))
131 (with-output-to-temp-buffer "*Completions*"
132 (display-completion-list
133 (mapcar semantic-ia-completion-format-tag-function syms))
134 ))))))
135
136(defcustom semantic-ia-completion-menu-format-tag-function
137 'semantic-uml-concise-prototype-nonterminal
138 "*Function used to convert a tag to a string during completion."
139 :group 'semantic
140 :type semantic-format-tag-custom-list)
141
142(defun semantic-ia-complete-symbol-menu (point)
143 "Complete the current symbol via a menu based at POINT.
144Completion options are calculated with `semantic-analyze-possible-completions'."
145 (interactive "d")
146 (let* ((a (semantic-analyze-current-context point))
147 (syms (semantic-ia-get-completions a point))
148 )
149 ;; Complete this symbol.
150 (if (not syms)
151 (progn
152 (message "No smart completions found. Trying Senator.")
153 (when (semantic-analyze-context-p a)
154 ;; This is a quick way of getting a nice completion list
155 ;; in the menu if the regular context mechanism fails.
156 (senator-completion-menu-popup)))
157
158 (let* ((menu
159 (mapcar
160 (lambda (tag)
161 (cons
162 (funcall semantic-ia-completion-menu-format-tag-function tag)
163 (vector tag)))
164 syms))
165 (ans
166 (imenu--mouse-menu
167 ;; XEmacs needs that the menu has at least 2 items. So,
168 ;; include a nil item that will be ignored by imenu.
169 (cons nil menu)
170 (senator-completion-menu-point-as-event)
171 "Completions")))
172 (when ans
173 (if (not (semantic-tag-p ans))
174 (setq ans (aref (cdr ans) 0)))
175 (delete-region (car (oref a bounds)) (cdr (oref a bounds)))
176 (semantic-ia-insert-tag ans))
177 ))))
178
179;;; COMPLETION HELPER
180;;
181;; This overload function handles inserting a tag
182;; into a buffer for these local completion routines.
183;;
184;; By creating the functions as overloadable, it can be
185;; customized. For example, the default will put a paren "("
186;; character after function names. For Lisp, it might check
187;; to put a "(" in front of a function name.
188
189(define-overloadable-function semantic-ia-insert-tag (tag)
190 "Insert TAG into the current buffer based on completion.")
191
192(defun semantic-ia-insert-tag-default (tag)
193 "Insert TAG into the current buffer based on completion."
194 (insert (semantic-tag-name tag))
195 (let ((tt (semantic-tag-class tag)))
196 (cond ((eq tt 'function)
197 (insert "("))
198 (t nil))))
199
200;;; Completions Tip
201;;
202;; This functions shows how to get the list of completions,
203;; to place in a tooltip. It doesn't actually do any completion.
204
205(defun semantic-ia-complete-tip (point)
206 "Pop up a tooltip for completion at POINT."
207 (interactive "d")
208 (let* ((a (semantic-analyze-current-context point))
209 (syms (semantic-ia-get-completions a point))
210 (x (mod (- (current-column) (window-hscroll))
211 (window-width)))
212 (y (save-excursion
213 (save-restriction
214 (widen)
215 (narrow-to-region (window-start) (point))
216 (goto-char (point-min))
217 (1+ (vertical-motion (buffer-size))))))
218 (str (mapconcat #'semantic-tag-name
219 syms
220 "\n"))
221 )
222 (cond ((fboundp 'x-show-tip)
223 (x-show-tip str
224 (selected-frame)
225 nil
226 nil
227 x y)
228 )
229 (t (message str))
230 )))
231
232;;; Summary
233;;
234;; Like idle-summary-mode, this shows how to get something to
235;; show a summary on.
236
237(defun semantic-ia-show-summary (point)
238 "Display a summary for the symbol under POINT."
239 (interactive "P")
240 (let* ((ctxt (semantic-analyze-current-context point))
241 (pf (when ctxt
242 ;; The CTXT is an EIEIO object. The below
243 ;; method will attempt to pick the most interesting
244 ;; tag associated with the current context.
245 (semantic-analyze-interesting-tag ctxt)))
246 )
247 (when pf
248 (message "%s" (semantic-format-tag-summarize pf nil t)))))
249
250;;; FAST Jump
251;;
252;; Jump to a destination based on the local context.
253;;
254;; This shows how to use the analyzer context, and the
255;; analyer references objects to choose a good destination.
256
257(defun semantic-ia--fast-jump-helper (dest)
258 "Jump to DEST, a Semantic tag.
259This helper manages the mark, buffer switching, and pulsing."
260 ;; We have a tag, but in C++, we usually get a prototype instead
261 ;; because of header files. Lets try to find the actual
262 ;; implementaion instead.
263 (when (semantic-tag-prototype-p dest)
264 (let* ((refs (semantic-analyze-tag-references dest))
265 (impl (semantic-analyze-refs-impl refs t))
266 )
267 (when impl (setq dest (car impl)))))
268
269 ;; Make sure we have a place to go...
270 (if (not (and (or (semantic-tag-with-position-p dest)
271 (semantic-tag-get-attribute dest :line))
272 (semantic-tag-file-name dest)))
273 (error "Tag %s has no buffer information"
274 (semantic-format-tag-name dest)))
275
276 ;; Once we have the tag, we can jump to it. Here
277 ;; are the key bits to the jump:
278
279 ;; 1) Push the mark, so you can pop global mark back, or
280 ;; use semantic-mru-bookmark mode to do so.
281 (push-mark)
282 (when (fboundp 'push-tag-mark)
283 (push-tag-mark))
284 ;; 2) Visits the tag.
285 (semantic-go-to-tag dest)
286 ;; 3) go-to-tag doesn't switch the buffer in the current window,
287 ;; so it is like find-file-noselect. Bring it forward.
288 (switch-to-buffer (current-buffer))
289 ;; 4) Fancy pulsing.
290 (pulse-momentary-highlight-one-line (point))
291 )
292
293(defun semantic-ia-fast-jump (point)
294 "Jump to the tag referred to by the code at POINT.
295Uses `semantic-analyze-current-context' output to identify an accurate
296origin of the code at point."
297 (interactive "d")
298 (let* ((ctxt (semantic-analyze-current-context point))
299 (pf (and ctxt (reverse (oref ctxt prefix))))
300 ;; In the analyzer context, the PREFIX is the list of items
301 ;; that makes up the code context at point. Thus the c++ code
302 ;; this.that().theothe
303 ;; would make a list:
304 ;; ( ("this" variable ..) ("that" function ...) "theothe")
305 ;; Where the first two elements are the semantic tags of the prefix.
306 ;;
307 ;; PF is the reverse of this list. If the first item is a string,
308 ;; then it is an incomplete symbol, thus we pick the second.
309 ;; The second cannot be a string, as that would have been an error.
310 (first (car pf))
311 (second (nth 1 pf))
312 )
313 (cond
314 ((semantic-tag-p first)
315 ;; We have a match. Just go there.
316 (semantic-ia--fast-jump-helper first))
317
318 ((semantic-tag-p second)
319 ;; Because FIRST failed, we should visit our second tag.
320 ;; HOWEVER, the tag we actually want that was only an unfound
321 ;; string may be related to some take in the datatype that belongs
322 ;; to SECOND. Thus, instead of visiting second directly, we
323 ;; can offer to find the type of SECOND, and go there.
324 (let ((secondclass (car (reverse (oref ctxt prefixtypes)))))
325 (cond
326 ((and (semantic-tag-with-position-p secondclass)
327 (y-or-n-p (format "Could not find `%s'. Jump to %s? "
328 first (semantic-tag-name secondclass))))
329 (semantic-ia--fast-jump-helper secondclass)
330 )
331 ;; If we missed out on the class of the second item, then
332 ;; just visit SECOND.
333 ((and (semantic-tag-p second)
334 (y-or-n-p (format "Could not find `%s'. Jump to %s? "
335 first (semantic-tag-name second))))
336 (semantic-ia--fast-jump-helper second)
337 ))))
338
339 ((semantic-tag-of-class-p (semantic-current-tag) 'include)
340 ;; Just borrow this cool fcn.
341 (semantic-decoration-include-visit)
342 )
343
344 (t
345 (error "Could not find suitable jump point for %s"
346 first))
347 )))
348
349(defun semantic-ia-fast-mouse-jump (evt)
350 "Jump to the tag referred to by the point clicked on.
351See `semantic-ia-fast-jump' for details on how it works.
352 This command is meant to be bound to a mouse event."
353 (interactive "e")
354 (semantic-ia-fast-jump
355 (save-excursion
356 (posn-set-point (event-end evt))
357 (point))))
358
359;;; DOC/DESCRIBE
360;;
361;; These routines show how to get additional information about a tag
362;; for purposes of describing or showing documentation about them.
363(defun semantic-ia-show-doc (point)
364 "Display the code-level documentation for the symbol at POINT."
365 (interactive "d")
366 (let* ((ctxt (semantic-analyze-current-context point))
367 (pf (reverse (oref ctxt prefix)))
368 )
369 ;; If PF, the prefix is non-nil, then the last element is either
370 ;; a string (incomplete type), or a semantic TAG. If it is a TAG
371 ;; then we should be able to find DOC for it.
372 (cond
373 ((stringp (car pf))
374 (message "Incomplete symbol name."))
375 ((semantic-tag-p (car pf))
376 ;; The `semantic-documentation-for-tag' fcn is language
377 ;; specific. If it doesn't return what you expect, you may
378 ;; need to implement something for your language.
379 ;;
380 ;; The default tries to find a comment in front of the tag
381 ;; and then strings off comment prefixes.
382 (let ((doc (semantic-documentation-for-tag (car pf))))
383 (with-output-to-temp-buffer "*TAG DOCUMENTATION*"
384 (princ "Tag: ")
385 (princ (semantic-format-tag-prototype (car pf)))
386 (princ "\n")
387 (princ "\n")
388 (princ "Snarfed Documentation: ")
389 (princ "\n")
390 (princ "\n")
391 (if doc
392 (princ doc)
393 (princ " Documentation unavailable."))
394 )))
395 (t
396 (message "Unknown tag.")))
397 ))
398
399(defun semantic-ia-describe-class (typename)
400 "Display all known parts for the datatype TYPENAME.
401If the type in question is a class, all methods and other accessible
402parts of the parent classes are displayed."
403 ;; @todo - use a fancy completing reader.
404 (interactive "sType Name: ")
405
406 ;; When looking for a tag of any name there are a couple ways to do
407 ;; it. The simple `semanticdb-find-tag-by-...' are simple, and
408 ;; you need to pass it the exact name you want.
409 ;;
410 ;; The analyzer function `semantic-analyze-tag-name' will take
411 ;; more complex names, such as the cpp symbol foo::bar::baz,
412 ;; and break it up, and dive through the namespaces.
413 (let ((class (semantic-analyze-find-tag typename)))
414
415 (when (not (semantic-tag-p class))
416 (error "Cannot find class %s" class))
417 (with-output-to-temp-buffer "*TAG DOCUMENTATION*"
418 ;; There are many semantic-format-tag-* fcns.
419 ;; The summarize routine is a fairly generic one.
420 (princ (semantic-format-tag-summarize class))
421 (princ "\n")
422 (princ " Type Members:\n")
423 ;; The type tag contains all the parts of the type.
424 ;; In complex languages with inheritance, not all the
425 ;; parts are in the tag. This analyzer fcn will traverse
426 ;; the inheritance tree, and find all the pieces that
427 ;; are inherited.
428 (let ((parts (semantic-analyze-scoped-type-parts class)))
429 (while parts
430 (princ " ")
431 (princ (semantic-format-tag-summarize (car parts)))
432 (princ "\n")
433 (setq parts (cdr parts)))
434 )
435 )))
436
437(provide 'semantic/ia)
438
439;;; 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 @@
1;;; tag-file.el --- Routines that find files based on tags.
2
3;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
4;;; 2008, 2009 Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7;; Keywords: syntax
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25;;
26;; A tag, by itself, can have representations in several files.
27;; These routines will find those files.
28
29(require 'semantic/tag)
30
31;;; Code:
32
33;;; Location a TAG came from.
34;;
35(define-overloadable-function semantic-go-to-tag (tag &optional parent)
36 "Go to the location of TAG.
37TAG may be a stripped element, in which case PARENT specifies a
38parent tag that has position information.
39PARENT can also be a `semanticdb-table' object."
40 (:override
41 (cond ((semantic-tag-in-buffer-p tag)
42 ;; We have a linked tag, go to that buffer.
43 (set-buffer (semantic-tag-buffer tag)))
44 ((semantic-tag-file-name tag)
45 ;; If it didn't have a buffer, but does have a file
46 ;; name, then we need to get to that file so the tag
47 ;; location is made accurate.
48 (set-buffer (find-file-noselect (semantic-tag-file-name tag))))
49 ((and parent (semantic-tag-p parent) (semantic-tag-in-buffer-p parent))
50 ;; The tag had nothing useful, but we have a parent with
51 ;; a buffer, then go there.
52 (set-buffer (semantic-tag-buffer parent)))
53 ((and parent (semantic-tag-p parent) (semantic-tag-file-name parent))
54 ;; Tag had nothing, and the parent only has a file-name, then
55 ;; find that file, and switch to that buffer.
56 (set-buffer (find-file-noselect (semantic-tag-file-name parent))))
57 ((and parent (semanticdb-table-child-p parent))
58 (set-buffer (semanticdb-get-buffer parent)))
59 (t
60 ;; Well, just assume things are in the current buffer.
61 nil
62 ))
63 ;; We should be in the correct buffer now, try and figure out
64 ;; where the tag is.
65 (cond ((semantic-tag-with-position-p tag)
66 ;; If it's a number, go there
67 (goto-char (semantic-tag-start tag)))
68 ((semantic-tag-with-position-p parent)
69 ;; Otherwise, it's a trimmed vector, such as a parameter,
70 ;; or a structure part. If there is a parent, we can use it
71 ;; as a bounds for searching.
72 (goto-char (semantic-tag-start parent))
73 ;; Here we make an assumption that the text returned by
74 ;; the parser and concocted by us actually exists
75 ;; in the buffer.
76 (re-search-forward (semantic-tag-name tag)
77 (semantic-tag-end parent)
78 t))
79 ((semantic-tag-get-attribute tag :line)
80 ;; The tag has a line number in it. Go there.
81 (goto-line (semantic-tag-get-attribute tag :line)))
82 ((and (semantic-tag-p parent) (semantic-tag-get-attribute parent :line))
83 ;; The tag has a line number in it. Go there.
84 (goto-line (semantic-tag-get-attribute parent :line))
85 (re-search-forward (semantic-tag-name tag) nil t)
86 )
87 (t
88 ;; Take a guess that the tag has a unique name, and just
89 ;; search for it from the beginning of the buffer.
90 (goto-char (point-min))
91 (re-search-forward (semantic-tag-name tag) nil t)))
92 )
93 )
94
95(make-obsolete-overload 'semantic-find-nonterminal
96 'semantic-go-to-tag)
97
98;;; Dependencies
99;;
100;; A tag which is of type 'include specifies a dependency.
101;; Dependencies usually represent a file of some sort.
102;; Find the file described by a dependency.
103
104(define-overloadable-function semantic-dependency-tag-file (&optional tag)
105 "Find the filename represented from TAG.
106Depends on `semantic-dependency-include-path' for searching. Always searches
107`.' first, then searches additional paths."
108 (or tag (setq tag (car (semantic-find-tag-by-overlay nil))))
109 (unless (semantic-tag-of-class-p tag 'include)
110 (signal 'wrong-type-argument (list tag 'include)))
111 (save-excursion
112 (let ((result nil)
113 (default-directory default-directory)
114 (edefind nil)
115 (tag-fname nil))
116 (cond ((semantic-tag-in-buffer-p tag)
117 ;; If the tag has an overlay and buffer associated with it,
118 ;; switch to that buffer so that we get the right override metohds.
119 (set-buffer (semantic-tag-buffer tag)))
120 ((semantic-tag-file-name tag)
121 ;; If it didn't have a buffer, but does have a file
122 ;; name, then we need to get to that file so the tag
123 ;; location is made accurate.
124 ;;(set-buffer (find-file-noselect (semantic-tag-file-name tag)))
125 ;;
126 ;; 2/3/08
127 ;; The above causes unnecessary buffer loads all over the place. Ick!
128 ;; All we really need is for 'default-directory' to be set correctly.
129 (setq default-directory (file-name-directory (semantic-tag-file-name tag)))
130 ))
131 ;; Setup the filename represented by this include
132 (setq tag-fname (semantic-tag-include-filename tag))
133
134 ;; First, see if this file exists in the current EDE project
135 (if (and (fboundp 'ede-expand-filename) ede-minor-mode
136 (setq edefind
137 (condition-case nil
138 (let ((proj (ede-toplevel)))
139 (when proj
140 (ede-expand-filename proj tag-fname)))
141 (error nil))))
142 (setq result edefind))
143 (if (not result)
144 (setq result
145 ;; I don't have a plan for refreshing tags with a dependency
146 ;; stuck on them somehow. I'm thinking that putting a cache
147 ;; onto the dependancy finding with a hash table might be best.
148 ;;(if (semantic--tag-get-property tag 'dependency-file)
149 ;; (semantic--tag-get-property tag 'dependency-file)
150 (:override
151 (save-excursion
152 (semantic-dependency-find-file-on-path
153 tag-fname (semantic-tag-include-system-p tag))))
154 ;; )
155 ))
156 (if (stringp result)
157 (progn
158 (semantic--tag-put-property tag 'dependency-file result)
159 result)
160 ;; @todo: Do something to make this get flushed w/
161 ;; when the path is changed.
162 ;; @undo: Just eliminate
163 ;; (semantic--tag-put-property tag 'dependency-file 'none)
164 nil)
165 )))
166
167(make-obsolete-overload 'semantic-find-dependency
168 'semantic-dependency-tag-file)
169
170;;; PROTOTYPE FILE
171;;
172;; In C, a function in the .c file often has a representation in a
173;; corresponding .h file. This routine attempts to find the
174;; prototype file a given source file would be associated with.
175;; This can be used by prototype manager programs.
176(define-overloadable-function semantic-prototype-file (buffer)
177 "Return a file in which prototypes belonging to BUFFER should be placed.
178Default behavior (if not overridden) looks for a token specifying the
179prototype file, or the existence of an EDE variable indicating which
180file prototypes belong in."
181 (:override
182 ;; Perform some default behaviors
183 (if (and (fboundp 'ede-header-file) ede-minor-mode)
184 (save-excursion
185 (set-buffer buffer)
186 (ede-header-file))
187 ;; No EDE options for a quick answer. Search.
188 (save-excursion
189 (set-buffer buffer)
190 (if (re-search-forward "::Header:: \\([a-zA-Z0-9.]+\\)" nil t)
191 (match-string 1))))))
192
193(semantic-alias-obsolete 'semantic-find-nonterminal
194 'semantic-go-to-tag)
195
196(semantic-alias-obsolete 'semantic-find-dependency
197 'semantic-dependency-tag-file)
198
199
200(provide 'semantic/tag-file)
201
202;;; 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 @@
1;;; tag-ls.el --- Language Specific override functions for tags
2
3;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008
4;;; Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; There are some features of tags that are too langauge dependent to
26;; put in the core `semantic-tag' functionality. For instance, the
27;; protection of a tag (as specified by UML) could be almost anything.
28;; In Java, it is a type specifier. In C, there is a label. This
29;; informatin can be derived, and thus should not be stored in the tag
30;; itself. These are the functions that languages can use to derive
31;; the information.
32
33(require 'semantic/tag)
34
35;;; Code:
36
37;;; UML features:
38;;
39;; UML can represent several types of features of a tag
40;; such as the `protection' of a symbol, or if it is abstract,
41;; leaf, etc. Learn about UML to catch onto the lingo.
42
43(define-overloadable-function semantic-tag-calculate-parent (tag)
44 "Attempt to calculate the parent of TAG.
45The default behavior (if not overriden with `tag-calculate-parent')
46is to search a buffer found with TAG, and if externally defined,
47search locally, then semanticdb for that tag (when enabled.)")
48
49(defun semantic-tag-calculate-parent-default (tag)
50 "Attempt to calculate the parent of TAG."
51 (when (semantic-tag-in-buffer-p tag)
52 (save-excursion
53 (set-buffer (semantic-tag-buffer tag))
54 (save-excursion
55 (goto-char (semantic-tag-start tag))
56 (semantic-current-tag-parent))
57 )))
58
59(define-overloadable-function semantic-tag-protection (tag &optional parent)
60 "Return protection information about TAG with optional PARENT.
61This function returns on of the following symbols:
62 nil - No special protection. Language dependent.
63 'public - Anyone can access this TAG.
64 'private - Only methods in the local scope can access TAG.
65 'protected - Like private for outside scopes, like public for child
66 classes.
67Some languages may choose to provide additional return symbols specific
68to themselves. Use of this function should allow for this.
69
70The default behavior (if not overridden with `tag-protection'
71is to return a symbol based on type modifiers."
72 (and (not parent)
73 (semantic-tag-overlay tag)
74 (semantic-tag-in-buffer-p tag)
75 (setq parent (semantic-tag-calculate-parent tag)))
76 (:override))
77
78(make-obsolete-overload 'semantic-nonterminal-protection
79 'semantic-tag-protection)
80
81(defun semantic-tag-protection-default (tag &optional parent)
82 "Return the protection of TAG as a child of PARENT default action.
83See `semantic-tag-protection'."
84 (let ((mods (semantic-tag-modifiers tag))
85 (prot nil))
86 (while (and (not prot) mods)
87 (if (stringp (car mods))
88 (let ((s (car mods)))
89 (setq prot
90 ;; A few silly defaults to get things started.
91 (cond ((or (string= s "public")
92 (string= s "extern")
93 (string= s "export"))
94 'public)
95 ((string= s "private")
96 'private)
97 ((string= s "protected")
98 'protected)))))
99 (setq mods (cdr mods)))
100 prot))
101
102(defun semantic-tag-protected-p (tag protection &optional parent)
103 "Non-nil if TAG is is protected.
104PROTECTION is a symbol which can be returned by the method
105`semantic-tag-protection'.
106PARENT is the parent data type which contains TAG.
107
108For these PROTECTIONs, true is returned if TAG is:
109@table @asis
110@item nil
111 Always true
112@item private
113 True if nil.
114@item protected
115 True if private or nil.
116@item public
117 True if private, protected, or nil.
118@end table"
119 (if (null protection)
120 t
121 (let ((tagpro (semantic-tag-protection tag parent)))
122 (or (and (eq protection 'private)
123 (null tagpro))
124 (and (eq protection 'protected)
125 (or (null tagpro)
126 (eq tagpro 'private)))
127 (and (eq protection 'public)
128 (not (eq tagpro 'public)))))
129 ))
130
131(define-overloadable-function semantic-tag-abstract-p (tag &optional parent)
132 "Return non nil if TAG is abstract.
133Optional PARENT is the parent tag of TAG.
134In UML, abstract methods and classes have special meaning and behavior
135in how methods are overridden. In UML, abstract methods are italicized.
136
137The default behavior (if not overridden with `tag-abstract-p'
138is to return true if `abstract' is in the type modifiers.")
139
140(make-obsolete-overload 'semantic-nonterminal-abstract
141 'semantic-tag-abstract-p)
142
143(defun semantic-tag-abstract-p-default (tag &optional parent)
144 "Return non-nil if TAG is abstract as a child of PARENT default action.
145See `semantic-tag-abstract-p'."
146 (let ((mods (semantic-tag-modifiers tag))
147 (abs nil))
148 (while (and (not abs) mods)
149 (if (stringp (car mods))
150 (setq abs (or (string= (car mods) "abstract")
151 (string= (car mods) "virtual"))))
152 (setq mods (cdr mods)))
153 abs))
154
155(define-overloadable-function semantic-tag-leaf-p (tag &optional parent)
156 "Return non nil if TAG is leaf.
157Optional PARENT is the parent tag of TAG.
158In UML, leaf methods and classes have special meaning and behavior.
159
160The default behavior (if not overridden with `tag-leaf-p'
161is to return true if `leaf' is in the type modifiers.")
162
163(make-obsolete-overload 'semantic-nonterminal-leaf
164 'semantic-tag-leaf-p)
165
166(defun semantic-tag-leaf-p-default (tag &optional parent)
167 "Return non-nil if TAG is leaf as a child of PARENT default action.
168See `semantic-tag-leaf-p'."
169 (let ((mods (semantic-tag-modifiers tag))
170 (leaf nil))
171 (while (and (not leaf) mods)
172 (if (stringp (car mods))
173 ;; Use java FINAL as example default. There is none
174 ;; for C/C++
175 (setq leaf (string= (car mods) "final")))
176 (setq mods (cdr mods)))
177 leaf))
178
179(define-overloadable-function semantic-tag-static-p (tag &optional parent)
180 "Return non nil if TAG is static.
181Optional PARENT is the parent tag of TAG.
182In UML, static methods and attributes mean that they are allocated
183in the parent class, and are not instance specific.
184UML notation specifies that STATIC entries are underlined.")
185
186(defun semantic-tag-static-p-default (tag &optional parent)
187 "Return non-nil if TAG is static as a child of PARENT default action.
188See `semantic-tag-static-p'."
189 (let ((mods (semantic-tag-modifiers tag))
190 (static nil))
191 (while (and (not static) mods)
192 (if (stringp (car mods))
193 (setq static (string= (car mods) "static")))
194 (setq mods (cdr mods)))
195 static))
196
197(define-overloadable-function semantic-tag-prototype-p (tag)
198 "Return non nil if TAG is a prototype.
199For some laguages, such as C, a prototype is a declaration of
200something without an implementation."
201 )
202
203(defun semantic-tag-prototype-p-default (tag)
204 "Non-nil if TAG is a prototype."
205 (let ((p (semantic-tag-get-attribute tag :prototype-flag)))
206 (cond
207 ;; Trust the parser author.
208 (p p)
209 ;; Empty types might be a prototype.
210 ;; @todo - make this better.
211 ((eq (semantic-tag-class tag) 'type)
212 (not (semantic-tag-type-members tag)))
213 ;; No other heuristics.
214 (t nil))
215 ))
216
217;;; FULL NAMES
218;;
219;; For programmer convenience, a full name is not specified in source
220;; code. Instead some abbreviation is made, and the local environment
221;; will contain the info needed to determine the full name.
222
223(define-overloadable-function semantic-tag-full-name (tag &optional stream-or-buffer)
224 "Return the fully qualified name of TAG in the package hierarchy.
225STREAM-OR-BUFFER can be anything convertable by `semantic-something-to-stream',
226but must be a toplevel semantic tag stream that contains TAG.
227A Package Hierarchy is defined in UML by the way classes and methods
228are organized on disk. Some language use this concept such that a
229class can be accessed via it's fully qualified name, (such as Java.)
230Other languages qualify names within a Namespace (such as C++) which
231result in a different package like structure. Languages which do not
232override this function with `tag-full-name' will use
233`semantic-tag-name'. Override functions only need to handle
234STREAM-OR-BUFFER with a tag stream value, or nil."
235 (let ((stream (semantic-something-to-tag-table
236 (or stream-or-buffer tag))))
237 (:override-with-args (tag stream))))
238
239(make-obsolete-overload 'semantic-nonterminal-full-name
240 'semantic-tag-full-name)
241
242(defun semantic-tag-full-name-default (tag stream)
243 "Default method for `semantic-tag-full-name'.
244Return the name of TAG found in the toplevel STREAM."
245 (semantic-tag-name tag))
246
247;;; Compatibility aliases.
248;;
249(semantic-alias-obsolete 'semantic-nonterminal-protection
250 'semantic-tag-protection)
251(semantic-alias-obsolete 'semantic-nonterminal-protection-default
252 'semantic-tag-protection-default)
253(semantic-alias-obsolete 'semantic-nonterminal-abstract
254 'semantic-tag-abstract-p)
255(semantic-alias-obsolete 'semantic-nonterminal-abstract-default
256 'semantic-tag-abstract-p-default)
257(semantic-alias-obsolete 'semantic-nonterminal-leaf
258 'semantic-tag-leaf-p)
259(semantic-alias-obsolete 'semantic-nonterminal-leaf-default
260 'semantic-tag-leaf-p-default)
261(semantic-alias-obsolete 'semantic-nonterminal-static-default
262 'semantic-tag-static-p-default)
263(semantic-alias-obsolete 'semantic-nonterminal-full-name
264 'semantic-tag-full-name)
265(semantic-alias-obsolete 'semantic-nonterminal-full-name-default
266 'semantic-tag-full-name-default)
267
268;; TEMPORARY within betas of CEDET 1.0
269(semantic-alias-obsolete 'semantic-tag-static 'semantic-tag-static-p)
270(semantic-alias-obsolete 'semantic-tag-leaf 'semantic-tag-leaf-p)
271(semantic-alias-obsolete 'semantic-tag-abstract 'semantic-tag-abstract-p)
272
273
274(provide 'semantic/tag-ls)
275
276;;; semantic-tag-ls.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-02-13 16:51:56 +0000