1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
6 ;;;; CLSQL metaclass for standard-db-objects created in the OODDL.
8 ;;;; This file is part of CLSQL.
10 ;;;; CLSQL users are granted the rights to distribute and use this software
11 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
12 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
13 ;;;; *************************************************************************
15 (in-package #:clsql-sys)
17 (eval-when (:compile-toplevel :load-toplevel :execute)
18 (when (>= (length (generic-function-lambda-list
19 (ensure-generic-function
20 'compute-effective-slot-definition)))
22 (pushnew :kmr-normal-cesd cl:*features*))
24 (when (>= (length (generic-function-lambda-list
25 (ensure-generic-function
26 'direct-slot-definition-class)))
28 (pushnew :kmr-normal-dsdc cl:*features*))
30 (when (>= (length (generic-function-lambda-list
31 (ensure-generic-function
32 'effective-slot-definition-class)))
34 (pushnew :kmr-normal-esdc cl:*features*)))
37 ;; ------------------------------------------------------------
38 ;; metaclass: view-class
40 (defclass standard-db-class (standard-class)
45 :accessor object-definition
52 :accessor view-class-qualifier
55 (:documentation "VIEW-CLASS metaclass."))
58 (defmacro push-on-end (value location)
59 `(setf ,location (nconc ,location (list ,value))))
61 ;; As Heiko Kirscke (author of PLOB!) would say: !@##^@%! Lispworks!
63 (defconstant +extra-slot-options+ '(:column :db-kind :db-reader :nulls-ok
64 :db-writer :db-type :db-info))
67 (define-setf-expander assoc (key alist &environment env)
68 (multiple-value-bind (temps vals stores store-form access-form)
69 (get-setf-expansion alist env)
70 (let ((new-value (gensym "NEW-VALUE-"))
71 (keyed (gensym "KEYED-"))
72 (accessed (gensym "ACCESSED-"))
73 (store-new-value (car stores)))
74 (values (cons keyed temps)
77 `(let* ((,accessed ,access-form)
78 (,store-new-value (assoc ,keyed ,accessed)))
80 (rplacd ,store-new-value ,new-value)
82 (setq ,store-new-value
83 (acons ,keyed ,new-value ,accessed))
86 `(assoc ,new-value ,access-form)))))
89 (defmethod clos::canonicalize-defclass-slot :around
90 ((prototype standard-db-class) slot)
91 "\\lw\\ signals an error on unknown slot options; so this method
92 removes any extra allowed options before calling the default method
93 and returns the canonicalized extra options concatenated to the result
94 of the default method. The extra allowed options are the value of the
95 \\fcite{+extra-slot-options+}."
96 (let ((extra-slot-options ())
99 (do ((olist (cdr slot) (cddr olist)))
101 (let ((option (car olist)))
103 ((find option +extra-slot-options+)
104 ;;(push (cons option (cadr olist)) extra-slot-options))
105 (setf (assoc option extra-slot-options) (cadr olist)))
107 (push (cadr olist) rest-options)
108 (push (car olist) rest-options)))))
109 (setf result (call-next-method prototype (cons (car slot) rest-options)))
110 (dolist (option extra-slot-options)
111 (push-on-end (car option) result)
112 (push-on-end `(quote ,(cdr option)) result))
116 (defconstant +extra-class-options+ '(:base-table))
119 (defmethod clos::canonicalize-class-options :around
120 ((prototype standard-db-class) class-options)
121 "\\lw\\ signals an error on unknown class options; so this method
122 removes any extra allowed options before calling the default method
123 and returns the canonicalized extra options concatenated to the result
124 of the default method. The extra allowed options are the value of the
125 \\fcite{+extra-class-options+}."
126 (let ((extra-class-options nil)
129 (dolist (o class-options)
130 (let ((option (car o)))
132 ((find option +extra-class-options+)
133 ;;(push (cons option (cadr o)) extra-class-options))
134 (setf (assoc option extra-class-options) (cadr o)))
136 (push o rest-options)))))
137 (setf result (call-next-method prototype rest-options))
138 (dolist (option extra-class-options)
139 (push-on-end (car option) result)
140 (push-on-end `(quote ,(cdr option)) result))
144 (defmethod validate-superclass ((class standard-db-class)
145 (superclass standard-class))
148 (defun table-name-from-arg (arg)
151 ((typep arg 'sql-ident)
152 (slot-value arg 'name))
154 (intern (string-upcase arg)))))
156 (defun column-name-from-arg (arg)
159 ((typep arg 'sql-ident)
160 (slot-value arg 'name))
162 (intern (string-upcase arg)))))
165 (defun remove-keyword-arg (arglist akey)
166 (let ((mylist arglist)
168 (labels ((pop-arg (alist)
169 (let ((arg (pop alist))
171 (unless (equal arg akey)
172 (setf newlist (append (list arg val) newlist)))
173 (when alist (pop-arg alist)))))
177 (defmethod initialize-instance :around ((class standard-db-class)
179 &key direct-superclasses base-table
182 (let ((root-class (find-class 'standard-db-object nil))
183 (vmc (find-class 'standard-db-class)))
184 (setf (view-class-qualifier class)
187 (if (member-if #'(lambda (super)
188 (eq (class-of super) vmc)) direct-superclasses)
190 (apply #'call-next-method
192 :direct-superclasses (append (list root-class)
194 (remove-keyword-arg all-keys :direct-superclasses)))
196 (setf (view-table class)
197 (table-name-from-arg (sql-escape (or (and base-table
198 (if (listp base-table)
201 (class-name class)))))
202 (register-metaclass class (nth (1+ (position :direct-slots all-keys))
205 (defmethod reinitialize-instance :around ((class standard-db-class)
208 direct-superclasses qualifier
210 (let ((root-class (find-class 'standard-db-object nil))
211 (vmc (find-class 'standard-db-class)))
212 (setf (view-table class)
213 (table-name-from-arg (sql-escape (or (and base-table
214 (if (listp base-table)
217 (class-name class)))))
218 (setf (view-class-qualifier class)
220 (if (and root-class (not (equal class root-class)))
221 (if (member-if #'(lambda (super)
222 (eq (class-of super) vmc)) direct-superclasses)
224 (apply #'call-next-method
226 :direct-superclasses (append (list root-class)
228 (remove-keyword-arg all-keys :direct-superclasses)))
230 (register-metaclass class (nth (1+ (position :direct-slots all-keys))
234 (defun get-keywords (keys list)
235 (flet ((extract (key)
236 (let ((pos (position key list)))
238 (nth (1+ pos) list)))))
239 (mapcar #'extract keys)))
241 (defun describe-db-layout (class)
242 (flet ((not-db-col (col)
243 (not (member (nth 2 col) '(nil :base :key))))
245 (let ((type (slot-value slot 'type)))
248 (list (slot-value slot 'name)
250 (slot-value slot 'db-kind)
251 (and (slot-boundp slot 'column)
252 (slot-value slot 'column))))))
253 (let ((all-slots (mapcar #'frob-slot (ordered-class-slots class))))
254 (setq all-slots (remove-if #'not-db-col all-slots))
255 (setq all-slots (stable-sort all-slots #'string< :key #'car))
256 ;;(mapcar #'dink-type all-slots)
259 (defun register-metaclass (class slots)
260 (labels ((not-db-col (col)
261 (not (member (nth 2 col) '(nil :base :key))))
263 (get-keywords '(:name :type :db-kind :column) slot)))
264 (let ((all-slots (mapcar #'frob-slot slots)))
265 (setq all-slots (remove-if #'not-db-col all-slots))
266 (setq all-slots (stable-sort all-slots #'string< :key #'car))
267 (setf (object-definition class) all-slots))
268 #-(or allegro openmcl)
269 (setf (key-slots class) (remove-if-not (lambda (slot)
270 (eql (slot-value slot 'db-kind)
272 (ordered-class-slots class)))))
274 #+(or allegro openmcl)
275 (defmethod finalize-inheritance :after ((class standard-db-class))
276 ;; KMRL for slots without a type set, openmcl sets type-predicate to ccl:false
277 ;; for standard-db-class
281 (if (eq 'ccl:false (slot-value s 'ccl::type-predicate))
282 (setf (slot-value s 'ccl::type-predicate) 'ccl:true)))
285 (setf (key-slots class) (remove-if-not (lambda (slot)
286 (eql (slot-value slot 'db-kind)
288 (ordered-class-slots class))))
290 ;; return the deepest view-class ancestor for a given view class
292 (defun base-db-class (classname)
293 (let* ((class (find-class classname))
294 (db-class (find-class 'standard-db-object)))
296 (let ((cds (class-direct-superclasses class)))
298 (error "not a db class"))
299 ((member db-class cds)
300 (return (class-name class))))
301 (setq class (car cds))))))
303 (defun db-ancestors (classname)
304 (let ((class (find-class classname))
305 (db-class (find-class 'standard-db-object)))
306 (labels ((ancestors (class)
307 (let ((scs (class-direct-superclasses class)))
308 (if (member db-class scs)
310 (append (list class) (mapcar #'ancestors scs))))))
313 (defclass view-class-slot-definition-mixin ()
315 :accessor view-class-slot-column
318 "The name of the SQL column this slot is stored in. Defaults to
321 :accessor view-class-slot-db-kind
326 "The kind of DB mapping which is performed for this slot. :base
327 indicates the slot maps to an ordinary column of the DB view. :key
328 indicates that this slot corresponds to part of the unique keys for
329 this view, :join indicates ... and :virtual indicates that this slot
330 is an ordinary CLOS slot. Defaults to :base.")
332 :accessor view-class-slot-db-reader
336 "If a string, then when reading values from the DB, the string
337 will be used for a format string, with the only value being the value
338 from the database. The resulting string will be used as the slot
339 value. If a function then it will take one argument, the value from
340 the database, and return the value that should be put into the slot.")
342 :accessor view-class-slot-db-writer
346 "If a string, then when reading values from the slot for the DB,
347 the string will be used for a format string, with the only value being
348 the value of the slot. The resulting string will be used as the
349 column value in the DB. If a function then it will take one argument,
350 the value of the slot, and return the value that should be put into
353 :accessor view-class-slot-db-type
357 "A string which will be used as the type specifier for this slots
358 column definition in the database.")
360 :accessor view-class-slot-db-constraints
361 :initarg :db-constraints
364 "A single constraint or list of constraints for this column")
366 :accessor view-class-slot-nulls-ok
370 "If t, all sql NULL values retrieved from the database become nil; if nil,
371 all NULL values retrieved are converted by DATABASE-NULL-VALUE")
373 :accessor view-class-slot-db-info
375 :documentation "Description of the join.")
377 :accessor specified-type
379 :documentation "KMR: Internal slot storing the :type specified by user.")))
381 (defparameter *db-info-lambda-list*
387 (retrieval :immmediate)
390 (defun parse-db-info (db-info-list)
392 (&key join-class home-key key-join foreign-key (delete-rule nil)
393 (target-slot nil) (retrieval :deferred) (set nil))
395 (let ((ih (make-hash-table :size 6)))
397 (setf (gethash :join-class ih) join-class)
398 (error "Must specify :join-class in :db-info"))
400 (setf (gethash :home-key ih) home-key)
401 (error "Must specify :home-key in :db-info"))
403 (setf (gethash :delete-rule ih) delete-rule))
405 (setf (gethash :foreign-key ih) foreign-key)
406 (error "Must specify :foreign-key in :db-info"))
408 (setf (gethash :key-join ih) t))
410 (setf (gethash :target-slot ih) target-slot))
412 (setf (gethash :set ih) set))
415 (setf (gethash :retrieval ih) retrieval)
416 (if (eql retrieval :immediate)
417 (setf (gethash :set ih) nil))))
420 (defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
421 standard-direct-slot-definition)
424 (defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
425 standard-effective-slot-definition)
428 (defmethod direct-slot-definition-class ((class standard-db-class)
429 #+kmr-normal-dsdc &rest
431 (declare (ignore initargs))
432 (find-class 'view-class-direct-slot-definition))
434 (defmethod effective-slot-definition-class ((class standard-db-class)
435 #+kmr-normal-esdc &rest
437 (declare (ignore initargs))
438 (find-class 'view-class-effective-slot-definition))
441 (defun compute-class-precedence-list (class)
442 ;; safe to call this in openmcl
443 (class-precedence-list class))
446 (defmethod compute-slots ((class standard-db-class))
447 "Need to sort order of class slots so they are the same across
449 (let ((slots (call-next-method))
452 (dolist (c (compute-class-precedence-list class))
453 (dolist (s (class-direct-slots c))
454 (let ((name (slot-definition-name s)))
455 (unless (find name desired-sequence)
456 (push name desired-sequence)))))
457 (dolist (desired desired-sequence)
458 (let ((slot (find desired slots :key #'slot-definition-name)))
460 (push slot output-slots)))
463 (defun compute-lisp-type-from-slot-specification (slotd specified-type)
464 "Computes the Lisp type for a user-specified type. Needed for OpenMCL
465 which does type checking before storing a value in a slot."
466 #-openmcl (declare (ignore slotd))
467 ;; This function is called after the base compute-effective-slots is called.
468 ;; OpenMCL sets the type-predicate based on the initial value of the slots type.
469 ;; so we have to override the type-predicates here
471 ((consp specified-type)
473 ((and (symbolp (car specified-type))
474 (string-equal (symbol-name (car specified-type)) "string"))
475 #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'stringp)
478 #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
481 ((null specified-type)
482 ;; setting this here is not enough since openmcl later sets the
483 ;; type-predicate to ccl:false. So, have to check slots again
484 ;; in finalize-inheritance
485 #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
488 ;; This can be improved for OpenMCL to set a more specific type
489 ;; predicate based on the value specified-type
490 #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
493 ;; Compute the slot definition for slots in a view-class. Figures out
494 ;; what kind of database value (if any) is stored there, generates and
495 ;; verifies the column name.
497 (defmethod compute-effective-slot-definition ((class standard-db-class)
498 #+kmr-normal-cesd slot-name
500 #+kmr-normal-cesd (declare (ignore slot-name))
502 (let ((slotd (call-next-method))
503 (sd (car direct-slots)))
506 (view-class-slot-definition-mixin
507 ;; Use the specified :column argument if it is supplied, otherwise
508 ;; the column slot is filled in with the slot-name, but transformed
509 ;; to be sql safe, - to _ and such.
510 (setf (slot-value slotd 'column)
511 (column-name-from-arg
512 (if (slot-boundp sd 'column)
513 (view-class-slot-column sd)
514 (column-name-from-arg
515 (sql-escape (slot-definition-name sd))))))
517 (setf (slot-value slotd 'db-type)
518 (when (slot-boundp sd 'db-type)
519 (view-class-slot-db-type sd)))
521 (setf (slot-value slotd 'nulls-ok)
522 (view-class-slot-nulls-ok sd))
524 ;; :db-kind slot value defaults to :base (store slot value in
527 (setf (slot-value slotd 'db-kind)
528 (if (slot-boundp sd 'db-kind)
529 (view-class-slot-db-kind sd)
532 (setf (slot-value slotd 'db-writer)
533 (when (slot-boundp sd 'db-writer)
534 (view-class-slot-db-writer sd)))
535 (setf (slot-value slotd 'db-constraints)
536 (when (slot-boundp sd 'db-constraints)
537 (view-class-slot-db-constraints sd)))
539 ;; I wonder if this slot option and the previous could be merged,
540 ;; so that :base and :key remain keyword options, but :db-kind
541 ;; :join becomes :db-kind (:join <db info .... >)?
543 (setf (slot-value slotd 'db-info)
544 (when (slot-boundp sd 'db-info)
545 (if (listp (view-class-slot-db-info sd))
546 (parse-db-info (view-class-slot-db-info sd))
547 (view-class-slot-db-info sd))))
549 ;; KMR: store the user-specified type and then compute
550 ;; real Lisp type and store it
551 (setf (specified-type slotd)
552 (slot-definition-type slotd))
553 (setf (slot-value slotd 'type)
554 (compute-lisp-type-from-slot-specification
555 slotd (slot-definition-type slotd)))
559 (change-class slotd 'view-class-effective-slot-definition
561 #+allegro (slot-definition-name sd))
562 (setf (slot-value slotd 'column)
563 (column-name-from-arg
564 (sql-escape (slot-definition-name sd))))
566 (setf (slot-value slotd 'db-info) nil)
567 (setf (slot-value slotd 'db-kind)
571 (defun slotdefs-for-slots-with-class (slots class)
574 (let ((c (slotdef-for-slot-with-class s class)))
575 (if c (setf result (cons c result)))))
578 (defun slotdef-for-slot-with-class (slot class)
579 (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
580 (class-slots class)))
583 (eval-when (:compile-toplevel :load-toplevel :execute)
585 (setq cl:*features* (delete :kmr-normal-cesd cl:*features*))
587 (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*))
589 (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))