123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374 |
- (require 'semantic/db)
- (require 'semantic/db-ref)
- (eval-when-compile
- (require 'semantic/find))
- (defvar data-debug-thing-alist)
- (declare-function data-debug-insert-stuff-list "data-debug")
- (declare-function semantic-scope-reset-cache "semantic/scope")
- (declare-function semanticdb-typecache-notify-reset "semantic/db-typecache")
- (declare-function ede-current-project "ede")
- (defvar semanticdb-find-throttle-custom-list
- '(repeat (radio (const 'local)
- (const 'project)
- (const 'unloaded)
- (const 'system)
- (const 'recursive)
- (const 'omniscience)))
- "Customization values for semanticdb find throttle.
- See `semanticdb-find-throttle' for details.")
- (defcustom semanticdb-find-default-throttle
- '(local project unloaded system recursive)
- "The default throttle for `semanticdb-find' routines.
- The throttle controls how detailed the list of database
- tables is for a symbol lookup. The value is a list with
- the following keys:
- `file' - The file the search is being performed from.
- This option is here for completeness only, and
- is assumed to always be on.
- `local' - Tables from the same local directory are included.
- This includes files directly referenced by a file name
- which might be in a different directory.
- `project' - Tables from the same local project are included
- If `project' is specified, then `local' is assumed.
- `unloaded' - If a table is not in memory, load it. If it is not cached
- on disk either, get the source, parse it, and create
- the table.
- `system' - Tables from system databases. These are specifically
- tables from system header files, or language equivalent.
- `recursive' - For include based searches, includes tables referenced
- by included files.
- `omniscience' - Included system databases which are omniscience, or
- somehow know everything. Omniscience databases are found
- in `semanticdb-project-system-databases'.
- The Emacs Lisp system DB is an omniscience database."
- :group 'semanticdb
- :type semanticdb-find-throttle-custom-list)
- (defun semanticdb-find-throttle-active-p (access-type)
- "Non-nil if ACCESS-TYPE is an active throttle type."
- (or (memq access-type semanticdb-find-default-throttle)
- (eq access-type 'file)
- (and (eq access-type 'local)
- (memq 'project semanticdb-find-default-throttle))
- ))
- (defclass semanticdb-find-search-index (semanticdb-abstract-search-index)
- ((include-path :initform nil
- :documentation
- "List of semanticdb tables from the include path.")
- (type-cache :initform nil
- :documentation
- "Cache of all the data types accessible from this file.
- Includes all types from all included files, merged namespaces, and
- expunge duplicates.")
- )
- "Concrete search index for `semanticdb-find'.
- This class will cache data derived during various searches.")
- (defmethod semantic-reset ((idx semanticdb-find-search-index))
- "Reset the object IDX."
- (require 'semantic/scope)
-
- (oset idx include-path nil)
- (when (oref idx type-cache)
- (semantic-reset (oref idx type-cache)))
-
-
- (semantic-scope-reset-cache)
- )
- (defmethod semanticdb-synchronize ((idx semanticdb-find-search-index)
- new-tags)
- "Synchronize the search index IDX with some NEW-TAGS."
-
- (semantic-reset idx)
-
- (semanticdb-notify-references
- (oref idx table)
- (lambda (tab me)
- (semantic-reset (semanticdb-get-table-index tab))))
- )
- (defmethod semanticdb-partial-synchronize ((idx semanticdb-find-search-index)
- new-tags)
- "Synchronize the search index IDX with some changed NEW-TAGS."
-
- (if (semantic-find-tags-by-class 'include new-tags)
- (progn
- (semantic-reset idx)
-
- (semanticdb-notify-references
- (oref idx table)
- (lambda (tab me)
- (semantic-reset (semanticdb-get-table-index tab))))
- )
-
- (when (oref idx type-cache)
- (when (semanticdb-partial-synchronize (oref idx type-cache) new-tags)
-
-
- (semanticdb-notify-references
- (oref idx table)
- (lambda (tab me)
- (let ((tab-idx (semanticdb-get-table-index tab)))
-
- (when (oref tab-idx type-cache)
- (require 'db-typecache)
- (semanticdb-typecache-notify-reset
- (oref tab-idx type-cache)))
- )))
- ))
- ))
- (define-overloadable-function semanticdb-find-translate-path (path brutish)
- "Translate PATH into a list of semantic tables.
- Path translation involves identifying the PATH input argument
- in one of the following ways:
- nil - Take the current buffer, and use its include list
- buffer - Use that buffer's include list.
- filename - Use that file's include list. If the file is not
- in a buffer, see of there is a semanticdb table for it. If
- not, read that file into a buffer.
- tag - Get that tag's buffer of file file. See above.
- table - Search that table, and its include list.
- find result - Search the results of a previous find.
- In addition, once the base path is found, there is the possibility of
- each added table adding yet more tables to the path, so this routine
- can return a lengthy list.
- If argument BRUTISH is non-nil, then instead of using the include
- list, use all tables found in the parent project of the table
- identified by translating PATH. Such searches use brute force to
- scan every available table.
- The return value is a list of objects of type `semanticdb-table' or
- their children. In the case of passing in a find result, the result
- is returned unchanged.
- This routine uses `semanticdb-find-table-for-include' to translate
- specific include tags into a semanticdb table.
- Note: When searching using a non-brutish method, the list of
- included files will be cached between runs. Database-references
- are used to track which files need to have their include lists
- refreshed when things change. See `semanticdb-ref-test'.
- Note for overloading: If you opt to overload this function for your
- major mode, and your routine takes a long time, be sure to call
- (semantic-throw-on-input 'your-symbol-here)
- so that it can be called from the idle work handler."
- )
- (defun semanticdb-find-translate-path-default (path brutish)
- "Translate PATH into a list of semantic tables.
- If BRUTISH is non nil, return all tables associated with PATH.
- Default action as described in `semanticdb-find-translate-path'."
- (if (semanticdb-find-results-p path)
-
- nil
- (if brutish
- (semanticdb-find-translate-path-brutish-default path)
- (semanticdb-find-translate-path-includes-default path))))
- (define-overloadable-function semanticdb-find-table-for-include (includetag &optional table)
- "For a single INCLUDETAG found in TABLE, find a `semanticdb-table' object
- INCLUDETAG is a semantic TAG of class 'include.
- TABLE is a semanticdb table that identifies where INCLUDETAG came from.
- TABLE is optional if INCLUDETAG has an overlay of :filename attribute."
- )
- (defun semanticdb-find-translate-path-brutish-default (path)
- "Translate PATH into a list of semantic tables.
- Default action as described in `semanticdb-find-translate-path'."
- (let ((basedb
- (cond ((null path) semanticdb-current-database)
- ((semanticdb-table-p path) (oref path parent-db))
- (t (let ((tt (semantic-something-to-tag-table path)))
- (if tt
-
- (with-current-buffer (semantic-tag-buffer (car tt))
- semanticdb-current-database)
- semanticdb-current-database))))))
- (apply
- #'nconc
- (mapcar
- (lambda (db)
- (let ((tabs (semanticdb-get-database-tables db))
- (ret nil))
-
-
- (while tabs
- (semantic-throw-on-input 'translate-path-brutish)
- (if (semanticdb-equivalent-mode-for-search (car tabs)
- (current-buffer))
- (setq ret (cons (car tabs) ret)))
- (setq tabs (cdr tabs)))
- ret))
-
-
-
- (semanticdb-current-database-list
- (if basedb (oref basedb reference-directory)
- default-directory))))
- ))
- (defun semanticdb-find-incomplete-cache-entries-p (cache)
- "Are there any incomplete entries in CACHE?"
- (let ((ans nil))
- (dolist (tab cache)
- (when (and (semanticdb-table-child-p tab)
- (not (number-or-marker-p (oref tab pointmax))))
- (setq ans t))
- )
- ans))
- (defun semanticdb-find-need-cache-update-p (table)
- "Non-nil if the semanticdb TABLE cache needs to be updated."
-
-
- (let* ((index (semanticdb-get-table-index table))
- (cache (when index (oref index include-path)))
- (incom (semanticdb-find-incomplete-cache-entries-p cache))
- (unl (semanticdb-find-throttle-active-p 'unloaded))
- )
- (if (and
- cache
- (or
-
-
-
- (not incom) (not unl)
- ))
- nil
-
-
-
-
- t))
- )
- (defun semanticdb-find-translate-path-includes-default (path)
- "Translate PATH into a list of semantic tables.
- Default action as described in `semanticdb-find-translate-path'."
- (let ((table (cond ((null path)
- semanticdb-current-table)
- ((bufferp path)
- (semantic-buffer-local-value 'semanticdb-current-table path))
- ((and (stringp path) (file-exists-p path))
- (semanticdb-file-table-object path t))
- ((semanticdb-abstract-table-child-p path)
- path)
- (t nil))))
- (if table
-
-
- (let ((index (semanticdb-get-table-index table)))
- (if (semanticdb-find-need-cache-update-p table)
-
- (let ((ans (semanticdb-find-translate-path-includes--internal path)))
- (oset index include-path ans)
-
-
-
- (when ans (semanticdb-refresh-references table))
- ans)
-
-
-
- (oref index include-path)))
-
-
- (semanticdb-find-translate-path-includes--internal path))))
- (defvar semanticdb-find-lost-includes nil
- "Include files that we cannot find associated with this buffer.")
- (make-variable-buffer-local 'semanticdb-find-lost-includes)
- (defvar semanticdb-find-scanned-include-tags nil
- "All include tags scanned, plus action taken on the tag.
- Each entry is an alist:
- (ACTION . TAG)
- where ACTION is one of 'scanned, 'duplicate, 'lost
- and TAG is a clone of the include tag that was found.")
- (make-variable-buffer-local 'semanticdb-find-scanned-include-tags)
- (defvar semanticdb-implied-include-tags nil
- "Include tags implied for all files of a given mode.
- Set this variable with `defvar-mode-local' for a particular mode so
- that any symbols that exist for all files for that mode are included.
- Note: This could be used as a way to write a file in a language
- to declare all the built-ins for that language.")
- (defun semanticdb-find-translate-path-includes--internal (path)
- "Internal implementation of `semanticdb-find-translate-path-includes-default'.
- This routine does not depend on the cache, but will always derive
- a new path from the provided PATH."
- (let ((includetags nil)
- (curtable nil)
- (matchedtables (list semanticdb-current-table))
- (matchedincludes nil)
- (lostincludes nil)
- (scannedincludes nil)
- (incfname nil)
- nexttable)
- (cond ((null path)
- (semantic-refresh-tags-safe)
- (setq includetags (append
- (semantic-find-tags-included (current-buffer))
- semanticdb-implied-include-tags)
- curtable semanticdb-current-table
- incfname (buffer-file-name))
- )
- ((semanticdb-table-p path)
- (setq includetags (semantic-find-tags-included path)
- curtable path
- incfname (semanticdb-full-filename path))
- )
- ((bufferp path)
- (with-current-buffer path
- (semantic-refresh-tags-safe))
- (setq includetags (semantic-find-tags-included path)
- curtable (with-current-buffer path
- semanticdb-current-table)
- incfname (buffer-file-name path)))
- (t
- (setq includetags (semantic-find-tags-included path))
- (when includetags
-
-
-
- (message "Need to derive tables for %S in translate-path-includes--default."
- path)
- )))
-
-
- (when incfname
- (dolist (it includetags)
- (semantic--tag-put-property it :filename incfname)))
-
- (while includetags
- (semantic-throw-on-input 'semantic-find-translate-path-includes-default)
-
- (if (member (semantic-tag-name (car includetags)) matchedincludes)
- (progn
- (setq nexttable nil)
- (push (cons 'duplicate (semantic-tag-clone (car includetags)))
- scannedincludes)
- )
- (setq nexttable (semanticdb-find-table-for-include (car includetags) curtable))
- (when (not nexttable)
-
- (push (car includetags) lostincludes)
- (push (cons 'lost (semantic-tag-clone (car includetags)))
- scannedincludes)
- )
- )
-
-
- (push (semantic-tag-name (car includetags)) matchedincludes)
-
- (when (and nexttable
- (not (memq nexttable matchedtables))
- (semanticdb-equivalent-mode-for-search nexttable
- (current-buffer))
- )
-
- (push nexttable matchedtables)
-
- (if (semanticdb-find-throttle-active-p 'recursive)
-
-
- (let ((newtags
- (cond
- ((semanticdb-table-p nexttable)
- (semanticdb-refresh-table nexttable)
-
-
- (semanticdb-find-tags-by-class-method
- nexttable 'include))
- (t
- (message "semanticdb-ftp - how did you do that?")
- (semantic-find-tags-included
- (semanticdb-get-tags nexttable)))
- ))
- (newincfname (semanticdb-full-filename nexttable))
- )
- (push (cons 'scanned (semantic-tag-clone (car includetags)))
- scannedincludes)
-
- (dolist (it newtags)
- (semantic--tag-put-property it :filename
- newincfname))
- (setq includetags (nconc includetags newtags)))
-
- (push (cons 'scanned-no-recurse
- (semantic-tag-clone (car includetags)))
- scannedincludes)
- )
- )
- (setq includetags (cdr includetags)))
- (setq semanticdb-find-lost-includes lostincludes)
- (setq semanticdb-find-scanned-include-tags (reverse scannedincludes))
-
-
- (when (and (semanticdb-find-throttle-active-p 'omniscience)
- semanticdb-search-system-databases)
-
-
- (let ((systemdb semanticdb-project-system-databases)
- (ans nil))
- (while systemdb
- (setq ans (semanticdb-file-table
- (car systemdb)
-
-
-
-
- (buffer-file-name (current-buffer))))
- (when (not (memq ans matchedtables))
- (setq matchedtables (cons ans matchedtables)))
- (setq systemdb (cdr systemdb))))
- )
- (nreverse matchedtables)))
- (define-overloadable-function semanticdb-find-load-unloaded (filename)
- "Create a database table for FILENAME if it hasn't been parsed yet.
- Assumes that FILENAME exists as a source file.
- Assumes that a preexisting table does not exist, even if it
- isn't in memory yet."
- (if (semanticdb-find-throttle-active-p 'unloaded)
- (:override)
- (semanticdb-file-table-object filename t)))
- (defun semanticdb-find-load-unloaded-default (filename)
- "Load an unloaded file in FILENAME using the default semanticdb loader."
- (semanticdb-file-table-object filename))
- (defun semanticdb-find-table-for-include-default (includetag &optional table)
- "Default implementation of `semanticdb-find-table-for-include'.
- Uses `semanticdb-current-database-list' as the search path.
- INCLUDETAG and TABLE are documented in `semanticdb-find-table-for-include'.
- Included databases are filtered based on `semanticdb-find-default-throttle'."
- (if (not (eq (semantic-tag-class includetag) 'include))
- (signal 'wrong-type-argument (list includetag 'include)))
- (let ((name
-
-
- (semantic-tag-include-filename includetag))
- (originfiledir nil)
- (roots nil)
- (tmp nil)
- (ans nil))
-
-
-
-
-
- (setq originfiledir
- (cond ((semantic-tag-file-name includetag)
-
- (file-name-directory (semantic-tag-file-name includetag)))
- (table
- (file-name-directory (semanticdb-full-filename table)))
- (t
-
-
- default-directory)))
- (cond
-
-
-
-
-
- ((and (semanticdb-find-throttle-active-p 'local)
- (file-exists-p (expand-file-name name originfiledir)))
- (setq ans (semanticdb-find-load-unloaded
- (expand-file-name name originfiledir)))
- )
-
-
- ((or
-
-
- (and (semanticdb-find-throttle-active-p 'system)
-
-
-
- (setq tmp (semantic-dependency-tag-file includetag))
- )
-
-
- (and (semanticdb-find-throttle-active-p 'project)
-
- (featurep 'ede) (ede-current-project originfiledir)
-
- (setq tmp (semantic-dependency-tag-file includetag))
- )
- )
- (setq ans (semanticdb-find-load-unloaded tmp))
- )
-
-
-
-
-
-
- ((and (semanticdb-find-throttle-active-p 'project)
-
-
- (not (semantic-tag-include-system-p includetag))
-
- (not (and (featurep 'ede)
-
-
-
- (ede-current-project)))
- )
- (setq roots (semanticdb-current-database-list))
- (while (and (not ans) roots)
- (let* ((ref (if (slot-boundp (car roots) 'reference-directory)
- (oref (car roots) reference-directory)))
- (fname (cond ((null ref) nil)
- ((file-exists-p (expand-file-name name ref))
- (expand-file-name name ref))
- ((file-exists-p (expand-file-name (file-name-nondirectory name) ref))
- (expand-file-name (file-name-nondirectory name) ref)))))
- (when (and ref fname)
-
- (setq ans (semanticdb-find-load-unloaded fname)))
-
-
-
-
-
-
-
- )
- (setq roots (cdr roots))))
- )
- ans))
- (defun semanticdb-find-test-translate-path (&optional arg)
- "Call and output results of `semanticdb-find-translate-path'.
- With ARG non-nil, specify a BRUTISH translation.
- See `semanticdb-find-default-throttle' and `semanticdb-project-roots'
- for details on how this list is derived."
- (interactive "P")
- (semantic-fetch-tags)
- (require 'data-debug)
- (let ((start (current-time))
- (p (semanticdb-find-translate-path nil arg))
- (end (current-time))
- )
- (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*")
- (message "Search of tags took %.2f seconds."
- (semantic-elapsed-time start end))
- (data-debug-insert-stuff-list p "*")))
- (defun semanticdb-find-test-translate-path-no-loading (&optional arg)
- "Call and output results of `semanticdb-find-translate-path'.
- With ARG non-nil, specify a BRUTISH translation.
- See `semanticdb-find-default-throttle' and `semanticdb-project-roots'
- for details on how this list is derived."
- (interactive "P")
- (semantic-fetch-tags)
- (require 'data-debug)
- (let* ((semanticdb-find-default-throttle
- (if (featurep 'semantic/db-find)
- (remq 'unloaded semanticdb-find-default-throttle)
- nil))
- (start (current-time))
- (p (semanticdb-find-translate-path nil arg))
- (end (current-time))
- )
- (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*")
- (message "Search of tags took %.2f seconds."
- (semantic-elapsed-time start end))
- (data-debug-insert-stuff-list p "*")))
- (defun semanticdb-find-adebug-lost-includes ()
- "Translate the current path, then display the lost includes.
- Examines the variable `semanticdb-find-lost-includes'."
- (interactive)
- (require 'data-debug)
- (semanticdb-find-translate-path nil nil)
- (let ((lost semanticdb-find-lost-includes)
- )
- (if (not lost)
- (message "There are no unknown includes for %s"
- (buffer-name))
- (data-debug-new-buffer "*SEMANTICDB lost-includes ADEBUG*")
-
- )))
- (defun semanticdb-find-adebug-insert-scanned-tag-cons (consdata prefix prebuttontext)
- "Insert a button representing scanned include CONSDATA.
- PREFIX is the text that precedes the button.
- PREBUTTONTEXT is some text between prefix and the overlay button."
- (let* ((start (point))
- (end nil)
- (mode (car consdata))
- (tag (cdr consdata))
- (name (semantic-tag-name tag))
- (file (semantic-tag-file-name tag))
- (str1 (format "%S %s" mode name))
- (str2 (format " : %s" file))
- (tip nil))
- (insert prefix prebuttontext str1)
- (setq end (point))
- (insert str2)
- (put-text-property start end 'face
- (cond ((eq mode 'scanned)
- 'font-lock-function-name-face)
- ((eq mode 'duplicate)
- 'font-lock-comment-face)
- ((eq mode 'lost)
- 'font-lock-variable-name-face)
- ((eq mode 'scanned-no-recurse)
- 'font-lock-type-face)))
- (put-text-property start end 'ddebug (cdr consdata))
- (put-text-property start end 'ddebug-indent(length prefix))
- (put-text-property start end 'ddebug-prefix prefix)
- (put-text-property start end 'help-echo tip)
- (put-text-property start end 'ddebug-function
- 'data-debug-insert-tag-parts-from-point)
- (insert "\n")
- )
- )
- (defun semanticdb-find-adebug-scanned-includes ()
- "Translate the current path, then display the lost includes.
- Examines the variable `semanticdb-find-lost-includes'."
- (interactive)
- (require 'data-debug)
- (semanticdb-find-translate-path nil nil)
- (let ((scanned semanticdb-find-scanned-include-tags)
- (data-debug-thing-alist
- (cons
- '((lambda (thing) (and (consp thing)
- (symbolp (car thing))
- (memq (car thing)
- '(scanned scanned-no-recurse
- lost duplicate))))
- . semanticdb-find-adebug-insert-scanned-tag-cons)
- data-debug-thing-alist))
- )
- (if (not scanned)
- (message "There are no includes scanned %s"
- (buffer-name))
- (data-debug-new-buffer "*SEMANTICDB scanned-includes ADEBUG*")
- (data-debug-insert-stuff-list scanned "*")
- )))
- (defun semanticdb-strip-find-results (results &optional find-file-match)
- "Strip a semanticdb search RESULTS to exclude objects.
- This makes it appear more like the results of a `semantic-find-' call.
- Optional FIND-FILE-MATCH loads all files associated with RESULTS
- into buffers. This has the side effect of enabling `semantic-tag-buffer' to
- return a value.
- If FIND-FILE-MATCH is 'name, then only the filename is stored
- in each tag instead of loading each file into a buffer.
- If the input RESULTS are not going to be used again, and if
- FIND-FILE-MATCH is nil, you can use `semanticdb-fast-strip-find-results'
- instead."
- (if find-file-match
-
- (let ((tmp results)
- (output nil))
- (while tmp
- (let ((tab (car (car tmp)))
- (tags (cdr (car tmp))))
- (dolist (T tags)
-
-
- (let* ((norm (semanticdb-normalize-one-tag tab T))
- (ntab (car norm))
- (ntag (cdr norm))
- (nametable ntab))
-
- (if (not norm)
- (setq nametable tab)
- (setq output (append output (list ntag))))
-
-
- (cond ((eq find-file-match 'name)
- (let ((f (semanticdb-full-filename nametable)))
- (semantic--tag-put-property ntag :filename f)))
- ((and find-file-match ntab)
- (semanticdb-get-buffer ntab))
- )
- ))
- )
- (setq tmp (cdr tmp)))
- output)
-
-
-
- (apply #'append (mapcar #'cdr results))))
- (defun semanticdb-fast-strip-find-results (results)
- "Destructively strip a semanticdb search RESULTS to exclude objects.
- This makes it appear more like the results of a `semantic-find-' call.
- This is like `semanticdb-strip-find-results', except the input list RESULTS
- will be changed."
- (apply #'nconc (mapcar #'cdr results)))
- (defun semanticdb-find-results-p (resultp)
- "Non-nil if RESULTP is in the form of a semanticdb search result.
- This query only really tests the first entry in the list that is RESULTP,
- but should be good enough for debugging assertions."
- (and (listp resultp)
- (listp (car resultp))
- (semanticdb-abstract-table-child-p (car (car resultp)))
- (or (semantic-tag-p (car (cdr (car resultp))))
- (null (car (cdr (car resultp)))))))
- (defun semanticdb-find-result-prin1-to-string (result)
- "Presuming RESULT satisfies `semanticdb-find-results-p', provide a short PRIN1 output."
- (if (< (length result) 2)
- (concat "#<FIND RESULT "
- (mapconcat (lambda (a)
- (concat "(" (object-name (car a) ) " . "
- "#<TAG LIST " (number-to-string (length (cdr a))) ">)"))
- result
- " ")
- ">")
-
- (format "#<FIND RESULT %d TAGS in %d FILES>"
- (semanticdb-find-result-length result)
- (length result))))
- (defun semanticdb-find-result-with-nil-p (resultp)
- "Non-nil of RESULTP is in the form of a semanticdb search result.
- The value nil is valid where a TABLE usually is, but only if the TAG
- results include overlays.
- This query only really tests the first entry in the list that is RESULTP,
- but should be good enough for debugging assertions."
- (and (listp resultp)
- (listp (car resultp))
- (let ((tag-to-test (car-safe (cdr (car resultp)))))
- (or (and (semanticdb-abstract-table-child-p (car (car resultp)))
- (or (semantic-tag-p tag-to-test)
- (null tag-to-test)))
- (and (null (car (car resultp)))
- (or (semantic-tag-with-position-p tag-to-test)
- (null tag-to-test))))
- )))
- (defun semanticdb-find-result-length (result)
- "Number of tags found in RESULT."
- (let ((count 0))
- (mapc (lambda (onetable)
- (setq count (+ count (1- (length onetable)))))
- result)
- count))
- (defun semanticdb-find-result-nth (result n)
- "In RESULT, return the Nth search result.
- This is a 0 based search result, with the first match being element 0.
- The returned value is a cons cell: (TAG . TABLE) where TAG
- is the tag at the Nth position. TABLE is the semanticdb table where
- the TAG was found. Sometimes TABLE can be nil."
- (let ((ans nil)
- (anstable nil))
-
- (while (and (not ans) result)
-
-
- (let ((ll (length (cdr (car result)))))
- (if (> ll n)
-
- (setq ans (nth n (cdr (car result)))
- anstable (car (car result)))
-
- (setq n (- n ll))))
-
- (setq result (cdr result)))
- (cons ans anstable)))
- (defun semanticdb-find-result-test (result)
- "Test RESULT by accessing all the tags in the list."
- (if (not (semanticdb-find-results-p result))
- (error "Does not pass `semanticdb-find-results-p.\n"))
- (let ((len (semanticdb-find-result-length result))
- (i 0))
- (while (< i len)
- (let ((tag (semanticdb-find-result-nth result i)))
- (if (not (semantic-tag-p (car tag)))
- (error "%d entry is not a tag" i)))
- (setq i (1+ i)))))
- (defun semanticdb-find-result-nth-in-buffer (result n)
- "In RESULT, return the Nth search result.
- Like `semanticdb-find-result-nth', except that only the TAG
- is returned, and the buffer it is found it will be made current.
- If the result tag has no position information, the originating buffer
- is still made current."
- (let* ((ret (semanticdb-find-result-nth result n))
- (ans (car ret))
- (anstable (cdr ret)))
-
-
-
- (if anstable
- (let ((norm (semanticdb-normalize-one-tag anstable ans)))
- (when norm
-
-
- (condition-case foo
- (progn
- (semanticdb-set-buffer (car norm))
-
- (setq ans (cdr norm)))
-
-
- (no-method-definition nil))
- ))
- )
-
- ans))
- (defun semanticdb-find-result-mapc (fcn result)
- "Apply FCN to each element of find RESULT for side-effects only.
- FCN takes two arguments. The first is a TAG, and the
- second is a DB from whence TAG originated.
- Returns result."
- (mapc (lambda (sublst-icky)
- (mapc (lambda (tag-icky)
- (funcall fcn tag-icky (car sublst-icky)))
- (cdr sublst-icky)))
- result)
- result)
- (defvar semanticdb-find-log-flag nil
- "Non-nil means log the process of searches.")
- (defvar semanticdb-find-log-buffer-name "*SemanticDB Find Log*"
- "The name of the logging buffer.")
- (defun semanticdb-find-toggle-logging ()
- "Toggle semanticdb logging."
- (interactive)
- (setq semanticdb-find-log-flag (null semanticdb-find-log-flag))
- (message "Semanticdb find logging is %sabled"
- (if semanticdb-find-log-flag "en" "dis")))
- (defun semanticdb-reset-log ()
- "Reset the log buffer."
- (interactive)
- (when semanticdb-find-log-flag
- (with-current-buffer (get-buffer-create semanticdb-find-log-buffer-name)
- (erase-buffer)
- )))
- (defun semanticdb-find-log-move-to-end ()
- "Move to the end of the semantic log."
- (let ((cb (current-buffer))
- (cw (selected-window)))
- (unwind-protect
- (progn
- (set-buffer semanticdb-find-log-buffer-name)
- (if (get-buffer-window (current-buffer) 'visible)
- (select-window (get-buffer-window (current-buffer) 'visible)))
- (goto-char (point-max)))
- (if cw (select-window cw))
- (set-buffer cb))))
- (defun semanticdb-find-log-new-search (forwhat)
- "Start a new search FORWHAT."
- (when semanticdb-find-log-flag
- (with-current-buffer (get-buffer-create semanticdb-find-log-buffer-name)
- (insert (format "New Search: %S\n" forwhat))
- )
- (semanticdb-find-log-move-to-end)))
- (defun semanticdb-find-log-activity (table result)
- "Log that TABLE has been searched and RESULT was found."
- (when semanticdb-find-log-flag
- (with-current-buffer semanticdb-find-log-buffer-name
- (insert "Table: " (object-print table)
- " Result: " (int-to-string (length result)) " tags"
- "\n")
- )
- (semanticdb-find-log-move-to-end)))
- (defun semanticdb-find-tags-collector (function &optional path find-file-match
- brutish)
- "Collect all tags returned by FUNCTION over PATH.
- The FUNCTION must take two arguments. The first is TABLE,
- which is a semanticdb table containing tags. The second argument
- to FUNCTION is TAGS. TAGS may be a list of tags. If TAGS is non-nil,
- then FUNCTION should search the TAG list, not through TABLE.
- See `semanticdb-find-translate-path' for details on PATH.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated with that tag should be loaded into a buffer.
- Note: You should leave FIND-FILE-MATCH as nil. It is far more
- efficient to take the results from any search and use
- `semanticdb-strip-find-results' instead. This argument is here
- for backward compatibility.
- If optional argument BRUTISH is non-nil, then ignore include statements,
- and search all tables in this project tree."
- (let (found match)
- (save-excursion
-
-
- (when (bufferp path) (set-buffer path))
- (if (semanticdb-find-results-p path)
-
- (dolist (tableandtags path)
- (semantic-throw-on-input 'semantic-find-translate-path)
-
-
-
- (unless (and find-file-match
- (obj-of-class-p
- (car tableandtags) semanticdb-search-results-table))
- (when (setq match (funcall function
- (car tableandtags) (cdr tableandtags)))
- (when find-file-match
- (save-excursion (semanticdb-set-buffer (car tableandtags))))
- (push (cons (car tableandtags) match) found)))
- )
-
- (semanticdb-find-log-new-search nil)
-
-
- (dolist (table (semanticdb-find-translate-path path brutish))
- (semantic-throw-on-input 'semantic-find-translate-path)
-
-
-
- (unless (and find-file-match
- (obj-of-class-p table semanticdb-search-results-table))
- (when (and table (setq match (funcall function table nil)))
- (semanticdb-find-log-activity table match)
- (when find-file-match
- (save-excursion (semanticdb-set-buffer table)))
- (push (cons table match) found))))))
-
-
-
-
-
-
- (nreverse found)))
- (defun semanticdb-find-tags-by-name (name &optional path find-file-match)
- "Search for all tags matching NAME on PATH.
- See `semanticdb-find-translate-path' for details on PATH.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-by-name-method table name tags))
- path find-file-match))
- (defun semanticdb-find-tags-by-name-regexp (regexp &optional path find-file-match)
- "Search for all tags matching REGEXP on PATH.
- See `semanticdb-find-translate-path' for details on PATH.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-by-name-regexp-method table regexp tags))
- path find-file-match))
- (defun semanticdb-find-tags-for-completion (prefix &optional path find-file-match)
- "Search for all tags matching PREFIX on PATH.
- See `semanticdb-find-translate-path' for details on PATH.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-for-completion-method table prefix tags))
- path find-file-match))
- (defun semanticdb-find-tags-by-class (class &optional path find-file-match)
- "Search for all tags of CLASS on PATH.
- See `semanticdb-find-translate-path' for details on PATH.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-by-class-method table class tags))
- path find-file-match))
- (defun semanticdb-deep-find-tags-by-name (name &optional path find-file-match)
- "Search for all tags matching NAME on PATH.
- Search also in all components of top level tags founds.
- See `semanticdb-find-translate-path' for details on PATH.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-deep-find-tags-by-name-method table name tags))
- path find-file-match))
- (defun semanticdb-deep-find-tags-by-name-regexp (regexp &optional path find-file-match)
- "Search for all tags matching REGEXP on PATH.
- Search also in all components of top level tags founds.
- See `semanticdb-find-translate-path' for details on PATH.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-deep-find-tags-by-name-regexp-method table regexp tags))
- path find-file-match))
- (defun semanticdb-deep-find-tags-for-completion (prefix &optional path find-file-match)
- "Search for all tags matching PREFIX on PATH.
- Search also in all components of top level tags founds.
- See `semanticdb-find-translate-path' for details on PATH.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-deep-find-tags-for-completion-method table prefix tags))
- path find-file-match))
- (defun semanticdb-brute-deep-find-tags-by-name (name &optional path find-file-match)
- "Search for all tags matching NAME on PATH.
- See `semanticdb-find-translate-path' for details on PATH.
- The argument BRUTISH will be set so that searching includes all tables
- in the current project.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated wit that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-deep-find-tags-by-name-method table name tags))
- path find-file-match t))
- (defun semanticdb-brute-deep-find-tags-for-completion (prefix &optional path find-file-match)
- "Search for all tags matching PREFIX on PATH.
- See `semanticdb-find-translate-path' for details on PATH.
- The argument BRUTISH will be set so that searching includes all tables
- in the current project.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated wit that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-deep-find-tags-for-completion-method table prefix tags))
- path find-file-match t))
- (defun semanticdb-brute-find-tags-by-class (class &optional path find-file-match)
- "Search for all tags of CLASS on PATH.
- See `semanticdb-find-translate-path' for details on PATH.
- The argument BRUTISH will be set so that searching includes all tables
- in the current project.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-by-class-method table class tags))
- path find-file-match t))
- (defun semanticdb-find-tags-external-children-of-type
- (type &optional path find-file-match)
- "Search for all tags defined outside of TYPE w/ TYPE as a parent.
- See `semanticdb-find-translate-path' for details on PATH.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-external-children-of-type-method table type tags))
- path find-file-match))
- (defun semanticdb-find-tags-subclasses-of-type
- (type &optional path find-file-match)
- "Search for all tags of class type defined that subclass TYPE.
- See `semanticdb-find-translate-path' for details on PATH.
- FIND-FILE-MATCH indicates that any time a match is found, the file
- associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-subclasses-of-type-method table type tags))
- path find-file-match t))
- (defmethod semanticdb-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags)
- "In TABLE, find all occurrences of tags with NAME.
- Optional argument TAGS is a list of tags to search.
- Returns a table of all matching tags."
- (semantic-find-tags-by-name name (or tags (semanticdb-get-tags table))))
- (defmethod semanticdb-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags)
- "In TABLE, find all occurrences of tags matching REGEXP.
- Optional argument TAGS is a list of tags to search.
- Returns a table of all matching tags."
- (semantic-find-tags-by-name-regexp regexp (or tags (semanticdb-get-tags table))))
- (defmethod semanticdb-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags)
- "In TABLE, find all occurrences of tags matching PREFIX.
- Optional argument TAGS is a list of tags to search.
- Returns a table of all matching tags."
- (semantic-find-tags-for-completion prefix (or tags (semanticdb-get-tags table))))
- (defmethod semanticdb-find-tags-by-class-method ((table semanticdb-abstract-table) class &optional tags)
- "In TABLE, find all occurrences of tags of CLASS.
- Optional argument TAGS is a list of tags to search.
- Returns a table of all matching tags."
- (semantic-find-tags-by-class class (or tags (semanticdb-get-tags table))))
- (defmethod semanticdb-find-tags-external-children-of-type-method ((table semanticdb-abstract-table) parent &optional tags)
- "In TABLE, find all occurrences of tags whose parent is the PARENT type.
- Optional argument TAGS is a list of tags to search.
- Returns a table of all matching tags."
- (require 'semantic/find)
- (semantic-find-tags-external-children-of-type parent (or tags (semanticdb-get-tags table))))
- (defmethod semanticdb-find-tags-subclasses-of-type-method ((table semanticdb-abstract-table) parent &optional tags)
- "In TABLE, find all occurrences of tags whose parent is the PARENT type.
- Optional argument TAGS is a list of tags to search.
- Returns a table of all matching tags."
- (require 'semantic/find)
- (semantic-find-tags-subclasses-of-type parent (or tags (semanticdb-get-tags table))))
- (defmethod semanticdb-deep-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags)
- "In TABLE, find all occurrences of tags with NAME.
- Search in all tags in TABLE, and all components of top level tags in
- TABLE.
- Optional argument TAGS is a list of tags to search.
- Return a table of all matching tags."
- (semantic-find-tags-by-name name (semantic-flatten-tags-table (or tags (semanticdb-get-tags table)))))
- (defmethod semanticdb-deep-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags)
- "In TABLE, find all occurrences of tags matching REGEXP.
- Search in all tags in TABLE, and all components of top level tags in
- TABLE.
- Optional argument TAGS is a list of tags to search.
- Return a table of all matching tags."
- (semantic-find-tags-by-name-regexp regexp (semantic-flatten-tags-table (or tags (semanticdb-get-tags table)))))
- (defmethod semanticdb-deep-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags)
- "In TABLE, find all occurrences of tags matching PREFIX.
- Search in all tags in TABLE, and all components of top level tags in
- TABLE.
- Optional argument TAGS is a list of tags to search.
- Return a table of all matching tags."
- (semantic-find-tags-for-completion prefix (semantic-flatten-tags-table (or tags (semanticdb-get-tags table)))))
- (provide 'semantic/db-find)
|