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