Commit | Line | Data |
---|---|---|
691a065e | 1 | ;;; semantic/db-file.el --- Save a semanticdb to a cache file. |
f273dfc6 | 2 | |
95df8112 | 3 | ;;; Copyright (C) 2000-2005, 2007-2011 Free Software Foundation, Inc. |
f273dfc6 CY |
4 | |
5 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | |
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 | ;; A set of semanticdb classes for persistently saving caches on disk. | |
26 | ;; | |
27 | ||
28 | (require 'semantic) | |
29 | (require 'semantic/db) | |
30 | (require 'cedet-files) | |
31 | ||
32 | (defvar semanticdb-file-version semantic-version | |
33 | "Version of semanticdb we are writing files to disk with.") | |
34 | (defvar semanticdb-file-incompatible-version "1.4" | |
35 | "Version of semanticdb we are not reverse compatible with.") | |
36 | ||
37 | ;;; Settings | |
38 | ;; | |
39 | (defcustom semanticdb-default-file-name "semantic.cache" | |
5bebb332 | 40 | "File name of the semantic tag cache." |
f273dfc6 CY |
41 | :group 'semanticdb |
42 | :type 'string) | |
43 | ||
5bebb332 | 44 | (defcustom semanticdb-default-save-directory |
0fd9cb9c | 45 | (locate-user-emacs-file "semanticdb" ".semanticdb") |
5bebb332 | 46 | "Directory name where semantic cache files are stored. |
f273dfc6 CY |
47 | If this value is nil, files are saved in the current directory. If the value |
48 | is a valid directory, then it overrides `semanticdb-default-file-name' and | |
49 | stores 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) | |
5bebb332 | 57 | "List of valid paths that semanticdb will cache tags to. |
f273dfc6 CY |
58 | When `global-semanticdb-minor-mode' is active, tag lists will |
59 | be saved to disk when Emacs exits. Not all directories will have | |
60 | tags that should be saved. | |
61 | The value should be a list of valid paths. A path can be a string, | |
62 | indicating a directory in which to save a variable. An element in the | |
63 | list can also be a symbol. Valid symbols are `never', which will | |
64 | disable any saving anywhere, `always', which enables saving | |
65 | everywhere, or `project', which enables saving in any directory that | |
66 | passes a list of predicates in `semanticdb-project-predicate-functions'." | |
67 | :group 'semanticdb | |
68 | :type nil) | |
69 | ||
57f4d2f8 CY |
70 | (defcustom semanticdb-save-database-hooks nil |
71 | "Abnormal hook run after a database is saved. | |
f273dfc6 CY |
72 | Each function is called with one argument, the object representing |
73 | the 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. | |
81 | Obsoleted in some versions of Emacs. Needed in others. | |
82 | NOTE: This should get deleted from semantic soon.") | |
83 | ||
84 | (defun semanticdb-fix-pathname (dir) | |
85 | "If DIR is broken, fix it. | |
86 | Force DIR to end with a /. | |
87 | Note: Same as `file-name-as-directory'. | |
88 | NOTE: 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 | ;; | |
dac49f4e | 98 | ;;;###autoload |
f273dfc6 CY |
99 | (defclass semanticdb-project-database-file (semanticdb-project-database |
100 | eieio-persistent) | |
101 | ((file-header-line :initform ";; SEMANTICDB Tags save file") | |
102 | (do-backups :initform nil) | |
103 | (semantic-tag-version :initarg :semantic-tag-version | |
104 | :initform "1.4" | |
105 | :documentation | |
106 | "The version of the tags saved. | |
107 | The default value is 1.4. In semantic 1.4 there was no versioning, so | |
108 | when those files are loaded, this becomes the version number. | |
109 | To save the version number, we must hand-set this version string.") | |
110 | (semanticdb-version :initarg :semanticdb-version | |
111 | :initform "1.4" | |
112 | :documentation | |
113 | "The version of the object system saved. | |
114 | The default value is 1.4. In semantic 1.4, there was no versioning, | |
115 | so when those files are loaded, this becomes the version number. | |
116 | To save the version number, we must hand-set this version string.") | |
117 | ) | |
118 | "Database of file tables saved to disk.") | |
119 | ||
120 | ;;; Code: | |
121 | ;; | |
122 | (defmethod semanticdb-create-database :STATIC ((dbc semanticdb-project-database-file) | |
123 | directory) | |
124 | "Create a new semantic database for DIRECTORY and return it. | |
125 | If a database for DIRECTORY has already been loaded, return it. | |
126 | If a database for DIRECTORY exists, then load that database, and return it. | |
127 | If DIRECTORY doesn't exist, create a new one." | |
128 | ;; Make sure this is fully expanded so we don't get duplicates. | |
129 | (setq directory (file-truename directory)) | |
130 | (let* ((fn (semanticdb-cache-filename dbc directory)) | |
131 | (db (or (semanticdb-file-loaded-p fn) | |
132 | (if (file-exists-p fn) | |
133 | (progn | |
134 | (semanticdb-load-database fn)))))) | |
135 | (unless db | |
136 | (setq db (make-instance | |
137 | dbc ; Create the database requested. Perhaps | |
138 | (concat (file-name-nondirectory | |
139 | (directory-file-name | |
140 | directory)) | |
141 | "/") | |
142 | :file fn :tables nil | |
143 | :semantic-tag-version semantic-version | |
144 | :semanticdb-version semanticdb-file-version))) | |
145 | ;; Set this up here. We can't put it in the constructor because it | |
146 | ;; would be saved, and we want DB files to be portable. | |
147 | (oset db reference-directory directory) | |
148 | db)) | |
149 | ||
150 | ;;; File IO | |
691a065e CY |
151 | |
152 | (declare-function inversion-test "inversion") | |
153 | ||
f273dfc6 CY |
154 | (defun semanticdb-load-database (filename) |
155 | "Load the database FILENAME." | |
f273dfc6 CY |
156 | (condition-case foo |
157 | (let* ((r (eieio-persistent-read filename)) | |
158 | (c (semanticdb-get-database-tables r)) | |
159 | (tv (oref r semantic-tag-version)) | |
160 | (fv (oref r semanticdb-version)) | |
161 | ) | |
162 | ;; Restore the parent-db connection | |
163 | (while c | |
164 | (oset (car c) parent-db r) | |
165 | (setq c (cdr c))) | |
691a065e CY |
166 | (unless (and (equal semanticdb-file-version fv) |
167 | (equal semantic-tag-version tv)) | |
168 | ;; Try not to load inversion unless we need it: | |
169 | (require 'inversion) | |
170 | (if (not (inversion-test 'semanticdb-file fv)) | |
171 | (when (inversion-test 'semantic-tag tv) | |
172 | ;; Incompatible version. Flush tables. | |
173 | (semanticdb-flush-database-tables r) | |
174 | ;; Reset the version to new version. | |
175 | (oset r semantic-tag-version semantic-tag-version) | |
176 | ;; Warn user | |
177 | (message "Semanticdb file is old. Starting over for %s" | |
178 | filename)) | |
179 | ;; Version is not ok. Flush whole system | |
180 | (message "semanticdb file is old. Starting over for %s" | |
181 | filename) | |
182 | ;; This database is so old, we need to replace it. | |
183 | ;; We also need to delete it from the instance tracker. | |
184 | (delete-instance r) | |
185 | (setq r nil))) | |
f273dfc6 CY |
186 | r) |
187 | (error (message "Cache Error: [%s] %s, Restart" | |
188 | filename foo) | |
189 | nil))) | |
190 | ||
191 | (defun semanticdb-file-loaded-p (filename) | |
192 | "Return the project belonging to FILENAME if it was already loaded." | |
193 | (eieio-instance-tracker-find filename 'file 'semanticdb-database-list)) | |
194 | ||
195 | (defmethod semanticdb-file-directory-exists-p ((DB semanticdb-project-database-file) | |
196 | &optional supress-questions) | |
197 | "Does the directory the database DB needs to write to exist? | |
198 | If SUPRESS-QUESTIONS, then do not ask to create the directory." | |
199 | (let ((dest (file-name-directory (oref DB file))) | |
200 | ) | |
201 | (cond ((null dest) | |
202 | ;; @TODO - If it was never set up... what should we do ? | |
203 | nil) | |
204 | ((file-exists-p dest) t) | |
5bebb332 CY |
205 | ((or supress-questions |
206 | (and (boundp 'semanticdb--inhibit-make-directory) | |
207 | semanticdb--inhibit-make-directory)) | |
208 | nil) | |
209 | ((y-or-n-p (format "Create directory %s for SemanticDB? " dest)) | |
f273dfc6 CY |
210 | (make-directory dest t) |
211 | t) | |
29e1a603 CY |
212 | (t |
213 | (if (boundp 'semanticdb--inhibit-make-directory) | |
214 | (setq semanticdb--inhibit-make-directory t)) | |
215 | nil)))) | |
f273dfc6 CY |
216 | |
217 | (defmethod semanticdb-save-db ((DB semanticdb-project-database-file) | |
218 | &optional | |
219 | supress-questions) | |
220 | "Write out the database DB to its file. | |
221 | If DB is not specified, then use the current database." | |
222 | (let ((objname (oref DB file))) | |
223 | (when (and (semanticdb-dirty-p DB) | |
224 | (semanticdb-live-p DB) | |
225 | (semanticdb-file-directory-exists-p DB supress-questions) | |
226 | (semanticdb-write-directory-p DB) | |
227 | ) | |
228 | ;;(message "Saving tag summary for %s..." objname) | |
229 | (condition-case foo | |
230 | (eieio-persistent-save (or DB semanticdb-current-database)) | |
231 | (file-error ; System error saving? Ignore it. | |
232 | (message "%S: %s" foo objname)) | |
233 | (error | |
234 | (cond | |
235 | ((and (listp foo) | |
236 | (stringp (nth 1 foo)) | |
237 | (string-match "write[- ]protected" (nth 1 foo))) | |
238 | (message (nth 1 foo))) | |
239 | ((and (listp foo) | |
240 | (stringp (nth 1 foo)) | |
241 | (string-match "no such directory" (nth 1 foo))) | |
242 | (message (nth 1 foo))) | |
243 | (t | |
244 | ;; @todo - It should ask if we are not called from a hook. | |
245 | ;; How? | |
246 | (if (or supress-questions | |
dd9af436 | 247 | (y-or-n-p (format "Skip Error: %s ?" (car (cdr foo))))) |
f273dfc6 CY |
248 | (message "Save Error: %S: %s" (car (cdr foo)) |
249 | objname) | |
250 | (error "%S" (car (cdr foo)))))))) | |
251 | (run-hook-with-args 'semanticdb-save-database-hooks | |
252 | (or DB semanticdb-current-database)) | |
253 | ;;(message "Saving tag summary for %s...done" objname) | |
254 | ) | |
255 | )) | |
256 | ||
257 | (defmethod semanticdb-live-p ((obj semanticdb-project-database)) | |
258 | "Return non-nil if the file associated with OBJ is live. | |
259 | Live databases are objects associated with existing directories." | |
260 | (and (slot-boundp obj 'reference-directory) | |
261 | (file-exists-p (oref obj reference-directory)))) | |
262 | ||
263 | (defmethod semanticdb-live-p ((obj semanticdb-table)) | |
264 | "Return non-nil if the file associated with OBJ is live. | |
265 | Live files are either buffers in Emacs, or files existing on the filesystem." | |
266 | (let ((full-filename (semanticdb-full-filename obj))) | |
267 | (or (find-buffer-visiting full-filename) | |
268 | (file-exists-p full-filename)))) | |
269 | ||
270 | (defvar semanticdb-data-debug-on-write-error nil | |
271 | "Run the data debugger on tables that issue errors. | |
272 | This variable is set to nil after the first error is encountered | |
273 | to prevent overload.") | |
274 | ||
691a065e CY |
275 | (declare-function data-debug-insert-thing "data-debug") |
276 | ||
f273dfc6 CY |
277 | (defmethod object-write ((obj semanticdb-table)) |
278 | "When writing a table, we have to make sure we deoverlay it first. | |
604f7ca6 | 279 | Restore the overlays after writing. |
f273dfc6 CY |
280 | Argument OBJ is the object to write." |
281 | (when (semanticdb-live-p obj) | |
282 | (when (semanticdb-in-buffer-p obj) | |
0816d744 | 283 | (with-current-buffer (semanticdb-in-buffer-p obj) |
f273dfc6 CY |
284 | |
285 | ;; Make sure all our tag lists are up to date. | |
286 | (semantic-fetch-tags) | |
287 | ||
288 | ;; Try to get an accurate unmatched syntax table. | |
289 | (when (and (boundp semantic-show-unmatched-syntax-mode) | |
290 | semantic-show-unmatched-syntax-mode) | |
291 | ;; Only do this if the user runs unmatched syntax | |
292 | ;; mode display enties. | |
293 | (oset obj unmatched-syntax | |
294 | (semantic-show-unmatched-lex-tokens-fetch)) | |
295 | ) | |
296 | ||
297 | ;; Make sure pointmax is up to date | |
298 | (oset obj pointmax (point-max)) | |
299 | )) | |
300 | ||
301 | ;; Make sure that the file size and other attributes are | |
302 | ;; up to date. | |
303 | (let ((fattr (file-attributes (semanticdb-full-filename obj)))) | |
304 | (oset obj fsize (nth 7 fattr)) | |
305 | (oset obj lastmodtime (nth 5 fattr)) | |
306 | ) | |
307 | ||
308 | ;; Do it! | |
309 | (condition-case tableerror | |
310 | (call-next-method) | |
311 | (error | |
312 | (when semanticdb-data-debug-on-write-error | |
313 | (require 'data-debug) | |
314 | (data-debug-new-buffer (concat "*SEMANTICDB ERROR*")) | |
315 | (data-debug-insert-thing obj "*" "") | |
316 | (setq semanticdb-data-debug-on-write-error nil)) | |
317 | (message "Error Writing Table: %s" (object-name obj)) | |
318 | (error "%S" (car (cdr tableerror))))) | |
319 | ||
320 | ;; Clear the dirty bit. | |
321 | (oset obj dirty nil) | |
322 | )) | |
323 | ||
324 | ;;; State queries | |
325 | ;; | |
326 | (defmethod semanticdb-write-directory-p ((obj semanticdb-project-database-file)) | |
327 | "Return non-nil if OBJ should be written to disk. | |
328 | Uses `semanticdb-persistent-path' to determine the return value." | |
329 | (let ((path semanticdb-persistent-path)) | |
330 | (catch 'found | |
331 | (while path | |
332 | (cond ((stringp (car path)) | |
333 | (if (string= (oref obj reference-directory) (car path)) | |
334 | (throw 'found t))) | |
335 | ((eq (car path) 'project) | |
336 | ;; @TODO - EDE causes us to go in here and disable | |
337 | ;; the old default 'always save' setting. | |
338 | ;; | |
339 | ;; With new default 'always' should I care? | |
340 | (if semanticdb-project-predicate-functions | |
341 | (if (run-hook-with-args-until-success | |
342 | 'semanticdb-project-predicate-functions | |
343 | (oref obj reference-directory)) | |
344 | (throw 'found t)) | |
345 | ;; If the mode is 'project, and there are no project | |
346 | ;; modes, then just always save the file. If users | |
347 | ;; wish to restrict the search, modify | |
348 | ;; `semanticdb-persistent-path' to include desired paths. | |
349 | (if (= (length semanticdb-persistent-path) 1) | |
350 | (throw 'found t)) | |
351 | )) | |
352 | ((eq (car path) 'never) | |
353 | (throw 'found nil)) | |
354 | ((eq (car path) 'always) | |
355 | (throw 'found t)) | |
356 | (t (error "Invalid path %S" (car path)))) | |
357 | (setq path (cdr path))) | |
358 | (call-next-method)) | |
359 | )) | |
360 | ||
361 | ;;; Filename manipulation | |
362 | ;; | |
363 | (defmethod semanticdb-file-table ((obj semanticdb-project-database-file) filename) | |
364 | "From OBJ, return FILENAME's associated table object." | |
365 | ;; Cheater option. In this case, we always have files directly | |
366 | ;; under ourselves. The main project type may not. | |
367 | (object-assoc (file-name-nondirectory filename) 'file (oref obj tables))) | |
368 | ||
369 | (defmethod semanticdb-file-name-non-directory :STATIC | |
370 | ((dbclass semanticdb-project-database-file)) | |
371 | "Return the file name DBCLASS will use. | |
372 | File name excludes any directory part." | |
373 | semanticdb-default-file-name) | |
374 | ||
375 | (defmethod semanticdb-file-name-directory :STATIC | |
376 | ((dbclass semanticdb-project-database-file) directory) | |
377 | "Return the relative directory to where DBCLASS will save its cache file. | |
378 | The returned path is related to DIRECTORY." | |
379 | (if semanticdb-default-save-directory | |
380 | (let ((file (cedet-directory-name-to-file-name directory))) | |
381 | ;; Now create a filename for the cache file in | |
382 | ;; ;`semanticdb-default-save-directory'. | |
383 | (expand-file-name | |
384 | file (file-name-as-directory semanticdb-default-save-directory))) | |
385 | directory)) | |
386 | ||
387 | (defmethod semanticdb-cache-filename :STATIC | |
388 | ((dbclass semanticdb-project-database-file) path) | |
389 | "For DBCLASS, return a file to a cache file belonging to PATH. | |
390 | This could be a cache file in the current directory, or an encoded file | |
391 | name in a secondary directory." | |
392 | ;; Use concat and not expand-file-name, because the dir part | |
393 | ;; may include some of the file name. | |
394 | (concat (semanticdb-file-name-directory dbclass path) | |
395 | (semanticdb-file-name-non-directory dbclass))) | |
396 | ||
397 | (defmethod semanticdb-full-filename ((obj semanticdb-project-database-file)) | |
398 | "Fetch the full filename that OBJ refers to." | |
399 | (oref obj file)) | |
400 | ||
401 | ;;; FLUSH OLD FILES | |
402 | ;; | |
403 | (defun semanticdb-cleanup-cache-files (&optional noerror) | |
404 | "Cleanup any cache files associated with directories that no longer exist. | |
405 | Optional NOERROR prevents errors from being displayed." | |
406 | (interactive) | |
407 | (when (and (not semanticdb-default-save-directory) | |
408 | (not noerror)) | |
409 | (error "No default save directory for semantic-save files")) | |
410 | ||
411 | (when semanticdb-default-save-directory | |
412 | ||
413 | ;; Calculate all the cache files we have. | |
414 | (let* ((regexp (regexp-quote semanticdb-default-file-name)) | |
415 | (files (directory-files semanticdb-default-save-directory | |
416 | t regexp)) | |
417 | (orig nil) | |
418 | (to-delete nil)) | |
419 | (dolist (F files) | |
420 | (setq orig (cedet-file-name-to-directory-name | |
421 | (file-name-nondirectory F))) | |
422 | (when (not (file-exists-p (file-name-directory orig))) | |
423 | (setq to-delete (cons F to-delete)) | |
424 | )) | |
425 | (if to-delete | |
426 | (save-window-excursion | |
427 | (let ((buff (get-buffer-create "*Semanticdb Delete*"))) | |
428 | (with-current-buffer buff | |
429 | (erase-buffer) | |
430 | (insert "The following Cache files appear to be obsolete.\n\n") | |
431 | (dolist (F to-delete) | |
432 | (insert F "\n"))) | |
433 | (pop-to-buffer buff t t) | |
434 | (fit-window-to-buffer (get-buffer-window buff) nil 1) | |
435 | (when (y-or-n-p "Delete Old Cache Files? ") | |
436 | (mapc (lambda (F) | |
437 | (message "Deleting to %s..." F) | |
438 | (delete-file F)) | |
439 | to-delete) | |
440 | (message "done.")) | |
441 | )) | |
442 | ;; No files to delete | |
443 | (when (not noerror) | |
444 | (message "No obsolete semanticdb.cache files.")) | |
445 | )))) | |
446 | ||
447 | (provide 'semantic/db-file) | |
448 | ||
dac49f4e CY |
449 | ;; Local variables: |
450 | ;; generated-autoload-file: "loaddefs.el" | |
dac49f4e CY |
451 | ;; generated-autoload-load-name: "semantic/db-file" |
452 | ;; End: | |
453 | ||
691a065e | 454 | ;;; semantic/db-file.el ends here |