1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
4 ;;;; $Id: objects.lisp 8906 2004-04-09 12:41:07Z kevin $
6 ;;;; The CLSQL Object Oriented Data Definitional Language (OODDL)
7 ;;;; and Object Oriented Data Manipulation Language (OODML).
9 ;;;; This file is part of CLSQL.
11 ;;;; CLSQL users are granted the rights to distribute and use this software
12 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
13 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
14 ;;;; *************************************************************************
16 (in-package #:clsql-sys)
20 (defclass standard-db-object ()
21 ((stored :db-kind :virtual
24 (:metaclass standard-db-class)
25 (:documentation "Superclass for all CLSQL View Classes."))
27 (defvar *deserializing* nil)
28 (defvar *initializing* nil)
30 (defmethod initialize-instance :around ((object standard-db-object)
31 &rest all-keys &key &allow-other-keys)
32 (declare (ignore all-keys))
33 (let ((*initializing* t))
35 (unless *deserializing*
36 #+nil (created-object object)
37 (update-records-from-instance object))))
39 (defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
40 (declare (optimize (speed 3)))
41 (unless *deserializing*
42 (let ((slot-name (%slot-def-name slot-def))
43 (slot-kind (view-class-slot-db-kind slot-def)))
44 (when (and (eql slot-kind :join)
45 (not (slot-boundp instance slot-name)))
46 (let ((*deserializing* t))
47 (setf (slot-value instance slot-name)
48 (fault-join-slot class instance slot-def))))))
51 (defmethod (setf slot-value-using-class) :around (new-value (class standard-db-class) instance slot-def)
52 (declare (ignore new-value))
53 (let* ((slot-name (%slot-def-name slot-def))
54 (slot-kind (view-class-slot-db-kind slot-def))
55 (no-update? (or (eql slot-kind :virtual)
60 (update-record-from-slot instance slot-name))))
62 (defun %slot-def-name (slot)
64 #-lispworks (slot-definition-name slot))
66 (defun %slot-object (slot class)
67 (declare (ignorable class))
68 #+lispworks (clos:find-slot-definition slot class)
71 (defun sequence-from-class (view-class-name)
75 (symbol-name (view-table (find-class view-class-name)))
78 (defun create-sequence-from-class (view-class-name
79 &key (database *default-database*))
80 (create-sequence (sequence-from-class view-class-name) :database database))
82 (defun drop-sequence-from-class (view-class-name
83 &key (if-does-not-exist :error)
84 (database *default-database*))
85 (drop-sequence (sequence-from-class view-class-name)
86 :if-does-not-exist if-does-not-exist
90 ;; Build the database tables required to store the given view class
93 (defmethod database-pkey-constraint ((class standard-db-class) database)
94 (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
96 (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
97 (database-output-sql (view-table class) database)
98 (database-output-sql keylist database)))))
104 #.(locally-enable-sql-reader-syntax)
106 (defun ensure-schema-version-table (database)
107 (unless (table-exists-p "clsql_object_v" :database database)
108 (create-table [clsql_object_v] '(([name] string)
111 :database database)))
113 (defun update-schema-version-records (view-class-name
114 &key (database *default-database*))
115 (let ((schemadef nil)
116 (tclass (find-class view-class-name)))
117 (dolist (slotdef (class-slots tclass))
118 (let ((res (database-generate-column-definition view-class-name
120 (when res (setf schemadef (cons res schemadef)))))
122 (delete-records :from [clsql_object_v]
123 :where [= [name] (sql-escape (class-name tclass))]
125 (insert-records :into [clsql_object_v]
126 :av-pairs `(([name] ,(sql-escape (class-name tclass)))
127 ([vers] ,(car (object-version tclass)))
128 ([def] ,(prin1-to-string
129 (object-definition tclass))))
130 :database database))))
132 #.(restore-sql-reader-syntax-state)
135 (defun create-view-from-class (view-class-name
136 &key (database *default-database*))
137 "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
138 the view. The argument DATABASE has a default value of
140 (let ((tclass (find-class view-class-name)))
142 (let ((*default-database* database))
143 (%install-class tclass database)
144 #+noschema (ensure-schema-version-table database)
145 #+noschema (update-schema-version-records view-class-name :database database))
146 (error "Class ~s not found." view-class-name)))
149 (defmethod %install-class ((self standard-db-class) database &aux schemadef)
150 (dolist (slotdef (ordered-class-slots self))
151 (let ((res (database-generate-column-definition (class-name self)
154 (push res schemadef))))
156 (error "Class ~s has no :base slots" self))
157 (create-table (sql-expression :table (view-table self)) schemadef
159 :constraints (database-pkey-constraint self database))
160 (push self (database-view-classes database))
164 ;; Drop the tables which store the given view class
167 #.(locally-enable-sql-reader-syntax)
169 (defun drop-view-from-class (view-class-name &key (database *default-database*))
170 "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME
171 which defines that view. The argument DATABASE has a default value of
173 (let ((tclass (find-class view-class-name)))
175 (let ((*default-database* database))
176 (%uninstall-class tclass)
178 (delete-records :from [clsql_object_v]
179 :where [= [name] (sql-escape view-class-name)]))
180 (error "Class ~s not found." view-class-name)))
183 #.(restore-sql-reader-syntax-state)
185 (defun %uninstall-class (self &key (database *default-database*))
186 (drop-table (sql-expression :table (view-table self))
187 :if-does-not-exist :ignore
189 (setf (database-view-classes database)
190 (remove self (database-view-classes database))))
194 ;; List all known view classes
197 (defun list-classes (&key (test #'identity)
198 (root-class 'standard-db-object)
199 (database *default-database*))
200 "Returns a list of View Classes connected to a given DATABASE which
201 defaults to *DEFAULT-DATABASE*."
202 (declare (ignore root-class))
203 (remove-if #'(lambda (c) (not (funcall test c)))
204 (database-view-classes database)))
207 ;; Define a new view class
210 (defmacro def-view-class (class supers slots &rest options)
211 "Extends the syntax of defclass to allow special slots to be mapped
212 onto the attributes of database views. The macro DEF-VIEW-CLASS
213 creates a class called CLASS which maps onto a database view. Such a
214 class is called a View Class. The macro DEF-VIEW-CLASS extends the
215 syntax of DEFCLASS to allow special base slots to be mapped onto the
216 attributes of database views (presently single tables). When a select
217 query that names a View Class is submitted, then the corresponding
218 database view is queried, and the slots in the resulting View Class
219 instances are filled with attribute values from the database. If
220 SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the
221 superclass of the newly-defined View Class."
223 (defclass ,class ,supers ,slots ,@options
224 (:metaclass standard-db-class))
225 (finalize-inheritance (find-class ',class))))
227 (defun keyslots-for-class (class)
228 (slot-value class 'key-slots))
230 (defun key-qualifier-for-instance (obj &key (database *default-database*))
231 (let ((tb (view-table (class-of obj))))
234 (sql-expression :attribute
235 (view-class-slot-column k)
239 (slot-value obj (slot-definition-name k))
241 (let* ((keys (keyslots-for-class (class-of obj)))
242 (keyxprs (mapcar #'qfk (reverse keys))))
244 ((= (length keyxprs) 0) nil)
245 ((= (length keyxprs) 1) (car keyxprs))
246 ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
249 ;; Function used by 'generate-selection-list'
252 (defun generate-attribute-reference (vclass slotdef)
254 ((eq (view-class-slot-db-kind slotdef) :base)
255 (sql-expression :attribute (view-class-slot-column slotdef)
256 :table (view-table vclass)))
257 ((eq (view-class-slot-db-kind slotdef) :key)
258 (sql-expression :attribute (view-class-slot-column slotdef)
259 :table (view-table vclass)))
263 ;; Function used by 'find-all'
266 (defun generate-selection-list (vclass)
268 (dolist (slotdef (ordered-class-slots vclass))
269 (let ((res (generate-attribute-reference vclass slotdef)))
271 (push (cons slotdef res) sels))))
274 (error "No slots of type :base in view-class ~A" (class-name vclass)))))
277 ;; Used by 'create-view-from-class'
281 (defmethod database-generate-column-definition (class slotdef database)
282 (declare (ignore database class))
283 (when (member (view-class-slot-db-kind slotdef) '(:base :key))
285 (list (sql-expression :attribute (view-class-slot-column slotdef))
286 (slot-type slotdef))))
287 (let ((const (view-class-slot-db-constraints slotdef)))
289 (setq cdef (append cdef (list const)))))
293 ;; Called by 'get-slot-values-from-view'
296 (declaim (inline delistify))
297 (defun delistify (list)
302 (defun slot-type (slotdef)
303 (specified-type slotdef)
305 (let ((slot-type (specified-type slotdef)))
306 (if (listp slot-type)
307 (cons (find-symbol (symbol-name (car slot-type)) :clsql-sys)
309 (find-symbol (symbol-name slot-type) :clsql-sys))))
311 (defvar *update-context* nil)
313 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
314 (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
315 (let* ((slot-reader (view-class-slot-db-reader slotdef))
316 (slot-name (slot-definition-name slotdef))
317 (slot-type (slot-type slotdef))
318 (*update-context* (cons (type-of instance) slot-name)))
319 (cond ((and value (null slot-reader))
320 (setf (slot-value instance slot-name)
321 (read-sql-value value (delistify slot-type)
322 *default-database*)))
324 (update-slot-with-null instance slot-name slotdef))
325 ((typep slot-reader 'string)
326 (setf (slot-value instance slot-name)
327 (format nil slot-reader value)))
328 ((typep slot-reader 'function)
329 (setf (slot-value instance slot-name)
330 (apply slot-reader (list value))))
332 (error "Slot reader is of an unusual type.")))))
334 (defmethod key-value-from-db (slotdef value database)
335 (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
336 (let ((slot-reader (view-class-slot-db-reader slotdef))
337 (slot-type (slot-type slotdef)))
338 (cond ((and value (null slot-reader))
339 (read-sql-value value (delistify slot-type) database))
342 ((typep slot-reader 'string)
343 (format nil slot-reader value))
344 ((typep slot-reader 'function)
345 (apply slot-reader (list value)))
347 (error "Slot reader is of an unusual type.")))))
349 (defun db-value-from-slot (slotdef val database)
350 (let ((dbwriter (view-class-slot-db-writer slotdef))
351 (dbtype (slot-type slotdef)))
353 (string (format nil dbwriter val))
354 (function (apply dbwriter (list val)))
358 (database-output-sql-as-type (car dbtype) val database))
360 (database-output-sql-as-type dbtype val database)))))))
362 (defun check-slot-type (slotdef val)
363 (let* ((slot-type (slot-type slotdef))
364 (basetype (if (listp slot-type) (car slot-type) slot-type)))
365 (when (and slot-type val)
366 (unless (typep val basetype)
367 (error 'clsql-type-error
368 :slotname (slot-definition-name slotdef)
373 ;; Called by find-all
376 (defmethod get-slot-values-from-view (obj slotdeflist values)
377 (flet ((update-slot (slot-def values)
378 (update-slot-from-db obj slot-def values)))
379 (mapc #'update-slot slotdeflist values)
382 (defun synchronize-keys (src srckey dest destkey)
383 (let ((skeys (if (listp srckey) srckey (list srckey)))
384 (dkeys (if (listp destkey) destkey (list destkey))))
385 (mapcar #'(lambda (sk dk)
386 (setf (slot-value dest dk)
393 (defun desynchronize-keys (dest destkey)
394 (let ((dkeys (if (listp destkey) destkey (list destkey))))
395 (mapcar #'(lambda (dk)
396 (setf (slot-value dest dk) nil))
399 (defmethod add-to-relation ((target standard-db-object)
401 (value standard-db-object))
402 (let* ((objclass (class-of target))
403 (sdef (or (slotdef-for-slot-with-class slot-name objclass)
404 (error "~s is not an known slot on ~s" slot-name target)))
405 (dbinfo (view-class-slot-db-info sdef))
406 (join-class (gethash :join-class dbinfo))
407 (homekey (gethash :home-key dbinfo))
408 (foreignkey (gethash :foreign-key dbinfo))
409 (to-many (gethash :set dbinfo)))
410 (unless (equal (type-of value) join-class)
411 (error 'clsql-type-error :slotname slot-name :typespec join-class
413 (when (gethash :target-slot dbinfo)
414 (error "add-to-relation does not work with many-to-many relations yet."))
417 (synchronize-keys target homekey value foreignkey)
418 (if (slot-boundp target slot-name)
419 (unless (member value (slot-value target slot-name))
420 (setf (slot-value target slot-name)
421 (append (slot-value target slot-name) (list value))))
422 (setf (slot-value target slot-name) (list value))))
424 (synchronize-keys value foreignkey target homekey)
425 (setf (slot-value target slot-name) value)))))
427 (defmethod remove-from-relation ((target standard-db-object)
428 slot-name (value standard-db-object))
429 (let* ((objclass (class-of target))
430 (sdef (slotdef-for-slot-with-class slot-name objclass))
431 (dbinfo (view-class-slot-db-info sdef))
432 (homekey (gethash :home-key dbinfo))
433 (foreignkey (gethash :foreign-key dbinfo))
434 (to-many (gethash :set dbinfo)))
435 (when (gethash :target-slot dbinfo)
436 (error "remove-relation does not work with many-to-many relations yet."))
439 (desynchronize-keys value foreignkey)
440 (if (slot-boundp target slot-name)
441 (setf (slot-value target slot-name)
443 (slot-value target slot-name)
446 (desynchronize-keys target homekey)
447 (setf (slot-value target slot-name)
451 (defgeneric update-record-from-slot (object slot &key database)
453 "The generic function UPDATE-RECORD-FROM-SLOT updates an individual
454 data item in the column represented by SLOT. The DATABASE is only used
455 if OBJECT is not yet associated with any database, in which case a
456 record is created in DATABASE. Only SLOT is initialized in this case;
457 other columns in the underlying database receive default values. The
458 argument SLOT is the CLOS slot name; the corresponding column names
459 are derived from the View Class definition."))
461 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
462 (database *default-database*))
463 #+nil (odcl:updated-object obj)
464 (let* ((vct (view-table (class-of obj)))
465 (stored? (slot-value obj 'stored))
466 (sd (slotdef-for-slot-with-class slot (class-of obj))))
467 (check-slot-type sd (slot-value obj slot))
468 (let* ((att (view-class-slot-column sd))
469 (val (db-value-from-slot sd (slot-value obj slot) database)))
470 (cond ((and vct sd stored?)
471 (update-records :table (sql-expression :table vct)
472 :attributes (list (sql-expression :attribute att))
474 :where (key-qualifier-for-instance obj :database database)
479 (error "Unable to update record")))))
482 (defgeneric update-record-from-slots (object slots &key database)
484 "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the
485 columns represented by SLOTS. The DATABASE is only used if OBJECT is
486 not yet associated with any database, in which case a record is
487 created in DATABASE. Only slots are initialized in this case; other
488 columns in the underlying database receive default values. The
489 argument SLOTS contains the CLOS slot names; the corresponding column
490 names are derived from the view class definition."))
492 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
493 (database *default-database*))
494 (let* ((vct (view-table (class-of obj)))
495 (stored? (slot-value obj 'stored))
496 (sds (slotdefs-for-slots-with-class slots (class-of obj)))
497 (avps (mapcar #'(lambda (s)
498 (let ((val (slot-value
499 obj (slot-definition-name s))))
500 (check-slot-type s val)
501 (list (sql-expression
502 :attribute (view-class-slot-column s))
503 (db-value-from-slot s val database))))
505 (cond ((and avps stored?)
506 (update-records :table (sql-expression :table vct)
508 :where (key-qualifier-for-instance
509 obj :database database)
512 (insert-records :into (sql-expression :table vct)
515 (setf (slot-value obj 'stored) t))
517 (error "Unable to update records"))))
521 (defgeneric update-records-from-instance (object &key database)
523 "Using an instance of a view class, update the database table that
524 stores its instance data. If the instance is already associated with a
525 database, that database is used, and database is ignored. If instance
526 is not yet associated with a database, a record is created for
527 instance in the appropriate table of database and the instance becomes
528 associated with that database."))
530 (defmethod update-records-from-instance ((obj standard-db-object)
531 &key (database *default-database*))
532 (labels ((slot-storedp (slot)
533 (and (member (view-class-slot-db-kind slot) '(:base :key))
534 (slot-boundp obj (slot-definition-name slot))))
535 (slot-value-list (slot)
536 (let ((value (slot-value obj (slot-definition-name slot))))
537 (check-slot-type slot value)
538 (list (sql-expression :attribute (view-class-slot-column slot))
539 (db-value-from-slot slot value database)))))
540 (let* ((view-class (class-of obj))
541 (view-class-table (view-table view-class))
542 (slots (remove-if-not #'slot-storedp (class-slots view-class)))
543 (record-values (mapcar #'slot-value-list slots)))
544 (unless record-values
545 (error "No settable slots."))
546 (if (slot-value obj 'stored)
547 (update-records :table (sql-expression :table view-class-table)
548 :av-pairs record-values
549 :where (key-qualifier-for-instance
550 obj :database database)
553 (insert-records :into (sql-expression :table view-class-table)
554 :av-pairs record-values
556 (setf (slot-value obj 'stored) t)))))
559 (setf (symbol-function (intern (symbol-name '#:store-instance)))
560 (symbol-function 'update-records-from-instance))
562 (defmethod delete-instance-records ((object standard-db-object))
563 (let ((vt (sql-expression :table (view-table (class-of object))))
564 (qualifier (key-qualifier-for-instance object :database *default-database*)))
565 (delete-records :from vt :where qualifier :database *default-database*)
566 #+ignore (odcl::deleted-object object)))
568 (defgeneric update-instance-from-db (instance)
570 "Updates the values in the slots of the View Class instance
571 INSTANCE using the data in the database DATABASE which defaults to the
572 database that INSTANCE is associated with, or the value of
573 *DEFAULT-DATABASE*."))
575 (defmethod update-instance-from-db ((object standard-db-object))
576 (let* ((view-class (find-class (class-name (class-of object))))
577 (view-table (sql-expression :table (view-table view-class)))
578 (view-qual (key-qualifier-for-instance object :database *default-database*))
579 (sels (generate-selection-list view-class))
580 (res (apply #'select (append (mapcar #'cdr sels) (list :from view-table
581 :where view-qual)))))
583 (get-slot-values-from-view object (mapcar #'car sels) (car res))
587 (defgeneric database-null-value (type)
588 (:documentation "Return an expression of type TYPE which SQL NULL values
589 will be converted into."))
591 (defmethod database-null-value ((type t))
593 ((subtypep type 'string) nil)
594 ((subtypep type 'integer) nil)
595 ((subtypep type 'list) nil)
596 ((subtypep type 'boolean) nil)
598 ((subtypep type 'symbol) nil)
599 ((subtypep type 'keyword) nil)
600 ((subtypep type 'wall-time) nil)
601 ((subtypep type 'duration) nil)
602 ((subtypep type 'money) nil)
604 (error "Unable to handle null for type ~A" type))))
606 (defgeneric update-slot-with-null (instance slotname slotdef)
607 (:documentation "Called to update a slot when its column has a NULL
608 value. If nulls are allowed for the column, the slot's value will be
609 nil, otherwise its value will be set to the result of calling
610 DATABASE-NULL-VALUE on the type of the slot."))
612 (defmethod update-slot-with-null ((object standard-db-object)
615 (let ((st (slot-definition-type slotdef))
616 (allowed (slot-value slotdef 'nulls-ok)))
618 (setf (slot-value object slotname) nil)
619 (setf (slot-value object slotname)
620 (database-null-value st)))))
622 (defvar +no-slot-value+ '+no-slot-value+)
624 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
625 (let* ((class (find-class classname))
626 (sld (slotdef-for-slot-with-class slot class)))
628 (if (eq value +no-slot-value+)
629 (sql-expression :attribute (view-class-slot-column sld)
630 :table (view-table class))
635 (error "Unknown slot ~A for class ~A" slot classname))))
637 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
638 (declare (ignore database))
639 (let* ((class (find-class classname)))
640 (unless (view-table class)
641 (error "No view-table for class ~A" classname))
642 (sql-expression :table (view-table class))))
644 (defmethod database-get-type-specifier (type args database)
645 (declare (ignore type args))
646 (if (member (database-type database) '(:postgresql :postgresql-socket))
650 (defmethod database-get-type-specifier ((type (eql 'integer)) args database)
651 (declare (ignore database))
654 (format nil "INT(~A)" (car args))
657 (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
660 (format nil "VARCHAR(~A)" (car args))
661 (if (member (database-type database) '(:postgresql :postgresql-socket))
665 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
668 (format nil "VARCHAR(~A)" (car args))
669 (if (member (database-type database) '(:postgresql :postgresql-socket))
673 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
675 (format nil "VARCHAR(~A)" (car args))
676 (if (member (database-type database) '(:postgresql :postgresql-socket))
680 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
681 (declare (ignore args))
682 (case (database-type database)
684 "TIMESTAMP WITHOUT TIME ZONE")
686 "TIMESTAMP WITHOUT TIME ZONE")
691 (defmethod database-get-type-specifier ((type (eql 'duration)) args database)
692 (declare (ignore database args))
695 (defmethod database-get-type-specifier ((type (eql 'money)) args database)
696 (declare (ignore database args))
699 (deftype raw-string (&optional len)
700 "A string which is not trimmed when retrieved from the database"
703 (defmethod database-get-type-specifier ((type (eql 'raw-string)) args database)
704 (declare (ignore database))
706 (format nil "VARCHAR(~A)" (car args))
709 (defmethod database-get-type-specifier ((type (eql 'float)) args database)
710 (declare (ignore database))
712 (format nil "FLOAT(~A)" (car args))
715 (defmethod database-get-type-specifier ((type (eql 'long-float)) args database)
716 (declare (ignore database))
718 (format nil "FLOAT(~A)" (car args))
721 (defmethod database-get-type-specifier ((type (eql 't)) args database)
722 (declare (ignore args database))
725 (defmethod database-output-sql-as-type (type val database)
726 (declare (ignore type database))
729 (defmethod database-output-sql-as-type ((type (eql 'list)) val database)
730 (declare (ignore database))
731 (progv '(*print-circle* *print-array*) '(t t)
732 (let ((escaped (prin1-to-string val)))
733 (clsql-base-sys::substitute-char-string
734 escaped #\Null " "))))
736 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
737 (declare (ignore database))
742 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database)
743 (declare (ignore database))
748 (defmethod database-output-sql-as-type ((type (eql 'vector)) val database)
749 (declare (ignore database))
750 (progv '(*print-circle* *print-array*) '(t t)
751 (prin1-to-string val)))
753 (defmethod database-output-sql-as-type ((type (eql 'array)) val database)
754 (declare (ignore database))
755 (progv '(*print-circle* *print-array*) '(t t)
756 (prin1-to-string val)))
758 (defmethod database-output-sql-as-type ((type (eql 't)) val database)
759 (declare (ignore database))
762 (defmethod database-output-sql-as-type ((type (eql 'string)) val database)
763 (declare (ignore database))
766 (defmethod database-output-sql-as-type ((type (eql 'simple-string))
768 (declare (ignore database))
771 (defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
773 (declare (ignore database))
776 (defmethod read-sql-value (val type database)
777 (declare (ignore type database))
778 (read-from-string val))
780 (defmethod read-sql-value (val (type (eql 'string)) database)
781 (declare (ignore database))
784 (defmethod read-sql-value (val (type (eql 'simple-string)) database)
785 (declare (ignore database))
788 (defmethod read-sql-value (val (type (eql 'simple-base-string)) database)
789 (declare (ignore database))
792 (defmethod read-sql-value (val (type (eql 'raw-string)) database)
793 (declare (ignore database))
796 (defmethod read-sql-value (val (type (eql 'keyword)) database)
797 (declare (ignore database))
798 (when (< 0 (length val))
799 (intern (string-upcase val) "KEYWORD")))
801 (defmethod read-sql-value (val (type (eql 'symbol)) database)
802 (declare (ignore database))
803 (when (< 0 (length val))
804 (unless (string= val "NIL")
805 (intern (string-upcase val)
806 (symbol-package *update-context*)))))
808 (defmethod read-sql-value (val (type (eql 'integer)) database)
809 (declare (ignore database))
812 (read-from-string val))
815 (defmethod read-sql-value (val (type (eql 'float)) database)
816 (declare (ignore database))
817 ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
818 (float (read-from-string val)))
820 (defmethod read-sql-value (val (type (eql 't)) database)
821 (declare (ignore database))
824 (defmethod read-sql-value (val (type (eql 'wall-time)) database)
825 (declare (ignore database))
826 (unless (eq 'NULL val)
827 (parse-timestring val)))
829 (defmethod read-sql-value (val (type (eql 'duration)) database)
830 (declare (ignore database))
831 (unless (or (eq 'NULL val)
833 (parse-timestring val)))
835 (defmethod read-sql-value (val (type (eql 'money)) database)
836 (unless (eq 'NULL val)
837 (make-instance 'money :units (read-sql-value val 'integer database))))
839 ;; ------------------------------------------------------------
840 ;; Logic for 'faulting in' :join slots
842 (defun fault-join-slot-raw (class object slot-def)
843 (let* ((dbi (view-class-slot-db-info slot-def))
844 (jc (gethash :join-class dbi)))
845 (let ((jq (join-qualifier class object slot-def)))
847 (select jc :where jq)))))
849 (defun fault-join-slot (class object slot-def)
850 (let* ((dbi (view-class-slot-db-info slot-def))
851 (ts (gethash :target-slot dbi))
852 (res (fault-join-slot-raw class object slot-def)))
855 ((and ts (gethash :set dbi))
856 (mapcar (lambda (obj)
857 (cons obj (slot-value obj ts))) res))
858 ((and ts (not (gethash :set dbi)))
859 (mapcar (lambda (obj) (slot-value obj ts)) res))
860 ((and (not ts) (not (gethash :set dbi)))
862 ((and (not ts) (gethash :set dbi))
865 (defun join-qualifier (class object slot-def)
866 (declare (ignore class))
867 (let* ((dbi (view-class-slot-db-info slot-def))
868 (jc (find-class (gethash :join-class dbi)))
869 ;;(ts (gethash :target-slot dbi))
870 ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
871 (foreign-keys (gethash :foreign-key dbi))
872 (home-keys (gethash :home-key dbi)))
873 (when (every #'(lambda (slt)
874 (and (slot-boundp object slt)
875 (not (null (slot-value object slt)))))
876 (if (listp home-keys) home-keys (list home-keys)))
877 (let ((jc (mapcar #'(lambda (hk fk)
878 (let ((fksd (slotdef-for-slot-with-class fk jc)))
883 :attribute (view-class-slot-column fksd)
884 :table (view-table jc)))
888 (slot-value object hk))
891 (if (listp home-keys) home-keys (list home-keys))
892 (if (listp foreign-keys) foreign-keys (list foreign-keys)))))
894 (if (> (length jc) 1)
898 (defmethod postinitialize ((self t))
901 (defun find-all (view-classes &rest args &key all set-operation distinct from
902 where group-by having order-by order-by-descending offset limit
903 (database *default-database*))
904 "tweeze me apart someone pleeze"
905 (declare (ignore all set-operation group-by having
907 (optimize (debug 3) (speed 1)))
908 ;; (cmsg "Args = ~s" args)
910 (let* ((*deserializing* t)
911 (*default-database* (or database
912 (error 'usql-nodb-error))))
913 (flet ((table-sql-expr (table)
914 (sql-expression :table (view-table table)))
915 (ref-equal (ref1 ref2)
918 (tables-equal (table-a table-b)
919 (string= (string (slot-value table-a 'name))
920 (string (slot-value table-b 'name)))))
922 (let* ((sclasses (mapcar #'find-class view-classes))
923 (sels (mapcar #'generate-selection-list sclasses))
924 (fullsels (apply #'append sels))
925 (sel-tables (collect-table-refs where))
926 (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses) sel-tables)
927 :test #'tables-equal))
929 (dolist (ob (listify order-by))
930 (when (and ob (not (member ob (mapcar #'cdr fullsels)
932 (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att))
934 (dolist (ob (listify order-by-descending))
935 (when (and ob (not (member ob (mapcar #'cdr fullsels)
937 (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att))
939 (dolist (ob (listify distinct))
940 (when (and (typep ob 'sql-ident) (not (member ob (mapcar #'cdr fullsels)
942 (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att))
944 ;; (cmsg "Tables = ~s" tables)
945 ;; (cmsg "From = ~s" from)
946 (setq res (apply #'select (append (mapcar #'cdr fullsels)
947 (cons :from (list (append (when from (listify from)) (listify tables)))) args)))
948 (flet ((build-object (vals)
949 (flet ((%build-object (vclass selects)
950 (let ((class-name (class-name vclass))
951 (db-vals (butlast vals (- (list-length vals)
952 (list-length selects)))))
953 ;; (setf vals (nthcdr (list-length selects) vals))
954 (%make-fresh-object class-name (mapcar #'car selects) db-vals))))
955 (let ((objects (mapcar #'%build-object sclasses sels)))
956 (if (= (length sclasses) 1)
959 (mapcar #'build-object res))))))
961 (defun %make-fresh-object (class-name slots values)
962 (let* ((*initializing* t)
963 (obj (make-instance class-name
965 (setf obj (get-slot-values-from-view obj slots values))
969 (defun select (&rest select-all-args)
970 "Selects data from database given the constraints specified. Returns
971 a list of lists of record values as specified by select-all-args. By
972 default, the records are each represented as lists of attribute
973 values. The selections argument may be either db-identifiers, literal
974 strings or view classes. If the argument consists solely of view
975 classes, the return value will be instances of objects rather than raw
977 (flet ((select-objects (target-args)
979 (every #'(lambda (arg)
981 (find-class arg nil)))
983 (multiple-value-bind (target-args qualifier-args)
984 (query-get-selections select-all-args)
985 ;; (cmsg "Qual args = ~s" qualifier-args)
986 (if (select-objects target-args)
987 (apply #'find-all target-args qualifier-args)
988 (let ((expr (apply #'make-query select-all-args)))
989 (destructuring-bind (&key (flatp nil)
990 (database *default-database*)
993 (let ((res (query expr :database database)))
995 (= (length (slot-value expr 'selections)) 1))