diff lisp/cedet/semantic/db-file.el @ 104420:2e15afd37998

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.

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/cedet/semantic/db-file.el	Sat Aug 29 19:32:33 2009 +0000
@@ -0,0 +1,438 @@
+;;; db-file.el --- Save a semanticdb to a cache file.
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <[e-mail]>
+;; Keywords: tags
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; A set of semanticdb classes for persistently saving caches on disk.
+;;
+
+(require 'semantic)
+(require 'semantic/db)
+(require 'cedet-files)
+
+(defvar semanticdb-file-version semantic-version
+  "Version of semanticdb we are writing files to disk with.")
+(defvar semanticdb-file-incompatible-version "1.4"
+  "Version of semanticdb we are not reverse compatible with.")
+
+;;; Settings
+;;
+(defcustom semanticdb-default-file-name "semantic.cache"
+  "*File name of the semantic tag cache."
+  :group 'semanticdb
+  :type 'string)
+
+(defcustom semanticdb-default-save-directory (expand-file-name "~/.semanticdb")
+  "*Directory name where semantic cache files are stored.
+If this value is nil, files are saved in the current directory.  If the value
+is a valid directory, then it overrides `semanticdb-default-file-name' and
+stores caches in a coded file name in this directory."
+  :group 'semanticdb
+  :type '(choice :tag "Default-Directory"
+                 :menu-tag "Default-Directory"
+                 (const :tag "Use current directory" :value nil)
+                 (directory)))
+
+(defcustom semanticdb-persistent-path '(always)
+  "*List of valid paths that semanticdb will cache tags to.
+When `global-semanticdb-minor-mode' is active, tag lists will
+be saved to disk when Emacs exits.  Not all directories will have
+tags that should be saved.
+The value should be a list of valid paths.  A path can be a string,
+indicating a directory in which to save a variable.  An element in the
+list can also be a symbol.  Valid symbols are `never', which will
+disable any saving anywhere, `always', which enables saving
+everywhere, or `project', which enables saving in any directory that
+passes a list of predicates in `semanticdb-project-predicate-functions'."
+  :group 'semanticdb
+  :type nil)
+
+(defcustom semanticdb-save-database-hooks nil
+  "*Hooks run after a database is saved.
+Each function is called with one argument, the object representing
+the database recently written."
+  :group 'semanticdb
+  :type 'hook)
+
+(defvar semanticdb-dir-sep-char (if (boundp 'directory-sep-char)
+				    (symbol-value 'directory-sep-char)
+				  ?/)
+  "Character used for directory separation.
+Obsoleted in some versions of Emacs.  Needed in others.
+NOTE: This should get deleted from semantic soon.")
+
+(defun semanticdb-fix-pathname (dir)
+  "If DIR is broken, fix it.
+Force DIR to end with a /.
+Note: Same as `file-name-as-directory'.
+NOTE: This should get deleted from semantic soon."
+  (file-name-as-directory dir))
+;; I didn't initially know about the above fcn.  Keep the below as a
+;; reference.  Delete it someday once I've proven everything is the same.
+;;  (if (not (= semanticdb-dir-sep-char (aref path (1- (length path)))))
+;;      (concat path (list semanticdb-dir-sep-char))
+;;    path))
+
+;;; Classes
+;;
+(defclass semanticdb-project-database-file (semanticdb-project-database
+					    eieio-persistent)
+  ((file-header-line :initform ";; SEMANTICDB Tags save file")
+   (do-backups :initform nil)
+   (semantic-tag-version :initarg :semantic-tag-version
+			 :initform "1.4"
+			 :documentation
+			 "The version of the tags saved.
+The default value is 1.4.  In semantic 1.4 there was no versioning, so
+when those files are loaded, this becomes the version number.
+To save the version number, we must hand-set this version string.")
+   (semanticdb-version :initarg :semanticdb-version
+		       :initform "1.4"
+		       :documentation
+		       "The version of the object system saved.
+The default value is 1.4.  In semantic 1.4, there was no versioning,
+so when those files are loaded, this becomes the version number.
+To save the version number, we must hand-set this version string.")
+   )
+  "Database of file tables saved to disk.")
+
+;;; Code:
+;;
+(defmethod semanticdb-create-database :STATIC ((dbc semanticdb-project-database-file)
+					       directory)
+  "Create a new semantic database for DIRECTORY and return it.
+If a database for DIRECTORY has already been loaded, return it.
+If a database for DIRECTORY exists, then load that database, and return it.
+If DIRECTORY doesn't exist, create a new one."
+  ;; Make sure this is fully expanded so we don't get duplicates.
+  (setq directory (file-truename directory))
+  (let* ((fn (semanticdb-cache-filename dbc directory))
+	 (db (or (semanticdb-file-loaded-p fn)
+		 (if (file-exists-p fn)
+		     (progn
+		       (semanticdb-load-database fn))))))
+    (unless db
+      (setq db (make-instance
+		dbc  ; Create the database requested.  Perhaps
+		(concat (file-name-nondirectory
+			 (directory-file-name
+			  directory))
+			"/")
+		:file fn :tables nil
+		:semantic-tag-version semantic-version
+		:semanticdb-version semanticdb-file-version)))
+    ;; Set this up here.   We can't put it in the constructor because it
+    ;; would be saved, and we want DB files to be portable.
+    (oset db reference-directory directory)
+    db))
+
+;;; File IO
+(defun semanticdb-load-database (filename)
+  "Load the database FILENAME."
+  (require 'inversion)
+  (condition-case foo
+      (let* ((r (eieio-persistent-read filename))
+	     (c (semanticdb-get-database-tables r))
+	     (tv (oref r semantic-tag-version))
+	     (fv (oref r semanticdb-version))
+	     )
+	;; Restore the parent-db connection
+	(while c
+	  (oset (car c) parent-db r)
+	  (setq c (cdr c)))
+	(if (not (inversion-test 'semanticdb-file fv))
+	    (when (inversion-test 'semantic-tag tv)
+	      ;; Incompatible version.  Flush tables.
+	      (semanticdb-flush-database-tables r)
+	      ;; Reset the version to new version.
+	      (oset r semantic-tag-version semantic-tag-version)
+	      ;; Warn user
+	      (message "Semanticdb file is old.  Starting over for %s"
+		       filename)
+	      )
+	  ;; Version is not ok.  Flush whole system
+	  (message "semanticdb file is old.  Starting over for %s"
+		   filename)
+	  ;; This database is so old, we need to replace it.
+	  ;; We also need to delete it from the instance tracker.
+	  (delete-instance r)
+	  (setq r nil))
+	r)
+    (error (message "Cache Error: [%s] %s, Restart"
+		    filename foo)
+	   nil)))
+
+(defun semanticdb-file-loaded-p (filename)
+  "Return the project belonging to FILENAME if it was already loaded."
+  (eieio-instance-tracker-find filename 'file 'semanticdb-database-list))
+
+(defmethod semanticdb-file-directory-exists-p ((DB semanticdb-project-database-file)
+					       &optional supress-questions)
+  "Does the directory the database DB needs to write to exist?
+If SUPRESS-QUESTIONS, then do not ask to create the directory."
+  (let ((dest (file-name-directory (oref DB file)))
+	)
+    (cond ((null dest)
+	   ;; @TODO - If it was never set up... what should we do ?
+	   nil)
+	  ((file-exists-p dest) t)
+	  (supress-questions nil)
+	  ((y-or-n-p (format "Create directory %s for SemanticDB? "
+			     dest))
+	   (make-directory dest t)
+	   t)
+	  (t nil))
+    ))
+
+(defmethod semanticdb-save-db ((DB semanticdb-project-database-file)
+			       &optional
+			       supress-questions)
+  "Write out the database DB to its file.
+If DB is not specified, then use the current database."
+  (let ((objname (oref DB file)))
+    (when (and (semanticdb-dirty-p DB)
+	       (semanticdb-live-p DB)
+	       (semanticdb-file-directory-exists-p DB supress-questions)
+	       (semanticdb-write-directory-p DB)
+	       )
+      ;;(message "Saving tag summary for %s..." objname)
+      (condition-case foo
+	  (eieio-persistent-save (or DB semanticdb-current-database))
+	(file-error		    ; System error saving?  Ignore it.
+	 (message "%S: %s" foo objname))
+	(error
+	 (cond
+	  ((and (listp foo)
+		(stringp (nth 1 foo))
+		(string-match "write[- ]protected" (nth 1 foo)))
+	   (message (nth 1 foo)))
+	  ((and (listp foo)
+		(stringp (nth 1 foo))
+		(string-match "no such directory" (nth 1 foo)))
+	   (message (nth 1 foo)))
+	  (t
+	   ;; @todo - It should ask if we are not called from a hook.
+	   ;;         How?
+	   (if (or supress-questions
+		   (y-or-n-p (format "Skip Error: %S ?" (car (cdr foo)))))
+	       (message "Save Error: %S: %s" (car (cdr foo))
+			objname)
+	     (error "%S" (car (cdr foo))))))))
+      (run-hook-with-args 'semanticdb-save-database-hooks
+			  (or DB semanticdb-current-database))
+      ;;(message "Saving tag summary for %s...done" objname)
+      )
+    ))
+
+(defmethod semanticdb-live-p ((obj semanticdb-project-database))
+  "Return non-nil if the file associated with OBJ is live.
+Live databases are objects associated with existing directories."
+  (and (slot-boundp obj 'reference-directory)
+       (file-exists-p (oref obj reference-directory))))
+
+(defmethod semanticdb-live-p ((obj semanticdb-table))
+  "Return non-nil if the file associated with OBJ is live.
+Live files are either buffers in Emacs, or files existing on the filesystem."
+  (let ((full-filename (semanticdb-full-filename obj)))
+    (or (find-buffer-visiting full-filename)
+	(file-exists-p full-filename))))
+
+(defvar semanticdb-data-debug-on-write-error nil
+  "Run the data debugger on tables that issue errors.
+This variable is set to nil after the first error is encountered
+to prevent overload.")
+
+(defmethod object-write ((obj semanticdb-table))
+  "When writing a table, we have to make sure we deoverlay it first.
+Restore the overlays after writting.
+Argument OBJ is the object to write."
+  (when (semanticdb-live-p obj)
+    (when (semanticdb-in-buffer-p obj)
+      (save-excursion
+	(set-buffer (semanticdb-in-buffer-p obj))
+
+	;; Make sure all our tag lists are up to date.
+	(semantic-fetch-tags)
+
+	;; Try to get an accurate unmatched syntax table.
+	(when (and (boundp semantic-show-unmatched-syntax-mode)
+		   semantic-show-unmatched-syntax-mode)
+	  ;; Only do this if the user runs unmatched syntax
+	  ;; mode display enties.
+	  (oset obj unmatched-syntax
+		(semantic-show-unmatched-lex-tokens-fetch))
+	  )
+
+	;; Make sure pointmax is up to date
+	(oset obj pointmax (point-max))
+	))
+
+    ;; Make sure that the file size and other attributes are
+    ;; up to date.
+    (let ((fattr (file-attributes (semanticdb-full-filename obj))))
+      (oset obj fsize (nth 7 fattr))
+      (oset obj lastmodtime (nth 5 fattr))
+      )
+
+    ;; Do it!
+    (condition-case tableerror
+	(call-next-method)
+      (error
+       (when semanticdb-data-debug-on-write-error
+	 (require 'data-debug)
+	 (data-debug-new-buffer (concat "*SEMANTICDB ERROR*"))
+	 (data-debug-insert-thing obj "*" "")
+	 (setq semanticdb-data-debug-on-write-error nil))
+       (message "Error Writing Table: %s" (object-name obj))
+       (error "%S" (car (cdr tableerror)))))
+
+    ;; Clear the dirty bit.
+    (oset obj dirty nil)
+    ))
+
+;;; State queries
+;;
+(defmethod semanticdb-write-directory-p ((obj semanticdb-project-database-file))
+  "Return non-nil if OBJ should be written to disk.
+Uses `semanticdb-persistent-path' to determine the return value."
+  (let ((path semanticdb-persistent-path))
+    (catch 'found
+      (while path
+	(cond ((stringp (car path))
+	       (if (string= (oref obj reference-directory) (car path))
+		   (throw 'found t)))
+	      ((eq (car path) 'project)
+	       ;; @TODO - EDE causes us to go in here and disable
+	       ;; the old default 'always save' setting.
+	       ;;
+	       ;; With new default 'always' should I care?
+	       (if semanticdb-project-predicate-functions
+		   (if (run-hook-with-args-until-success
+			'semanticdb-project-predicate-functions
+			(oref obj reference-directory))
+		       (throw 'found t))
+		 ;; If the mode is 'project, and there are no project
+		 ;; modes, then just always save the file.  If users
+		 ;; wish to restrict the search, modify
+		 ;; `semanticdb-persistent-path' to include desired paths.
+		 (if (= (length semanticdb-persistent-path) 1)
+		     (throw 'found t))
+		 ))
+	      ((eq (car path) 'never)
+	       (throw 'found nil))
+	      ((eq (car path) 'always)
+	       (throw 'found t))
+	      (t (error "Invalid path %S" (car path))))
+	(setq path (cdr path)))
+      (call-next-method))
+    ))
+
+;;; Filename manipulation
+;;
+(defmethod semanticdb-file-table ((obj semanticdb-project-database-file) filename)
+  "From OBJ, return FILENAME's associated table object."
+  ;; Cheater option.  In this case, we always have files directly
+  ;; under ourselves.  The main project type may not.
+  (object-assoc (file-name-nondirectory filename) 'file (oref obj tables)))
+
+(defmethod semanticdb-file-name-non-directory :STATIC
+  ((dbclass semanticdb-project-database-file))
+  "Return the file name DBCLASS will use.
+File name excludes any directory part."
+  semanticdb-default-file-name)
+
+(defmethod semanticdb-file-name-directory :STATIC
+  ((dbclass semanticdb-project-database-file) directory)
+  "Return the relative directory to where DBCLASS will save its cache file.
+The returned path is related to DIRECTORY."
+  (if semanticdb-default-save-directory
+      (let ((file (cedet-directory-name-to-file-name directory)))
+        ;; Now create a filename for the cache file in
+        ;; ;`semanticdb-default-save-directory'.
+	(expand-file-name
+	 file (file-name-as-directory semanticdb-default-save-directory)))
+    directory))
+
+(defmethod semanticdb-cache-filename :STATIC
+  ((dbclass semanticdb-project-database-file) path)
+  "For DBCLASS, return a file to a cache file belonging to PATH.
+This could be a cache file in the current directory, or an encoded file
+name in a secondary directory."
+  ;; Use concat and not expand-file-name, because the dir part
+  ;; may include some of the file name.
+  (concat (semanticdb-file-name-directory dbclass path)
+	  (semanticdb-file-name-non-directory dbclass)))
+
+(defmethod semanticdb-full-filename ((obj semanticdb-project-database-file))
+  "Fetch the full filename that OBJ refers to."
+  (oref obj file))
+
+;;; FLUSH OLD FILES
+;;
+(defun semanticdb-cleanup-cache-files (&optional noerror)
+  "Cleanup any cache files associated with directories that no longer exist.
+Optional NOERROR prevents errors from being displayed."
+  (interactive)
+  (when (and (not semanticdb-default-save-directory)
+	     (not noerror))
+    (error "No default save directory for semantic-save files"))
+
+  (when semanticdb-default-save-directory
+
+    ;; Calculate all the cache files we have.
+    (let* ((regexp (regexp-quote semanticdb-default-file-name))
+	   (files (directory-files semanticdb-default-save-directory
+				   t regexp))
+	   (orig nil)
+	   (to-delete nil))
+      (dolist (F files)
+	(setq orig (cedet-file-name-to-directory-name
+		    (file-name-nondirectory F)))
+	(when (not (file-exists-p (file-name-directory orig)))
+	  (setq to-delete (cons F to-delete))
+	  ))
+      (if to-delete
+	(save-window-excursion
+	  (let ((buff (get-buffer-create "*Semanticdb Delete*")))
+	    (with-current-buffer buff
+	      (erase-buffer)
+	      (insert "The following Cache files appear to be obsolete.\n\n")
+	      (dolist (F to-delete)
+		(insert F "\n")))
+	    (pop-to-buffer buff t t)
+	    (fit-window-to-buffer (get-buffer-window buff) nil 1)
+	    (when (y-or-n-p "Delete Old Cache Files? ")
+	      (mapc (lambda (F)
+		      (message "Deleting to %s..." F)
+		      (delete-file F))
+		    to-delete)
+	      (message "done."))
+	    ))
+	;; No files to delete
+	(when (not noerror)
+	  (message "No obsolete semanticdb.cache files."))
+	))))
+
+(provide 'semantic/db-file)
+
+;;; semanticdb-file.el ends here