/[rucksack]/rucksack/schema-table.lisp
ViewVC logotype

Contents of /rucksack/schema-table.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Sat Jan 20 18:17:55 2007 UTC (7 years, 2 months ago) by alemmens
Branch: MAIN
CVS Tags: HEAD
Changes since 1.6: +215 -215 lines
Version 0.1.5: removed ^M line terminators from all source files
(thanks to Attila Lendvai).
1 ;; $Id: schema-table.lisp,v 1.7 2007/01/20 18:17:55 alemmens Exp $
2
3 (in-package :rucksack)
4
5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 ;;; Schema table
7 ;;;
8 ;;; The schema table keeps track of all classes that have instances that
9 ;;; were saved by the cache.
10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11
12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13 ;;; Schema
14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
15
16 (defclass schema ()
17 ((id :initarg :id :reader schema-id
18 :documentation "A unique number that identifies a schema.")
19 (class-name :initarg :class-name :reader schema-class-name)
20 (version :initarg :version :initform 0 :reader schema-version
21 :documentation "The combination of class-name and version number
22 also uniquely identifies a schema.")
23 (obsolete-p :initform nil :accessor schema-obsolete-p)
24 ;; Slot info (computed during FINALIZE-INHERITANCE).
25 (added-slot-names :initform '()
26 :accessor added-slot-names
27 :documentation "A list with the names of all
28 persistent slots that were added by the most recent version (compared
29 to this version).")
30 (discarded-slot-names :initform '()
31 :accessor discarded-slot-names
32 :documentation "A list with the names of all
33 persistent slots that were discarded by the most recent version
34 (compared to this version).")
35 (persistent-slot-names :initarg :persistent-slot-names
36 :accessor persistent-slot-names
37 :documentation "A list with the names of all
38 persistent effective slots.")))
39
40 (defmethod nr-persistent-slots ((schema schema))
41 (length (persistent-slot-names schema)))
42
43 (defmethod print-object ((schema schema) stream)
44 (print-unreadable-object (schema stream :type t :identity t)
45 (format stream "~A ~D.~D with ~D slots"
46 (schema-class-name schema)
47 (schema-id schema)
48 (schema-version schema)
49 (nr-persistent-slots schema))))
50
51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52 ;; Schema table
53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
54
55 (defclass schema-table ()
56 ((pathname :initarg :pathname :accessor schema-table-pathname)
57 (by-name :initform (make-hash-table)
58 :documentation "A mapping from class names to a list (most
59 recent version first) of schemas."
60 :reader schema-table-by-name)
61 (by-id :initform (make-hash-table)
62 :documentation "A mapping from a schema id to a schema."
63 :accessor schema-table-by-id)
64 (highest-schema-id :initform 0 :accessor highest-schema-id)
65 (dirty-p :initform nil :accessor dirty-p
66 :documentation "When dirty, the schema table will be saved
67 at the next commit.")))
68
69 ;;
70 ;; Serializing schema table
71 ;;
72
73 (defmethod saved-slots ((table schema-table))
74 ;; Don't serialize the BY-ID hash table, but rebuild it by hand after the
75 ;; other slots are deserialized. This is necessary because schemas are
76 ;; referenced more than once, and the serializer doesn't handle shared
77 ;; objects (unless they're 'real' persistent objects).
78 '(pathname by-name highest-schema-id))
79
80 (defmethod load-slots :after ((table schema-table) serializer)
81 ;; Reconstruct the BY-ID hash table. This method is called by the
82 ;; serializer after an object is deserialized.
83 (setf (schema-table-by-id table) (make-hash-table))
84 (loop for schemas being the hash-value of (schema-table-by-name table)
85 do (loop for schema in schemas
86 do (setf (gethash (schema-id schema)
87 (schema-table-by-id table))
88 schema)))
89 ;;
90 (setf (dirty-p table) nil)
91 table)
92
93 ;;
94 ;; Finding schemas
95 ;;
96
97 (defmethod fresh-schema-id ((table schema-table))
98 (prog1 (highest-schema-id table)
99 (incf (highest-schema-id table))))
100
101 (defmethod find-schema-for-id ((table schema-table) id &key (errorp t))
102 (or (gethash id (schema-table-by-id table))
103 (and errorp
104 (error "Can't find schema with id ~D in ~S." id table))))
105
106 (defmethod find-schema-for-class ((table schema-table) class)
107 ;; Returns the most recent schema for a class
108 ;; (or NIL if there is no schema for the class).
109 (first (gethash (class-name class) (schema-table-by-name table))))
110
111 (defmethod old-schemas-for-class ((table schema-table) class)
112 (rest (gethash (class-name class) (schema-table-by-name table))))
113
114 (defmethod find-or-create-schema-for-object ((table schema-table) object)
115 ;; NOTE: This assumes that the class hasn't changed without the
116 ;; schema table knowing about it. We probably must assume that,
117 ;; otherwise we'd have a very expensive check whenever we want to
118 ;; save an object.
119 (let ((class (class-of object)))
120 (or (find-schema-for-class table class)
121 ;; There is no schema yet. Create it.
122 (let ((persistent-slots (compute-persistent-slot-names class object)))
123 (create-schema table class 0 persistent-slots)))))
124
125
126 (defmethod create-schema ((table schema-table) class version
127 &optional (persistent-slots '()))
128 (let ((schema (make-instance 'schema
129 :id (fresh-schema-id table)
130 :class-name (class-name class)
131 :version version
132 :persistent-slot-names persistent-slots)))
133 (add-schema table schema)
134 schema))
135
136
137 (defmethod compute-persistent-slot-names ((class persistent-class) object)
138 (declare (ignore object))
139 (mapcar #'slot-definition-name (class-persistent-slots class)))
140
141
142 (defmethod add-schema ((table schema-table) (schema schema))
143 (setf (gethash (schema-id schema) (schema-table-by-id table))
144 schema)
145 (push schema
146 (gethash (schema-class-name schema) (schema-table-by-name table) '()))
147 (setf (dirty-p table) t))
148
149
150 (defmethod save-schema-table ((table schema-table))
151 ;; Clear dirty flag first, because it's saved (and loaded) too.
152 (setf (dirty-p table) nil)
153 (save-objects (list table) (schema-table-pathname table)))
154
155 (defmethod save-schema-table-if-necessary ((table schema-table))
156 (when (dirty-p table)
157 (save-schema-table table)))
158
159 (defun open-schema-table (pathname &key if-exists if-does-not-exist)
160 ;; Load existing schemas from the file.
161 (if (probe-file pathname)
162 (ecase if-exists
163 (:error (error "Schema table file ~S already exists." pathname))
164 (:supersede
165 ;; Create an empty schema table, save it and return it.
166 (let ((table (make-instance 'schema-table :pathname pathname)))
167 (save-schema-table table)
168 table))
169 (:overwrite
170 ;; Normal case
171 (let ((table (first (load-objects pathname))))
172 (when (not (equal pathname (schema-table-pathname table)))
173 ;; The table was moved; update the pathname info.
174 (setf (schema-table-pathname table) pathname)
175 (save-schema-table table))
176 table)))
177 (ecase if-does-not-exist
178 (:error (error "Schema table file ~S does not exist." pathname))
179 (:create
180 ;; Create an empty schema table, save it and return it.
181 (let ((table (make-instance 'schema-table :pathname pathname)))
182 (save-schema-table table)
183 table)))))
184
185
186 (defun close-schema-table (table &key (commit t))
187 (when (and commit (dirty-p table))
188 (save-schema-table table)))
189
190 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
191 ;;; Schema updates
192 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
193
194 (defmethod maybe-update-schemas ((table schema-table) class)
195 ;; Rucksack analyzes the new class definition; if it's different from the
196 ;; previous version, a new schema is added to the schema table. From that
197 ;; moment, when an instance of the redefined class is created it will be
198 ;; saved with the new schema id.
199 ;; This is called by the FINALIZE-INHERITANCE method for PERSISTENT-CLASS.
200 (let ((slots (mapcar #'slot-definition-name (class-persistent-slots class)))
201 (old-schema (find-schema-for-class table class)))
202 (if (null old-schema)
203 ;; There is no schema yet: create the first one.
204 (create-schema table class 0 slots)
205 ;; There is a schema already: create a new one if necessary.
206 (when (set-difference slots (persistent-slot-names old-schema))
207 ;; Add a new schema for this class.
208 (create-schema table class (1+ (schema-version old-schema)) slots)
209 ;; Mark all older versions as obsolete and compute their
210 ;; slot diffs w.r.t. to the new schema
211 (dolist (schema (old-schemas-for-class table class))
212 (let ((old-slots (persistent-slot-names schema)))
213 (setf (schema-obsolete-p schema) t
214 (added-slot-names schema) (set-difference slots old-slots)
215 (discarded-slot-names schema) (set-difference old-slots slots))))))))

  ViewVC Help
Powered by ViewVC 1.1.5