1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
4 ;;;; CLSQL metaclass for standard-db-objects created in the OODDL.
6 ;;;; This file is part of CLSQL.
8 ;;;; CLSQL users are granted the rights to distribute and use this software
9 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
10 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
11 ;;;; *************************************************************************
13 (in-package #:clsql-sys)
15 (eval-when (:compile-toplevel :load-toplevel :execute)
16 (when (>= (length (generic-function-lambda-list
17 (ensure-generic-function
18 'compute-effective-slot-definition)))
20 (pushnew :kmr-normal-cesd cl:*features*))
22 (when (>= (length (generic-function-lambda-list
23 (ensure-generic-function
24 'direct-slot-definition-class)))
26 (pushnew :kmr-normal-dsdc cl:*features*))
28 (when (>= (length (generic-function-lambda-list
29 (ensure-generic-function
30 'effective-slot-definition-class)))
32 (pushnew :kmr-normal-esdc cl:*features*)))
35 ;; ------------------------------------------------------------
36 ;; metaclass: view-class
38 (defclass standard-db-class (standard-class)
43 :accessor object-definition
53 :accessor view-class-qualifier
56 (:documentation "Metaclass for all CLSQL View Classes."))
58 ;;; Lispworks 4.2 and before requires special processing of extra slot and class options
60 (defvar +extra-slot-options+ '(:column :db-kind :db-type :db-reader :void-value :db-constraints
62 (defvar +extra-class-options+ '(:base-table))
65 (dolist (slot-option +extra-slot-options+)
66 (eval `(process-slot-option standard-db-class ,slot-option)))
69 (dolist (class-option +extra-class-options+)
70 (eval `(process-class-option standard-db-class ,class-option)))
72 (defmethod validate-superclass ((class standard-db-class)
73 (superclass standard-class))
76 (defun table-name-from-arg (arg)
78 (intern (sql-escape arg)))
79 ((typep arg 'sql-ident)
80 (if (symbolp (slot-value arg 'name))
81 (intern (sql-escape (slot-value arg 'name)))
82 (sql-escape (slot-value arg 'name))))
86 (defun remove-keyword-arg (arglist akey)
87 (let ((mylist arglist)
89 (labels ((pop-arg (alist)
90 (let ((arg (pop alist))
92 (unless (equal arg akey)
93 (setf newlist (append (list arg val) newlist)))
94 (when alist (pop-arg alist)))))
98 (defun set-view-table-slot (class base-table)
99 (setf (view-table class)
100 (table-name-from-arg (or (and base-table
101 (if (listp base-table)
104 (class-name class)))))
106 (defmethod initialize-instance :around ((class standard-db-class)
108 &key direct-superclasses base-table
109 qualifier normalizedp
111 (let ((root-class (find-class 'standard-db-object nil))
112 (vmc 'standard-db-class))
113 (setf (view-class-qualifier class)
116 (if (some #'(lambda (super) (typep super vmc))
119 (apply #'call-next-method
121 :direct-superclasses (append (list root-class)
123 (remove-keyword-arg all-keys :direct-superclasses)))
125 (set-view-table-slot class base-table)
126 (setf (normalizedp class) (car normalizedp))
127 (register-metaclass class (nth (1+ (position :direct-slots all-keys))
130 (defmethod reinitialize-instance :around ((class standard-db-class)
132 &key base-table normalizedp
133 direct-superclasses qualifier
135 (let ((root-class (find-class 'standard-db-object nil))
136 (vmc 'standard-db-class))
137 (set-view-table-slot class base-table)
138 (setf (normalizedp class) (car normalizedp))
139 (setf (view-class-qualifier class)
141 (if (and root-class (not (equal class root-class)))
142 (if (some #'(lambda (super) (typep super vmc))
145 (apply #'call-next-method
147 :direct-superclasses (append (list root-class)
149 (remove-keyword-arg all-keys :direct-superclasses)))
151 (register-metaclass class (nth (1+ (position :direct-slots all-keys))
155 (defun get-keywords (keys list)
156 (flet ((extract (key)
157 (let ((pos (position key list)))
159 (nth (1+ pos) list)))))
160 (mapcar #'extract keys)))
162 (defun describe-db-layout (class)
163 (flet ((not-db-col (col)
164 (not (member (nth 2 col) '(nil :base :key))))
166 (let ((type (slot-definition-type slot)))
169 (list (slot-value slot 'name)
171 (slot-value slot 'db-kind)
172 (and (slot-boundp slot 'column)
173 (slot-value slot 'column))))))
174 (let ((all-slots (mapcar #'frob-slot (ordered-class-slots class))))
175 (setq all-slots (remove-if #'not-db-col all-slots))
176 (setq all-slots (stable-sort all-slots #'string< :key #'car))
177 ;;(mapcar #'dink-type all-slots)
180 (defun register-metaclass (class slots)
181 (labels ((not-db-col (col)
182 (not (member (nth 2 col) '(nil :base :key))))
184 (get-keywords '(:name :type :db-kind :column) slot)))
185 (let ((all-slots (mapcar #'frob-slot slots)))
186 (setq all-slots (remove-if #'not-db-col all-slots))
187 (setq all-slots (stable-sort all-slots #'string< :key #'car))
188 (setf (object-definition class) all-slots))
190 (setf (key-slots class) (remove-if-not (lambda (slot)
191 (eql (slot-value slot 'db-kind)
193 (slots-for-possibly-normalized-class class)))))
196 (defmethod finalize-inheritance :after ((class standard-db-class))
197 (setf (key-slots class) (remove-if-not (lambda (slot)
198 (eql (slot-value slot 'db-kind)
200 (slots-for-possibly-normalized-class class))))
202 ;; return the deepest view-class ancestor for a given view class
204 (defun base-db-class (classname)
205 (let* ((class (find-class classname))
206 (db-class (find-class 'standard-db-object)))
208 (let ((cds (class-direct-superclasses class)))
210 (error "not a db class"))
211 ((member db-class cds)
212 (return (class-name class))))
213 (setq class (car cds))))))
215 (defun db-ancestors (classname)
216 (let ((class (find-class classname))
217 (db-class (find-class 'standard-db-object)))
218 (labels ((ancestors (class)
219 (let ((scs (class-direct-superclasses class)))
220 (if (member db-class scs)
222 (append (list class) (mapcar #'ancestors scs))))))
225 (defclass view-class-slot-definition-mixin ()
227 :accessor view-class-slot-column
230 "The name of the SQL column this slot is stored in. Defaults to
233 :accessor view-class-slot-db-kind
236 ;; openmcl 0.14.2 stores the value as list in the DSD
237 ;; :type (or list keyword)
238 #-openmcl :type #-openmcl keyword
240 "The kind of DB mapping which is performed for this slot. :base
241 indicates the slot maps to an ordinary column of the DB view. :key
242 indicates that this slot corresponds to part of the unique keys for
243 this view, :join indicates ... and :virtual indicates that this slot
244 is an ordinary CLOS slot. Defaults to :base.")
246 :accessor view-class-slot-db-reader
250 "If a string, then when reading values from the DB, the string
251 will be used for a format string, with the only value being the value
252 from the database. The resulting string will be used as the slot
253 value. If a function then it will take one argument, the value from
254 the database, and return the value that should be put into the slot.")
256 :accessor view-class-slot-db-writer
260 "If a string, then when reading values from the slot for the DB,
261 the string will be used for a format string, with the only value being
262 the value of the slot. The resulting string will be used as the
263 column value in the DB. If a function then it will take one argument,
264 the value of the slot, and return the value that should be put into
267 :accessor view-class-slot-db-type
271 "A string which will be used as the type specifier for this slots
272 column definition in the database.")
274 :accessor view-class-slot-db-constraints
275 :initarg :db-constraints
278 "A keyword symbol representing a single SQL column constraint or list of such symbols.")
280 :accessor view-class-slot-void-value
284 "Value to store if the SQL value is NULL. Default is NIL.")
286 :accessor view-class-slot-db-info
288 :documentation "Description of the join.")
290 :accessor specified-type
291 :initarg specified-type
293 :documentation "Internal slot storing the :type specified by user.")
294 (autoincrement-sequence
295 :accessor view-class-slot-autoincrement-sequence
296 :initarg :autoincrement-sequence
298 :documentation "A string naming the (possibly automatically generated) sequence
299 for a slot with an :auto-increment constraint.")))
301 (defparameter *db-info-lambda-list*
307 (retrieval :immmediate)
310 (defun parse-db-info (db-info-list)
312 (&key join-class home-key key-join foreign-key (delete-rule nil)
313 (target-slot nil) (retrieval :deferred) (set t))
315 (let ((ih (make-hash-table :size 6)))
317 (setf (gethash :join-class ih) join-class)
318 (error "Must specify :join-class in :db-info"))
320 (setf (gethash :home-key ih) home-key)
321 (error "Must specify :home-key in :db-info"))
323 (setf (gethash :delete-rule ih) delete-rule))
325 (setf (gethash :foreign-key ih) foreign-key)
326 (error "Must specify :foreign-key in :db-info"))
328 (setf (gethash :key-join ih) t))
330 (setf (gethash :target-slot ih) target-slot))
332 (setf (gethash :set ih) set))
335 (setf (gethash :retrieval ih) retrieval)
336 (if (eql retrieval :immediate)
337 (setf (gethash :set ih) nil))))
340 (defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
341 standard-direct-slot-definition)
344 (defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
345 standard-effective-slot-definition)
348 (defmethod direct-slot-definition-class ((class standard-db-class)
349 #+kmr-normal-dsdc &rest
351 (declare (ignore initargs))
352 (find-class 'view-class-direct-slot-definition))
354 (defmethod effective-slot-definition-class ((class standard-db-class)
355 #+kmr-normal-esdc &rest
357 (declare (ignore initargs))
358 (find-class 'view-class-effective-slot-definition))
361 (when (not (symbol-function 'compute-class-precedence-list))
363 (defun compute-class-precedence-list (class)
364 (class-precedence-list class))))
366 #-mop-slot-order-reversed
367 (defmethod compute-slots ((class standard-db-class))
368 "Need to sort order of class slots so they are the same across
370 (let ((slots (call-next-method))
373 (dolist (c (compute-class-precedence-list class))
374 (dolist (s (class-direct-slots c))
375 (let ((name (slot-definition-name s)))
376 (unless (find name desired-sequence)
377 (push name desired-sequence)))))
378 (dolist (desired desired-sequence)
379 (let ((slot (find desired slots :key #'slot-definition-name)))
381 (push slot output-slots)))
384 (defun compute-lisp-type-from-specified-type (specified-type db-constraints)
385 "Computes the Lisp type for a user-specified type."
388 ((consp specified-type)
389 (let* ((first (first specified-type))
390 (name (etypecase first
391 (symbol (symbol-name first))
394 ((or (string-equal name "string")
395 (string-equal name "varchar")
396 (string-equal name "char"))
400 ((eq (ensure-keyword specified-type) :bigint)
402 ((eq (ensure-keyword specified-type) :char)
404 ((eq (ensure-keyword specified-type) :varchar)
408 (if (and type (not (member :not-null (listify db-constraints))))
412 ;; Compute the slot definition for slots in a view-class. Figures out
413 ;; what kind of database value (if any) is stored there, generates and
414 ;; verifies the column name.
416 (declaim (inline delistify))
417 (defun delistify (list)
418 "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
423 (declaim (inline delistify-dsd))
424 ;; there is an :after method below too
425 (defmethod initialize-instance :around
426 ((obj view-class-direct-slot-definition)
427 &rest initargs &key db-constraints db-kind type &allow-other-keys)
428 (when (and (not db-kind) (member :primary-key (listify db-constraints)))
429 (warn "Slot ~S constrained to be :primary-key, but not marked as :db-kind :key"
430 (slot-definition-name obj)))
431 (apply #'call-next-method obj
433 :type (if (and (eql db-kind :virtual) (null type))
435 (compute-lisp-type-from-specified-type
436 type db-constraints))
439 (defun compute-column-name (arg)
440 (database-identifier arg nil))
442 (defun %convert-db-info-to-hash (slot-def)
443 ;; I wonder if this slot option and the previous could be merged,
444 ;; so that :base and :key remain keyword options, but :db-kind
445 ;; :join becomes :db-kind (:join <db info .... >)?
446 (setf (slot-value slot-def 'db-info)
447 (when (slot-boundp slot-def 'db-info)
448 (let ((info (view-class-slot-db-info slot-def)))
453 (cond ((and (> (length info) 1)
455 (parse-db-info info))
456 ((and (= 1 (length info))
458 (parse-db-info (car info)))
461 (defmethod initialize-instance :after
462 ((obj view-class-direct-slot-definition)
463 &key &allow-other-keys)
464 (setf (view-class-slot-column obj) (compute-column-name obj)
465 (view-class-slot-autoincrement-sequence obj)
467 (view-class-slot-autoincrement-sequence obj)))
468 (%convert-db-info-to-hash obj))
470 (defmethod compute-effective-slot-definition ((class standard-db-class)
471 #+kmr-normal-cesd slot-name
473 #+kmr-normal-cesd (declare (ignore slot-name))
475 ;; KMR: store the user-specified type and then compute
476 ;; real Lisp type and store it
477 (let ((dsd (car direct-slots)))
478 (let ((esd (call-next-method)))
480 (view-class-slot-definition-mixin
481 (setf (slot-value esd 'column) (compute-column-name dsd))
484 ((safe-copy-value (name &optional default)
485 (let ((fn (intern (format nil "~A~A" 'view-class-slot- name ))))
486 `(setf (slot-value esd ',name)
487 (or (when (slot-boundp dsd ',name)
488 (delistify-dsd (,fn dsd)))
490 (safe-copy-value autoincrement-sequence)
491 (safe-copy-value db-type)
492 (safe-copy-value void-value)
493 (safe-copy-value db-reader)
494 (safe-copy-value db-writer)
495 ;; :db-kind slot value defaults to :base (store slot value in
497 (safe-copy-value db-kind :base)
498 (safe-copy-value db-constraints)
499 (safe-copy-value db-info)
500 (%convert-db-info-to-hash esd))
502 (setf (specified-type esd)
503 (delistify-dsd (specified-type dsd)))
504 ;; In older SBCL's the type-check-function is computed at
505 ;; defclass expansion, which is too early for the CLSQL type
506 ;; conversion to take place. This gets rid of it. It's ugly
507 ;; but it's better than nothing -wcp10/4/10.
508 #+(and sbcl #.(cl:if (cl:and (cl:find-package :sb-pcl)
509 (cl:find-symbol "%TYPE-CHECK-FUNCTION" :sb-pcl))
511 (setf (slot-value esd 'sb-pcl::%type-check-function) nil)
516 (unless (typep esd 'view-class-effective-slot-definition)
517 (warn "Non view-class-direct-slot object with non-view-class-effective-slot-definition in compute-effective-slot-definition")
519 (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate)))
520 #-openmcl (declare (ignore type-predicate))
521 #-(or clisp sbcl) (change-class esd 'view-class-effective-slot-definition
523 #+allegro (slot-definition-name dsd))
524 #+openmcl (setf (slot-value esd 'ccl::type-predicate)
527 ;; has no column name if it is not a database column
528 (setf (slot-value esd 'column) nil)
529 (setf (slot-value esd 'db-info) nil)
530 (setf (slot-value esd 'db-kind) :virtual)
531 (setf (specified-type esd) (slot-definition-type dsd)))
535 (defun slotdefs-for-slots-with-class (slots class)
538 (let ((c (slotdef-for-slot-with-class s class)))
539 (if c (setf result (cons c result)))))
542 (defun slotdef-for-slot-with-class (slot class)
544 (standard-slot-definition slot)
545 (symbol (find-slot-by-name class slot))))
548 (eval-when (:compile-toplevel :load-toplevel :execute)
550 (setq cl:*features* (delete :kmr-normal-cesd cl:*features*))
552 (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*))
554 (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
557 (defmethod database-identifier ( (name standard-db-class)
558 &optional database find-class-p)
559 "the majority of this function is in expressions.lisp
560 this is here to make loading be less painful (try-recompiles) in SBCL"
561 (declare (ignore find-class-p))
562 (database-identifier (view-table name) database))
564 (defmethod database-identifier ((name view-class-slot-definition-mixin)
565 &optional database find-class-p)
566 (declare (ignore find-class-p))
568 (if (slot-boundp name 'column)
569 (delistify-dsd (view-class-slot-column name))
570 (slot-definition-name name))
573 (defun find-standard-db-class (name &aux cls)
574 (and (setf cls (ignore-errors (find-class name)))
575 (typep cls 'standard-db-class)
578 (defun slots-for-possibly-normalized-class (class)
579 "Get the slots for this class, if normalized this is only the direct slots
580 otherwiese its all the slots"
581 (if (normalizedp class)
582 (ordered-class-direct-slots class)
583 (ordered-class-slots class)))
586 (defun key-slot-p (slot-def)
587 "takes a slot def and returns whether or not it is a key"
588 (eql :key (view-class-slot-db-kind slot-def)))
590 (defun join-slot-p (slot-def)
591 "takes a slot def and returns whether or not it is a join slot"
592 (eql :join (view-class-slot-db-kind slot-def)))
594 (defun join-slot-info-value (slot-def key)
595 "Get the join-slot db-info value associated with a key"
596 (when (join-slot-p slot-def)
597 (let ((dbi (view-class-slot-db-info slot-def)))
598 (when dbi (gethash key dbi)))))
600 (defun join-slot-retrieval-method (slot-def)
601 "if this is a join slot return the retrieval param in the db-info"
602 (join-slot-info-value slot-def :retrieval))
604 (defun join-slot-class-name (slot-def)
605 "get the join class name for a given join slot"
606 (join-slot-info-value slot-def :join-class))
608 (defun join-slot-class (slot-def)
609 "Get the join class for a given join slot"
610 (let ((c (join-slot-class-name slot-def)))
611 (when c (find-class c))))
613 (defun key-or-base-slot-p (slot-def)
614 "takes a slot def and returns whether or not it is a key"
615 (member (view-class-slot-db-kind slot-def) '(:key :base)))
617 (defun direct-normalized-slot-p (class slot-name)
618 "Is this a normalized class and if so is the slot one of our direct slots?"
619 (setf slot-name (to-slot-name slot-name))
620 (and (typep class 'standard-db-class)
622 (member slot-name (ordered-class-direct-slots class)
623 :key #'slot-definition-name)))
625 (defun not-direct-normalized-slot-p (class slot-name)
626 "Is this a normalized class and if so is the slot not one of our direct slots?"
627 (setf slot-name (to-slot-name slot-name))
628 (and (typep class 'standard-db-class)
630 (not (member slot-name (ordered-class-direct-slots class)
631 :key #'slot-definition-name))))
633 (defun slot-has-default-p (slot)
634 "returns nil if the slot does not have a default constraint"
636 (when (typep slot '(or view-class-direct-slot-definition
637 view-class-effective-slot-definition))
638 (listify (view-class-slot-db-constraints slot)))))
639 (member :default constraints)))