semantic / semanticdb.el

Diff from to

File semanticdb.el

 ;;; semanticdb.el --- Semantic token database manager
-;;; Copyright (C) 2000, 2001 Eric M. Ludlam
+;;; Copyright (C) 2000, 2001, 2002 Eric M. Ludlam
 ;; Author: Eric M. Ludlam <>
 ;; Keywords: tags
   :group 'semanticdb
   :type 'string)
+(defcustom semanticdb-default-save-directory nil
+  "*Directory name where semantic cache files are stored.
+If this value is nil, files are saved in the current directory. If the value
+is a valid directory, then it overrides `semanticdb-default-file-name' and
+stores caches in a coded file name in this directory."
+  :group 'semanticdb
+  :type '(choice :tag "Default-Directory"
+                 :menu-tag "Default-Directory"
+                 (const :tag "Use current directory" :value nil)
+                 (directory)))
 (defcustom semanticdb-persistent-path '(project)
   "*List of valid paths that semanticdb will cache tokens to.
 When `global-semanticdb-minor-mode' is active, token lists will
   ((tracking-symbol :initform semanticdb-database-list)
    (file-header-line :initform ";; SEMANTICDB Tags save file")
+   (reference-directory :type string
+			:documentation "Directory this database refers to.
+When a cache directory is specified, then this refers to the directory
+this database contains symbols for.")
    (tables :initarg :tables
 	   :type list
 	   :documentation "List of `semantic-db-table' objects."))
 Sometimes it is important for a program to know if a given table has the
 same major mode as the current buffer.")
    (tokens :initarg :tokens
-	   :documentation "The tokens belonging to this table."))
+	   :documentation "The tokens belonging to this table.")
+   (unmatched-syntax :initarg :unmatched-syntax
+		     :documentation
+		     "List of vectors specifying unmatched syntax.")
+   )
   "A single table of tokens belonging to a given file.")
 ;;; Code:
   (let ((db (if (file-exists-p filename)
 		(or (semanticdb-file-loaded-p filename)
 		    (semanticdb-load-database filename)))))
-  (if (not (semanticdb-file-loaded-p filename))
+    (unless db
       (setq db (semanticdb-project-database (file-name-nondirectory filename)
 					    :file filename
 					    :tables nil)))
-  db))
+    db))
+(defun semanticdb-file-loaded-p (filename)
+  "Return the project belonging to FILENAME if it was already loaded."
+  (eieio-instance-tracker-find filename 'file 'semanticdb-database-list))
 (defun semanticdb-get-database (filename)
   "Get a database for FILENAME.
 If one isn't found, create one."
-  (or (eieio-instance-tracker-find filename 'file 'semanticdb-database-list)
+  (or (semanticdb-file-loaded-p filename)
       (semanticdb-create-database filename)))
 (defun semanticdb-load-database (filename)
     (error (message "Cache Error: %s, Restart" foo)
-(defun semanticdb-file-loaded-p (filename)
-  "Return the project belonging to FILENAME if it was already loaded."
-  (object-assoc filename 'file semanticdb-database-list))
 (defmethod semanticdb-live-p ((obj semanticdb-project-database))
   "Return non-nil if the file associated with OBJ is live.
 Live databases are objects associated with existing directories."
 (defmethod semanticdb-file-table ((obj semanticdb-project-database) filename)
   "From OBJ, return FILENAMEs associated table object."
-  (object-assoc (eieio-persistent-path-relative obj filename)
-		'file (oref obj tables)))
+  (object-assoc (file-name-nondirectory filename) 'file (oref obj tables)))
 (defun semanticdb-save-db (&optional DB)
   "Write out the database DB to its file.
 (defmethod semanticdb-full-filename ((obj semanticdb-table))
   "Fetch the full filename that OBJ refers to."
-  (concat (file-name-directory (oref (oref obj parent-db) file))
+  (concat (file-name-directory (oref (oref obj parent-db) reference-directory))
 	  (oref obj file)))
 (defmethod semanticdb-live-p ((obj semanticdb-table))
     (catch 'found
       (while path
 	(cond ((stringp (car path))
-	       (if (string= (file-name-directory (oref obj file)) (car path))
+	       (if (string= (oref obj reference-directory) (car path))
 		   (throw 'found t)))
 	      ((eq (car path) 'project)
 	       (let ((predicates semanticdb-project-predicates))
 		 (if predicates
 		     (while predicates
 		       (if (funcall (car predicates)
-				    (file-name-directory (oref obj file)))
+				    (oref obj reference-directory))
 			   (throw 'found t))
 		       (setq predicates (cdr predicates)))
 		   ;; If the mode is 'project, and there are no project
-;;; hooks and Hats:
+;;; Filename manipulation
+(defun semanticdb-cache-filename (path)
+  "Return a file to a cache file belonging to PATH.
+This could be a cache file in the current directory, or an encoded file
+name in a secondary directory."
+  (if semanticdb-default-save-directory
+      (let ((file path))
+        (when (memq system-type '(windows-nt ms-dos))
+          ;; Normalize DOSish file names: convert all slashes to
+          ;; directory-sep-char, downcase the drive letter, if any,
+          ;; and replace the leading "x:" with "/drive_x".
+          (or (file-name-absolute-p file)
+              (setq file (expand-file-name file))) ; make defaults explicit
+          ;; Replace any invalid file-name characters (for the
+          ;; case of backing up remote files).
+          (setq file (expand-file-name (convert-standard-filename file)))
+          (setq dir-sep-string (char-to-string directory-sep-char))
+          (if (eq (aref file 1) ?:)
+              (setq file (concat dir-sep-string
+                                 "drive_"
+                                 (char-to-string (downcase (aref file 0)))
+                                 (if (eq (aref file 2) directory-sep-char)
+                                     ""
+                                   dir-sep-string)
+                                 (substring file 2)))))
+        ;; Make the name unique by substituting directory
+        ;; separators.  It may not really be worth bothering about
+        ;; doubling `!'s in the original name...
+        (setq file (subst-char-in-string
+                    directory-sep-char ?!
+                    (replace-regexp-in-string "!" "!!" file)))
+        ;; Now create a filename for the cache file in
+        ;; `semanticdb-default-save-directory'.
+     (expand-file-name
+         (concat (file-name-as-directory semanticdb-default-save-directory)
+                 file)))
+    (concat (file-name-directory (buffer-file-name))
+         semanticdb-default-file-name)))
+;;; Hooks:
 (defun semanticdb-semantic-init-hook-fcn ()
   "Function saved in `find-file-hooks'.
 Sets up the semanticdb environment."
   (let ((cdb nil)
 	(ctbl nil))
-    (if (not (and semanticdb-semantic-init-hook-overload
-		  (setq cdb (run-hooks 'semanticdb-semantic-init-hook-overload))))
-	(setq cdb
-	      (semanticdb-get-database
-	       (concat (file-name-directory (buffer-file-name))
-		       semanticdb-default-file-name))))
+    ;; Allow a database override function
+    (when (not (and semanticdb-semantic-init-hook-overload
+		    (setq cdb (run-hooks 'semanticdb-semantic-init-hook-overload))))
+      (setq cdb
+	    (semanticdb-get-database
+	     (semanticdb-cache-filename default-directory)))
+      )
+    ;; Do this outside of the find to make sure that when people upgrade
+    ;; that they get this set properly.
+    (oset cdb reference-directory default-directory)
+    ;; Get the current DB for this directory
     (setq semanticdb-current-database cdb)
+    ;; Get a table for this file.
     (setq ctbl (semanticdb-file-table cdb (buffer-file-name)))
     (unless ctbl
+      ;; Create a table if none exists.
       (setq ctbl
-	     (eieio-persistent-path-relative
-	      semanticdb-current-database (buffer-file-name))
-	     :file (eieio-persistent-path-relative
-		    semanticdb-current-database (buffer-file-name))
+	     (file-name-nondirectory (buffer-file-name))
+	     :file (file-name-nondirectory (buffer-file-name))
       (oset ctbl parent-db cdb)
       (object-add-to-list semanticdb-current-database
+    ;; Local state
     (setq semanticdb-current-table ctbl)
     (oset semanticdb-current-table major-mode major-mode)
+    ;; Try to swap in saved tokens
     (if (or (not (slot-boundp ctbl 'tokens)) (not (oref ctbl tokens))
 	    (/= (or (oref ctbl pointmax) 0) (point-max))
-	(progn
-	  (semantic-clear-toplevel-cache)
-	  (condition-case nil
-	      (semantic-bovinate-toplevel t)
-	    (quit (message "semanticdb: Semantic Token generation halted."))
-	    (error (error "Semanticdb: bovination failed at startup"))))
+	(semantic-clear-toplevel-cache)
+      (condition-case nil
+          (semantic-set-unmatched-syntax-cache
+           (oref ctbl unmatched-syntax))
+        (unbound-slot
+         ;; Old version of the semanticdb table can miss the unmatched
+         ;; syntax slot.  If so, just clear the unmatched syntax cache.
+         (semantic-clear-unmatched-syntax-cache)))
       (semantic-set-toplevel-bovine-cache  (oref ctbl tokens))
-      (semantic-overlay-cache))
+      (semantic-overlay-cache)
+      )
 (defun semanticdb-post-bovination (new-table)
   (if semanticdb-current-table
       (oset semanticdb-current-table tokens new-table)))
+(defun semanticdb-post-bovination-unmatched-syntax (new-un-tax)
+  "Function run after a bovination w/ unmatched syntax.
+Argument NEW-UN-TAX is the new unmatched syntax table."
+  (if semanticdb-current-table
+      (oset semanticdb-current-table unmatched-syntax new-un-tax)))
 (defun semanticdb-kill-hook ()
   "Function run when a buffer is killed.
 If there is a semantic cache, slurp out the overlays, an store
 ;;; Start/Stop database use
 (defvar semanticdb-hooks
-  '((semanticdb-semantic-init-hook-fcn semantic-init-hooks)
+  '((semanticdb-semantic-init-hook-fcn semantic-init-db-hooks)
     (semanticdb-post-bovination semantic-after-toplevel-cache-change-hook)
+    (semanticdb-post-bovination-unmatched-syntax semantic-unmatched-syntax-hook)
     (semanticdb-kill-hook kill-buffer-hook)
     (semanticdb-kill-emacs-hook kill-emacs-hook)
   (member (car (car semanticdb-hooks))
 	  (symbol-value (car (cdr (car semanticdb-hooks))))))
 (defun global-semanticdb-minor-mode (&optional arg)
   "Toggle the use of `semanticdb-minor-mode'.
 If ARG is positive, enable, if it is negative, disable.
   (let ((fn 'add-hook)
 	(h semanticdb-hooks))
     (if (< arg 0)
-	(setq fn 'remove-hook))
+	(setq semanticdb-global-mode nil
+              fn 'remove-hook)
+      (setq semanticdb-global-mode t))
     ;(message "ARG = %d" arg)
     (while h
       (funcall fn (car (cdr (car h))) (car (car h)))
 Update the environment of Semantic enabled buffers accordingly."
   (if (semanticdb-minor-mode-p)
-      (progn
-        ;; Update databases before disabling semanticdb.
-        (semantic-map-buffers #'semanticdb-kill-hook)
-        ;; Save the databases.
-        (semanticdb-save-all-db)))
+      ;; Save databases before disabling semanticdb.
+      (semanticdb-save-all-db))
   ;; Toggle semanticdb minor mode.
-  (global-semanticdb-minor-mode)
-  )
+  (global-semanticdb-minor-mode))
 ;;; Utilities
 ;;; Search routines
+(defun semanticdb-find-nonterminal-by-token
+  (token &optional databases search-parts search-includes diff-mode find-file-match)
+  "Find all occurances of nonterminals with token TOKEN in databases.
+See `semanticdb-find-nonterminal-by-function' for details on DATABASES,
+Return a list ((DB-TABLE . TOKEN-LIST) ...)."
+  (let ((goofy-token-name-thing token))
+    (semanticdb-find-nonterminal-by-function
+     (lambda (stream sp si)
+       (semantic-find-nonterminal-by-token goofy-token-name-thing
+					   stream sp si))
+     databases search-parts search-includes diff-mode find-file-match)))
 (defun semanticdb-find-nonterminal-by-name
   (name &optional databases search-parts search-includes diff-mode find-file-match)
   "Find all occurances of nonterminals with name NAME in databases.
 	  ;; if not, just do it.
 	  (semantic-bovinate-toplevel t))))
+;;; Validate the semantic database
+(defun semanticdb-table-oob-sanity-check (cache)
+  "Validate that CACHE tokens do not have any overlays in them."
+  (while cache
+    (when (semantic-overlay-p (semantic-token-overlay cache))
+      (message "Token %s has an erroneous overlay!"
+	       (semantic-summarize-nonterminal (car cache))))
+    (semanticdb-table-oob-sanity-check
+     (semantic-nonterminal-children (car cache) t))
+    (setq cache (cdr cache))))
+(defun semanticdb-table-sanity-check (&optional table)
+  "Validate the current semanticdb TABLE."
+  (interactive)
+  (if (not table) (setq table semanticdb-current-table))
+  (let* ((full-filename (semanticdb-full-filename table))
+	 (buff (get-file-buffer full-filename)))
+    (if buff
+	(save-excursion
+	  (set-buffer buff)
+	  (semantic-sanity-check))
+      ;; We can't use the usual semantic validity check, so hack our own.
+      (semanticdb-table-oob-sanity-check (oref table tokens)))))
+(defun semanticdb-database-sanity-check ()
+  "Validate the current semantic database."
+  (interactive)
+  (let ((tables (oref semanticdb-current-database tables)))
+    (while tables
+      (semanticdb-table-sanity-check (car tables))
+      (setq tables (cdr tables)))
+    ))
 (provide 'semanticdb)