123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664 |
- (require 'ebrowse)
- (require 'semantic)
- (require 'semantic/db-file)
- (eval-when-compile
-
- (require 'eieio)
- (require 'eieio-opt)
- (require 'semantic/find))
- (declare-function semantic-add-system-include "semantic/dep")
- (defvar semanticdb-ebrowse-default-file-name "BROWSE"
- "The EBROWSE file name used for system caches.")
- (defcustom semanticdb-ebrowse-file-match "\\.\\(hh?\\|HH?\\|hpp\\)"
- "Regular expression matching file names for ebrowse to parse.
- This expression should exclude C++ headers that have no extension.
- By default, include only headers since the semantic use of EBrowse
- is only for searching via semanticdb, and thus only headers would
- be searched."
- :group 'semanticdb
- :type 'string)
- (defclass semanticdb-table-ebrowse (semanticdb-table)
- ((major-mode :initform c++-mode)
- (ebrowse-tree :initform nil
- :initarg :ebrowse-tree
- :documentation
- "The raw ebrowse tree for this file."
- )
- (global-extract :initform nil
- :initarg :global-extract
- :documentation
- "Table of ebrowse tags specific to this file.
- This table is composited from the ebrowse *Globals* section.")
- )
- "A table for returning search results from ebrowse.")
- (defclass semanticdb-project-database-ebrowse
- (semanticdb-project-database)
- ((new-table-class :initform semanticdb-table-ebrowse
- :type class
- :documentation
- "New tables created for this database are of this class.")
- (system-include-p :initform nil
- :initarg :system-include
- :documentation
- "Flag indicating this database represents a system include directory.")
- (ebrowse-struct :initform nil
- :initarg :ebrowse-struct
- )
- )
- "Semantic Database deriving tags using the EBROWSE tool.
- EBROWSE is a C/C++ parser for use with `ebrowse' Emacs program.")
- (defun semanticdb-ebrowse-C-file-p (file)
- "Is FILE a C or C++ file?"
- (or (string-match semanticdb-ebrowse-file-match file)
- (and (string-match "/\\w+$" file)
- (not (file-directory-p file))
- (let ((tmp (get-buffer-create "*semanticdb-ebrowse-tmp*")))
- (with-current-buffer tmp
- (condition-case nil
- (insert-file-contents file nil 0 100 t)
- (error (insert-file-contents file nil nil nil t)))
- (goto-char (point-min))
- (looking-at "\\s-*/\\(\\*\\|/\\)")
- ))
- )))
- (defun semanticdb-create-ebrowse-database (dir)
- "Create an EBROWSE database for directory DIR.
- The database file is stored in ~/.semanticdb, or whichever directory
- is specified by `semanticdb-default-save-directory'."
- (interactive "DDirectory: ")
- (setq dir (file-name-as-directory dir))
- (let* ((savein (semanticdb-ebrowse-file-for-directory dir))
- (filebuff (get-buffer-create "*SEMANTICDB EBROWSE TMP*"))
- (files (directory-files (expand-file-name dir) t))
- (mma auto-mode-alist)
- (regexp nil)
- )
-
- (with-current-buffer filebuff
- (buffer-disable-undo filebuff)
- (setq default-directory (expand-file-name dir))
-
-
- (mapc (lambda (f)
- (when (semanticdb-ebrowse-C-file-p f)
- (insert f)
- (insert "\n")))
- files)
-
- (with-current-buffer (get-buffer-create "*EBROWSE OUTPUT*")
- (erase-buffer))
-
- (message "Creating ebrowse file: %s ..." savein)
- (call-process-region (point-min) (point-max)
- "ebrowse" nil "*EBROWSE OUTPUT*" nil
- (concat "--output-file=" savein)
- "--very-verbose")
- )
-
- (let* ((lfn (concat savein "-load.el"))
- (lf (find-file-noselect lfn)))
- (with-current-buffer lf
- (erase-buffer)
- (insert "(semanticdb-ebrowse-load-helper \""
- (expand-file-name dir)
- "\")\n")
- (save-buffer)
- (kill-buffer (current-buffer)))
- (message "Creating ebrowse file: %s ... done" savein)
-
- (load lfn nil t)
- )))
- (defun semanticdb-load-ebrowse-caches ()
- "Load all semanticdb controlled EBROWSE caches."
- (interactive)
- (let ((f (directory-files semanticdb-default-save-directory
- t (concat semanticdb-ebrowse-default-file-name "-load.el$") t)))
- (while f
- (load (car f) nil t)
- (setq f (cdr f)))
- ))
- (defun semanticdb-ebrowse-load-helper (directory)
- "Create the semanticdb database via ebrowse for directory.
- If DIRECTORY is found to be defunct, it won't load the DB, and will
- warn instead."
- (if (file-directory-p directory)
- (semanticdb-create-database semanticdb-project-database-ebrowse
- directory)
- (let* ((BF (semanticdb-ebrowse-file-for-directory directory))
- (BFL (concat BF "-load.el"))
- (BFLB (concat BF "-load.el~")))
- (save-window-excursion
- (with-output-to-temp-buffer "*FILES TO DELETE*"
- (princ "The following BROWSE files are obsolete.\n\n")
- (princ BF)
- (princ "\n")
- (princ BFL)
- (princ "\n")
- (when (file-exists-p BFLB)
- (princ BFLB)
- (princ "\n"))
- )
- (when (y-or-n-p (format
- "Warning: Obsolete BROWSE file for: %s\nDelete? "
- directory))
- (delete-file BF)
- (delete-file BFL)
- (when (file-exists-p BFLB)
- (delete-file BFLB))
- )))))
- (defvar-mode-local c++-mode semanticdb-project-system-databases
- ()
- "Search Ebrowse for symbols.")
- (defmethod semanticdb-needs-refresh-p ((table semanticdb-table-ebrowse))
- "EBROWSE database do not need to be refreshed.
- JAVE: stub for needs-refresh, because, how do we know if BROWSE files
- are out of date?
- EML: Our database should probably remember the timestamp/checksum of
- the most recently read EBROWSE file, and use that."
- nil
- )
- (defun semanticdb-ebrowse-file-for-directory (dir)
- "Return the file name for DIR where the ebrowse BROWSE file is.
- This file should reside in `semanticdb-default-save-directory'."
- (let* ((semanticdb-default-save-directory
- semanticdb-default-save-directory)
- (B (semanticdb-file-name-directory
- 'semanticdb-project-database-file
- (concat (expand-file-name dir)
- semanticdb-ebrowse-default-file-name)))
- )
- B))
- (defun semanticdb-ebrowse-get-ebrowse-structure (dir)
- "Return the ebrowse structure for directory DIR.
- This assumes semantic manages the BROWSE files, so they are assumed to live
- where semantic cache files live, depending on your settings.
- For instance: /home/<username>/.semanticdb/!usr!include!BROWSE"
- (let* ((B (semanticdb-ebrowse-file-for-directory dir))
- (buf (get-buffer-create "*semanticdb ebrowse*")))
- (message "semanticdb-ebrowse %s" B)
- (when (file-exists-p B)
- (set-buffer buf)
- (buffer-disable-undo buf)
- (erase-buffer)
- (insert-file-contents B)
- (let ((ans nil)
- (efcn (symbol-function 'ebrowse-show-progress)))
- (fset 'ebrowse-show-progress #'(lambda (&rest junk) nil))
- (unwind-protect
- (setq ans (list B (ebrowse-read)))
-
- (erase-buffer)
- (fset 'ebrowse-show-fcn efcn)
- )
- ans))))
- (defmethod semanticdb-create-database :STATIC ((dbeC semanticdb-project-database-ebrowse)
- directory)
- "Create a new semantic database for DIRECTORY based on ebrowse.
- If there is no database for DIRECTORY available, then
- {not implemented yet} create one. Return nil if that is not possible."
-
- (require 'semantic/dep)
- (let ((dbs semanticdb-database-list)
- (found nil))
- (while (and (not found) dbs)
- (when (semanticdb-project-database-ebrowse-p (car dbs))
- (when (string= (oref (car dbs) reference-directory) directory)
- (setq found (car dbs))))
- (setq dbs (cdr dbs)))
-
- (let* ((ebrowse-data (semanticdb-ebrowse-get-ebrowse-structure directory))
- (dat (car (cdr ebrowse-data)))
- (ebd (car dat))
- (db nil)
- (default-directory directory)
- )
- (if found
- (setq db found)
- (setq db (make-instance
- dbeC
- directory
- :ebrowse-struct ebd
- ))
- (oset db reference-directory directory))
-
-
- (oset db tables nil)
-
- (semanticdb-ebrowse-strip-trees db dat)
-
-
- (semantic-add-system-include directory 'c++-mode)
- (semantic-add-system-include directory 'c-mode)
- db)))
- (defmethod semanticdb-ebrowse-strip-trees ((dbe semanticdb-project-database-ebrowse)
- data)
- "For the ebrowse database DBE, strip all tables from DATA."
- (let ((T (car (cdr data))))
- (while T
- (let* ((tree (car T))
- (class (ebrowse-ts-class tree))
-
- (filename (or (ebrowse-cs-source-file class)
- (ebrowse-cs-file class)))
- )
- (cond
- ((ebrowse-globals-tree-p tree)
-
- (semanticdb-ebrowse-add-globals-to-table dbe tree)
- )
- (t
-
-
-
-
- (semanticdb-ebrowse-add-tree-to-table dbe tree)
- ))
- (setq T (cdr T))))
- ))
- (defun semanticdb-ebrowse-add-globals-to-table (dbe tree)
- "For database DBE, add the ebrowse TREE into the table."
- (if (or (not (ebrowse-ts-p tree))
- (not (ebrowse-globals-tree-p tree)))
- (signal 'wrong-type-argument (list 'ebrowse-ts-p tree)))
- (let* ((class (ebrowse-ts-class tree))
- (fname (or (ebrowse-cs-source-file class)
- (ebrowse-cs-file class)
-
-
- (concat default-directory "/unknown-proxy.hh")))
- (vars (ebrowse-ts-member-functions tree))
- (fns (ebrowse-ts-member-variables tree))
- (toks nil)
- )
- (while vars
- (let ((nt (semantic-tag (ebrowse-ms-name (car vars))
- 'variable))
- (defpoint (ebrowse-bs-point class)))
- (when defpoint
- (semantic--tag-set-overlay nt
- (vector defpoint defpoint)))
- (setq toks (cons nt toks)))
- (setq vars (cdr vars)))
- (while fns
- (let ((nt (semantic-tag (ebrowse-ms-name (car fns))
- 'function))
- (defpoint (ebrowse-bs-point class)))
- (when defpoint
- (semantic--tag-set-overlay nt
- (vector defpoint defpoint)))
- (setq toks (cons nt toks)))
- (setq fns (cdr fns)))
- ))
- (defun semanticdb-ebrowse-add-tree-to-table (dbe tree &optional fname baseclasses)
- "For database DBE, add the ebrowse TREE into the table for FNAME.
- Optional argument BASECLASSES specifies a baseclass to the tree being provided."
- (if (not (ebrowse-ts-p tree))
- (signal 'wrong-type-argument (list 'ebrowse-ts-p tree)))
-
-
-
-
-
-
-
- (if (not fname)
- (setq fname (or (ebrowse-cs-source-file (ebrowse-ts-class tree))
- (ebrowse-cs-file (ebrowse-ts-class tree))
-
-
- (concat default-directory "/unknown-proxy.hh"))))
- (let* ((tab (or (semanticdb-file-table dbe fname)
- (semanticdb-create-table dbe fname)))
- (class (ebrowse-ts-class tree))
- (scope (ebrowse-cs-scope class))
- (ns (when scope (split-string scope ":" t)))
- (nst nil)
- (cls nil)
- )
-
- (when ns
- (let ((taglst (if (slot-boundp tab 'tags) (oref tab tags) nil)))
- (setq nst (semantic-find-first-tag-by-name (car ns) taglst))
- (when (not nst)
- (setq nst (semantic-tag (car ns) 'type :type "namespace"))
- (oset tab tags (cons nst taglst))
- )))
-
- (setq cls (semantic-tag (ebrowse-cs-name class)
- 'type
- :type "class"
- :superclasses baseclasses
- :faux t
- :filename fname
- ))
- (let ((defpoint (ebrowse-bs-point class)))
- (when defpoint
- (semantic--tag-set-overlay cls
- (vector defpoint defpoint))))
-
- (if nst
- (semantic-tag-put-attribute
- nst :members (cons cls (semantic-tag-get-attribute nst :members)))
- (oset tab tags (cons cls (when (slot-boundp tab 'tags)
- (oref tab tags)))))
-
- (let* ((subclass (ebrowse-ts-subclasses tree))
- (pname (ebrowse-cs-name class)))
- (when (ebrowse-cs-scope class)
- (setq pname (concat (mapconcat (lambda (a) a) (cdr ns) "::") "::" pname)))
- (while subclass
- (let* ((scc (ebrowse-ts-class (car subclass)))
- (fname (or (ebrowse-cs-source-file scc)
- (ebrowse-cs-file scc)
-
-
- fname
- )))
- (when fname
- (semanticdb-ebrowse-add-tree-to-table
- dbe (car subclass) fname pname)))
- (setq subclass (cdr subclass))))
- ))
- (defmethod semanticdb-normalize-tags ((obj semanticdb-table-ebrowse) tags)
- "Convert in Ebrowse database OBJ a list of TAGS into a complete tag.
- The default tag provided by searches exclude many features of a
- semantic parsed tag. Look up the file for OBJ, and match TAGS
- against a semantic parsed tag that has all the info needed, and
- return that."
- (let ((tagret nil)
- )
-
-
-
-
-
- (while tags
- (let ((tag (car tags)))
- (save-excursion
- (semanticdb-set-buffer obj)
- (let ((ans nil))
-
- (when (semantic-tag-with-position-p tag)
- (goto-char (semantic-tag-start tag))
- (let ((foundtag (semantic-current-tag)))
-
- (when (string= (semantic-tag-name tag)
- (semantic-tag-name foundtag))
-
- (setq ans foundtag))))
-
-
- (when (not ans)
-
-
- (setq ans (semantic-deep-find-tags-by-name
- (semantic-tag-name tag)
- (semantic-fetch-tags))))
- (if (semantic-tag-p ans)
- (setq tagret (cons ans tagret))
- (setq tagret (append ans tagret)))
- ))
- (setq tags (cdr tags))))
- tagret))
- (defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-ebrowse) tag)
- "Convert in Ebrowse database OBJ one TAG into a complete tag.
- The default tag provided by searches exclude many features of a
- semantic parsed tag. Look up the file for OBJ, and match TAG
- against a semantic parsed tag that has all the info needed, and
- return that."
- (let ((tagret nil)
- (objret nil))
-
-
-
-
-
- (save-excursion
- (semanticdb-set-buffer obj)
- (setq objret semanticdb-current-table)
- (when (not objret)
-
- (debug))
- (let ((ans nil))
-
- (when (semantic-tag-with-position-p tag)
- (goto-char (semantic-tag-start tag))
- (let ((foundtag (semantic-current-tag)))
-
- (when (string= (semantic-tag-name tag)
- (semantic-tag-name foundtag))
-
- (setq ans foundtag))))
-
-
- (when (not ans)
-
-
- (setq ans (semantic-deep-find-tags-by-name
- (semantic-tag-name tag)
- (semantic-fetch-tags))))
- (if (semantic-tag-p ans)
- (setq tagret ans)
- (setq tagret (car ans)))
- ))
- (cons objret tagret)))
- (defmethod semanticdb-find-tags-by-name-method
- ((table semanticdb-table-ebrowse) name &optional tags)
- "Find all tags named NAME in TABLE.
- Return a list of tags."
-
- (if tags
-
- (call-next-method)
-
-
-
- (call-next-method)
- )
- )
- (defmethod semanticdb-find-tags-by-name-regexp-method
- ((table semanticdb-table-ebrowse) regex &optional tags)
- "Find all tags with name matching REGEX in TABLE.
- Optional argument TAGS is a list of tags to search.
- Return a list of tags."
- (if tags (call-next-method)
-
- (call-next-method)
- ))
- (defmethod semanticdb-find-tags-for-completion-method
- ((table semanticdb-table-ebrowse) 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."
- (if tags (call-next-method)
-
- (call-next-method)
- ))
- (defmethod semanticdb-find-tags-by-class-method
- ((table semanticdb-table-ebrowse) 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."
- (if tags (call-next-method)
- (call-next-method)))
- (defmethod semanticdb-deep-find-tags-by-name-method
- ((table semanticdb-table-ebrowse) name &optional tags)
- "Find all tags name NAME in TABLE.
- Optional argument TAGS is a list of tags to search.
- Like `semanticdb-find-tags-by-name-method' for ebrowse."
-
- (call-next-method))
- (defmethod semanticdb-deep-find-tags-by-name-regexp-method
- ((table semanticdb-table-ebrowse) regex &optional tags)
- "Find all tags with name matching REGEX in TABLE.
- Optional argument TAGS is a list of tags to search.
- Like `semanticdb-find-tags-by-name-method' for ebrowse."
-
- (call-next-method))
- (defmethod semanticdb-deep-find-tags-for-completion-method
- ((table semanticdb-table-ebrowse) prefix &optional tags)
- "In TABLE, find all occurrences of tags matching PREFIX.
- Optional argument TAGS is a list of tags to search.
- Like `semanticdb-find-tags-for-completion-method' for ebrowse."
-
- (call-next-method))
- (defmethod semanticdb-find-tags-external-children-of-type-method
- ((table semanticdb-table-ebrowse) type &optional tags)
- "Find all nonterminals which are child elements of TYPE
- Optional argument TAGS is a list of tags to search.
- Return a list of tags."
- (if tags (call-next-method)
-
-
- nil
- ))
- (provide 'semantic/db-ebrowse)
|