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