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