1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
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 ;;;; *************************************************************************
18 (defclass standard-db-object ()
19 ((view-database :initform nil :initarg :view-database :reader view-database
21 (:metaclass standard-db-class)
22 (:documentation "Superclass for all CLSQL View Classes."))
24 (defvar *db-auto-sync* nil
25 "A non-nil value means that creating View Class instances or
26 setting their slots automatically creates/updates the
27 corresponding records in the underlying database.")
29 (defvar *db-deserializing* nil)
30 (defvar *db-initializing* nil)
32 (defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
33 (declare (optimize (speed 3)))
34 (unless *db-deserializing*
35 (let* ((slot-name (%svuc-slot-name slot-def))
36 (slot-object (%svuc-slot-object slot-def class))
37 (slot-kind (view-class-slot-db-kind slot-object)))
38 (when (and (eql slot-kind :join)
39 (not (slot-boundp instance slot-name)))
40 (let ((*db-deserializing* t))
41 (if (view-database instance)
42 (setf (slot-value instance slot-name)
43 (fault-join-slot class instance slot-object))
44 (setf (slot-value instance slot-name) nil))))))
47 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
49 (declare (ignore new-value))
50 (let ((slot-name (%svuc-slot-name slot-def))
51 (slot-kind (view-class-slot-db-kind slot-def)))
53 (when (and *db-auto-sync*
54 (not *db-initializing*)
55 (not *db-deserializing*)
56 (not (eql slot-kind :virtual)))
57 (update-record-from-slot instance slot-name))))
59 (defmethod initialize-instance ((object standard-db-object)
60 &rest all-keys &key &allow-other-keys)
61 (declare (ignore all-keys))
62 (let ((*db-initializing* t))
64 (when (and *db-auto-sync*
65 (not *db-deserializing*))
66 (update-records-from-instance object))))
69 ;; Build the database tables required to store the given view class
72 (defun create-view-from-class (view-class-name
73 &key (database *default-database*))
74 "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
75 the view. The argument DATABASE has a default value of
77 (let ((tclass (find-class view-class-name)))
79 (let ((*default-database* database))
80 (%install-class tclass database))
81 (error "Class ~s not found." view-class-name)))
84 (defmethod %install-class ((self standard-db-class) database &aux schemadef)
85 (dolist (slotdef (ordered-class-slots self))
86 (let ((res (database-generate-column-definition (class-name self)
89 (push res schemadef))))
91 (error "Class ~s has no :base slots" self))
92 (create-table (sql-expression :table (view-table self)) schemadef
94 :constraints (database-pkey-constraint self database))
95 (push self (database-view-classes database))
98 (defmethod database-pkey-constraint ((class standard-db-class) database)
99 (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
101 (convert-to-db-default-case
102 (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
103 (database-output-sql (view-table class) database)
104 (database-output-sql keylist database))
107 (defmethod database-generate-column-definition (class slotdef database)
108 (declare (ignore database class))
109 (when (member (view-class-slot-db-kind slotdef) '(:base :key))
111 (list (sql-expression :attribute (view-class-slot-column slotdef))
112 (specified-type slotdef))))
113 (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
114 (let ((const (view-class-slot-db-constraints slotdef)))
116 (setq cdef (append cdef (list const)))))
121 ;; Drop the tables which store the given view class
124 (defun drop-view-from-class (view-class-name &key (database *default-database*))
125 "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME
126 which defines that view. The argument DATABASE has a default value of
128 (let ((tclass (find-class view-class-name)))
130 (let ((*default-database* database))
131 (%uninstall-class tclass))
132 (error "Class ~s not found." view-class-name)))
135 (defun %uninstall-class (self &key (database *default-database*))
136 (drop-table (sql-expression :table (view-table self))
137 :if-does-not-exist :ignore
139 (setf (database-view-classes database)
140 (remove self (database-view-classes database))))
144 ;; List all known view classes
147 (defun list-classes (&key (test #'identity)
148 (root-class (find-class 'standard-db-object))
149 (database *default-database*))
150 "The LIST-CLASSES function collects all the classes below
151 ROOT-CLASS, which defaults to standard-db-object, that are connected
152 to the supplied DATABASE and which satisfy the TEST function. The
153 default for the TEST argument is identity. By default, LIST-CLASSES
154 returns a list of all the classes connected to the default database,
156 (flet ((find-superclass (class)
157 (member root-class (class-precedence-list class))))
158 (let ((view-classes (and database (database-view-classes database))))
160 (remove-if #'(lambda (c) (or (not (funcall test c))
161 (not (find-superclass c))))
165 ;; Define a new view class
168 (defmacro def-view-class (class supers slots &rest cl-options)
169 "Extends the syntax of defclass to allow special slots to be mapped
170 onto the attributes of database views. The macro DEF-VIEW-CLASS
171 creates a class called CLASS which maps onto a database view. Such a
172 class is called a View Class. The macro DEF-VIEW-CLASS extends the
173 syntax of DEFCLASS to allow special base slots to be mapped onto the
174 attributes of database views (presently single tables). When a select
175 query that names a View Class is submitted, then the corresponding
176 database view is queried, and the slots in the resulting View Class
177 instances are filled with attribute values from the database. If
178 SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the
179 superclass of the newly-defined View Class."
181 (defclass ,class ,supers ,slots
182 ,@(if (find :metaclass `,cl-options :key #'car)
184 (cons '(:metaclass clsql::standard-db-class) `,cl-options)))
185 (finalize-inheritance (find-class ',class))
186 (find-class ',class)))
188 (defun keyslots-for-class (class)
189 (slot-value class 'key-slots))
191 (defun key-qualifier-for-instance (obj &key (database *default-database*))
192 (let ((tb (view-table (class-of obj))))
195 (sql-expression :attribute
196 (view-class-slot-column k)
200 (slot-value obj (slot-definition-name k))
202 (let* ((keys (keyslots-for-class (class-of obj)))
203 (keyxprs (mapcar #'qfk (reverse keys))))
205 ((= (length keyxprs) 0) nil)
206 ((= (length keyxprs) 1) (car keyxprs))
207 ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
210 ;; Function used by 'generate-selection-list'
213 (defun generate-attribute-reference (vclass slotdef)
215 ((eq (view-class-slot-db-kind slotdef) :base)
216 (sql-expression :attribute (view-class-slot-column slotdef)
217 :table (view-table vclass)))
218 ((eq (view-class-slot-db-kind slotdef) :key)
219 (sql-expression :attribute (view-class-slot-column slotdef)
220 :table (view-table vclass)))
224 ;; Function used by 'find-all'
227 (defun generate-selection-list (vclass)
229 (dolist (slotdef (ordered-class-slots vclass))
230 (let ((res (generate-attribute-reference vclass slotdef)))
232 (push (cons slotdef res) sels))))
235 (error "No slots of type :base in view-class ~A" (class-name vclass)))))
239 ;; Called by 'get-slot-values-from-view'
242 (declaim (inline delistify))
243 (defun delistify (list)
248 (defvar *update-context* nil)
250 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
251 (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
252 (let* ((slot-reader (view-class-slot-db-reader slotdef))
253 (slot-name (slot-definition-name slotdef))
254 (slot-type (specified-type slotdef))
255 (*update-context* (cons (type-of instance) slot-name)))
256 (cond ((and value (null slot-reader))
257 (setf (slot-value instance slot-name)
258 (read-sql-value value (delistify slot-type)
259 (view-database instance))))
261 (update-slot-with-null instance slot-name slotdef))
262 ((typep slot-reader 'string)
263 (setf (slot-value instance slot-name)
264 (format nil slot-reader value)))
265 ((typep slot-reader 'function)
266 (setf (slot-value instance slot-name)
267 (apply slot-reader (list value))))
269 (error "Slot reader is of an unusual type.")))))
271 (defmethod key-value-from-db (slotdef value database)
272 (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
273 (let ((slot-reader (view-class-slot-db-reader slotdef))
274 (slot-type (specified-type slotdef)))
275 (cond ((and value (null slot-reader))
276 (read-sql-value value (delistify slot-type) database))
279 ((typep slot-reader 'string)
280 (format nil slot-reader value))
281 ((typep slot-reader 'function)
282 (apply slot-reader (list value)))
284 (error "Slot reader is of an unusual type.")))))
286 (defun db-value-from-slot (slotdef val database)
287 (let ((dbwriter (view-class-slot-db-writer slotdef))
288 (dbtype (specified-type slotdef)))
290 (string (format nil dbwriter val))
291 (function (apply dbwriter (list val)))
295 (database-output-sql-as-type (car dbtype) val database))
297 (database-output-sql-as-type dbtype val database)))))))
299 (defun check-slot-type (slotdef val)
300 (let* ((slot-type (specified-type slotdef))
301 (basetype (if (listp slot-type) (car slot-type) slot-type)))
302 (when (and slot-type val)
303 (unless (typep val basetype)
304 (error 'clsql-type-error
305 :slotname (slot-definition-name slotdef)
310 ;; Called by find-all
313 (defmethod get-slot-values-from-view (obj slotdeflist values)
314 (flet ((update-slot (slot-def values)
315 (update-slot-from-db obj slot-def values)))
316 (mapc #'update-slot slotdeflist values)
319 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
320 (database *default-database*))
321 (let* ((database (or (view-database obj) database))
322 (vct (view-table (class-of obj)))
323 (sd (slotdef-for-slot-with-class slot (class-of obj))))
324 (check-slot-type sd (slot-value obj slot))
325 (let* ((att (view-class-slot-column sd))
326 (val (db-value-from-slot sd (slot-value obj slot) database)))
327 (cond ((and vct sd (view-database obj))
328 (update-records (sql-expression :table vct)
329 :attributes (list (sql-expression :attribute att))
331 :where (key-qualifier-for-instance
332 obj :database database)
334 ((and vct sd (not (view-database obj)))
335 (insert-records :into (sql-expression :table vct)
336 :attributes (list (sql-expression :attribute att))
339 (setf (slot-value obj 'view-database) database))
341 (error "Unable to update record.")))))
344 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
345 (database *default-database*))
346 (let* ((database (or (view-database obj) database))
347 (vct (view-table (class-of obj)))
348 (sds (slotdefs-for-slots-with-class slots (class-of obj)))
349 (avps (mapcar #'(lambda (s)
350 (let ((val (slot-value
351 obj (slot-definition-name s))))
352 (check-slot-type s val)
353 (list (sql-expression
354 :attribute (view-class-slot-column s))
355 (db-value-from-slot s val database))))
357 (cond ((and avps (view-database obj))
358 (update-records (sql-expression :table vct)
360 :where (key-qualifier-for-instance
361 obj :database database)
363 ((and avps (not (view-database obj)))
364 (insert-records :into (sql-expression :table vct)
367 (setf (slot-value obj 'view-database) database))
369 (error "Unable to update records"))))
372 (defmethod update-records-from-instance ((obj standard-db-object)
373 &key (database *default-database*))
374 (let ((database (or (view-database obj) database)))
375 (labels ((slot-storedp (slot)
376 (and (member (view-class-slot-db-kind slot) '(:base :key))
377 (slot-boundp obj (slot-definition-name slot))))
378 (slot-value-list (slot)
379 (let ((value (slot-value obj (slot-definition-name slot))))
380 (check-slot-type slot value)
381 (list (sql-expression :attribute (view-class-slot-column slot))
382 (db-value-from-slot slot value database)))))
383 (let* ((view-class (class-of obj))
384 (view-class-table (view-table view-class))
385 (slots (remove-if-not #'slot-storedp
386 (ordered-class-slots view-class)))
387 (record-values (mapcar #'slot-value-list slots)))
388 (unless record-values
389 (error "No settable slots."))
390 (if (view-database obj)
391 (update-records (sql-expression :table view-class-table)
392 :av-pairs record-values
393 :where (key-qualifier-for-instance
394 obj :database database)
397 (insert-records :into (sql-expression :table view-class-table)
398 :av-pairs record-values
400 (setf (slot-value obj 'view-database) database))))))
403 (defmethod delete-instance-records ((instance standard-db-object))
404 (let ((vt (sql-expression :table (view-table (class-of instance))))
405 (vd (view-database instance)))
407 (let ((qualifier (key-qualifier-for-instance instance :database vd)))
408 (delete-records :from vt :where qualifier :database vd)
409 (setf (slot-value instance 'view-database) nil))
410 (error 'clsql-base::clsql-no-database-error :database nil))))
412 (defmethod update-instance-from-records ((instance standard-db-object)
413 &key (database *default-database*))
414 (let* ((view-class (find-class (class-name (class-of instance))))
415 (view-table (sql-expression :table (view-table view-class)))
416 (vd (or (view-database instance) database))
417 (view-qual (key-qualifier-for-instance instance :database vd))
418 (sels (generate-selection-list view-class))
419 (res (apply #'select (append (mapcar #'cdr sels)
420 (list :from view-table
422 (list :result-types nil)))))
424 (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
426 (defmethod update-slot-from-record ((instance standard-db-object)
427 slot &key (database *default-database*))
428 (let* ((view-class (find-class (class-name (class-of instance))))
429 (view-table (sql-expression :table (view-table view-class)))
430 (vd (or (view-database instance) database))
431 (view-qual (key-qualifier-for-instance instance :database vd))
432 (slot-def (slotdef-for-slot-with-class slot view-class))
433 (att-ref (generate-attribute-reference view-class slot-def))
434 (res (select att-ref :from view-table :where view-qual
437 (get-slot-values-from-view instance (list slot-def) (car res)))))
440 (defmethod update-slot-with-null ((object standard-db-object)
443 (setf (slot-value object slotname) (slot-value slotdef 'void-value)))
445 (defvar +no-slot-value+ '+no-slot-value+)
447 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
448 (let* ((class (find-class classname))
449 (sld (slotdef-for-slot-with-class slot class)))
451 (if (eq value +no-slot-value+)
452 (sql-expression :attribute (view-class-slot-column sld)
453 :table (view-table class))
458 (error "Unknown slot ~A for class ~A" slot classname))))
460 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
461 (declare (ignore database))
462 (let* ((class (find-class classname)))
463 (unless (view-table class)
464 (error "No view-table for class ~A" classname))
465 (sql-expression :table (view-table class))))
467 (defmethod database-get-type-specifier (type args database)
468 (declare (ignore type args))
469 (if (clsql-base::in (database-underlying-type database)
470 :postgresql :postgresql-socket)
474 (defmethod database-get-type-specifier ((type (eql 'integer)) args database)
475 (declare (ignore database))
478 (format nil "INT(~A)" (car args))
482 "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
485 (defmethod database-get-type-specifier ((type (eql 'bigint)) args database)
486 (declare (ignore args database))
489 (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
492 (format nil "VARCHAR(~A)" (car args))
493 (if (clsql-base::in (database-underlying-type database)
494 :postgresql :postgresql-socket)
498 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
501 (format nil "VARCHAR(~A)" (car args))
502 (if (clsql-base::in (database-underlying-type database)
503 :postgresql :postgresql-socket)
507 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
509 (format nil "VARCHAR(~A)" (car args))
510 (if (clsql-base::in (database-underlying-type database)
511 :postgresql :postgresql-socket)
515 (deftype universal-time ()
516 "A positive integer as returned by GET-UNIVERSAL-TIME."
519 (defmethod database-get-type-specifier ((type (eql 'universal-time)) args database)
520 (declare (ignore args database))
523 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
524 (declare (ignore args))
525 (case (database-underlying-type database)
526 ((:postgresql :postgresql-socket)
527 "TIMESTAMP WITHOUT TIME ZONE")
532 (defmethod database-get-type-specifier ((type (eql 'duration)) args database)
533 (declare (ignore database args))
536 (defmethod database-get-type-specifier ((type (eql 'money)) args database)
537 (declare (ignore database args))
540 (deftype raw-string (&optional len)
541 "A string which is not trimmed when retrieved from the database"
544 (defmethod database-get-type-specifier ((type (eql 'raw-string)) args database)
545 (declare (ignore database))
547 (format nil "VARCHAR(~A)" (car args))
550 (defmethod database-get-type-specifier ((type (eql 'float)) args database)
551 (declare (ignore database))
553 (format nil "FLOAT(~A)" (car args))
556 (defmethod database-get-type-specifier ((type (eql 'long-float)) args database)
557 (declare (ignore database))
559 (format nil "FLOAT(~A)" (car args))
562 (defmethod database-get-type-specifier ((type (eql 'boolean)) args database)
563 (declare (ignore args database))
566 (defmethod database-output-sql-as-type (type val database)
567 (declare (ignore type database))
570 (defmethod database-output-sql-as-type ((type (eql 'list)) val database)
571 (declare (ignore database))
572 (progv '(*print-circle* *print-array*) '(t t)
573 (let ((escaped (prin1-to-string val)))
574 (clsql-base::substitute-char-string
575 escaped #\Null " "))))
577 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
578 (declare (ignore database))
583 (package-name (symbol-package val))
588 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database)
589 (declare (ignore database))
594 (defmethod database-output-sql-as-type ((type (eql 'vector)) val database)
595 (declare (ignore database))
596 (progv '(*print-circle* *print-array*) '(t t)
597 (prin1-to-string val)))
599 (defmethod database-output-sql-as-type ((type (eql 'array)) val database)
600 (declare (ignore database))
601 (progv '(*print-circle* *print-array*) '(t t)
602 (prin1-to-string val)))
604 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database)
605 (case (database-underlying-type database)
611 (defmethod database-output-sql-as-type ((type (eql 'string)) val database)
612 (declare (ignore database))
615 (defmethod database-output-sql-as-type ((type (eql 'simple-string))
617 (declare (ignore database))
620 (defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
622 (declare (ignore database))
625 (defmethod read-sql-value (val type database)
626 (declare (ignore type database))
627 (read-from-string val))
629 (defmethod read-sql-value (val (type (eql 'string)) database)
630 (declare (ignore database))
633 (defmethod read-sql-value (val (type (eql 'simple-string)) database)
634 (declare (ignore database))
637 (defmethod read-sql-value (val (type (eql 'simple-base-string)) database)
638 (declare (ignore database))
641 (defmethod read-sql-value (val (type (eql 'raw-string)) database)
642 (declare (ignore database))
645 (defmethod read-sql-value (val (type (eql 'keyword)) database)
646 (declare (ignore database))
647 (when (< 0 (length val))
648 (intern (symbol-name-default-case val)
649 (find-package '#:keyword))))
651 (defmethod read-sql-value (val (type (eql 'symbol)) database)
652 (declare (ignore database))
653 (when (< 0 (length val))
654 (unless (string= val (clsql-base:symbol-name-default-case "NIL"))
655 (intern (clsql-base:symbol-name-default-case val)
656 (symbol-package *update-context*)))))
658 (defmethod read-sql-value (val (type (eql 'integer)) database)
659 (declare (ignore database))
662 (unless (string-equal "NIL" val)
663 (parse-integer val)))
666 (defmethod read-sql-value (val (type (eql 'bigint)) database)
667 (declare (ignore database))
670 (unless (string-equal "NIL" val)
671 (parse-integer val)))
674 (defmethod read-sql-value (val (type (eql 'float)) database)
675 (declare (ignore database))
676 ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
677 (float (read-from-string val)))
679 (defmethod read-sql-value (val (type (eql 'boolean)) database)
680 (case (database-underlying-type database)
683 (string (if (string= "0" val) nil t))
684 (integer (if (zerop val) nil t))))
686 (if (eq :odbc (database-type database))
687 (if (string= "0" val) nil t)
692 (defmethod read-sql-value (val (type (eql 'univeral-time)) database)
693 (declare (ignore database))
694 (unless (eq 'NULL val)
700 (defmethod read-sql-value (val (type (eql 'wall-time)) database)
701 (declare (ignore database))
702 (unless (eq 'NULL val)
703 (parse-timestring val)))
705 (defmethod read-sql-value (val (type (eql 'duration)) database)
706 (declare (ignore database))
707 (unless (or (eq 'NULL val)
709 (parse-timestring val)))
711 ;; ------------------------------------------------------------
712 ;; Logic for 'faulting in' :join slots
714 ;; this works, but is inefficient requiring (+ 1 n-rows)
717 (defun fault-join-target-slot (class object slot-def)
718 (let* ((res (fault-join-slot-raw class object slot-def))
719 (dbi (view-class-slot-db-info slot-def))
720 (target-name (gethash :target-slot dbi))
721 (target-class (find-class target-name)))
723 (mapcar (lambda (obj)
729 (find target-name (class-slots (class-of obj))
730 :key #'slot-definition-name)))
733 #+ignore ;; this doesn't work when attempting to call slot-value
734 (mapcar (lambda (obj)
735 (cons obj (slot-value obj ts))) res))))
737 (defun fault-join-target-slot (class object slot-def)
738 (let* ((dbi (view-class-slot-db-info slot-def))
739 (ts (gethash :target-slot dbi))
740 (jc (gethash :join-class dbi))
741 (tdbi (view-class-slot-db-info
742 (find ts (class-slots (find-class jc))
743 :key #'slot-definition-name)))
744 (retrieval (gethash :retrieval tdbi))
745 (jq (join-qualifier class object slot-def))
746 (key (slot-value object (gethash :home-key dbi))))
752 :inner-join (sql-expression :attribute jc)
755 (sql-expression :attribute (gethash :foreign-key tdbi) :table ts)
756 (sql-expression :attribute (gethash :home-key tdbi) :table jc))
758 :result-types :auto)))
759 (mapcar #'(lambda (i)
760 (let* ((instance (car i))
761 (jcc (make-instance jc :view-database (view-database instance))))
762 (setf (slot-value jcc (gethash :foreign-key dbi))
764 (setf (slot-value jcc (gethash :home-key tdbi))
765 (slot-value instance (gethash :foreign-key tdbi)))
766 (list instance jcc)))
769 ;; just fill in minimal slots
772 (let ((instance (make-instance ts :view-database (view-database object)))
773 (jcc (make-instance jc :view-database (view-database object)))
775 (setf (slot-value instance (gethash :home-key tdbi)) fk)
776 (setf (slot-value jcc (gethash :foreign-key dbi))
778 (setf (slot-value jcc (gethash :home-key tdbi))
780 (list instance jcc)))
781 (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc)
782 :from (sql-expression :table jc)
785 (defun update-object-joins (objects &key (slots t) (force-p t)
786 class-name (max-len *default-update-objects-max-len))
787 "Updates the remote join slots, that is those slots defined without :retrieval :immediate."
790 (class-name (class-of (first object))))
795 (defun fault-join-slot-raw (class object slot-def)
796 (let* ((dbi (view-class-slot-db-info slot-def))
797 (jc (gethash :join-class dbi)))
798 (let ((jq (join-qualifier class object slot-def)))
800 (select jc :where jq :flatp t :result-types nil)))))
802 (defun fault-join-slot (class object slot-def)
803 (let* ((dbi (view-class-slot-db-info slot-def))
804 (ts (gethash :target-slot dbi)))
805 (if (and ts (gethash :set dbi))
806 (fault-join-target-slot class object slot-def)
807 (let ((res (fault-join-slot-raw class object slot-def)))
810 ((and ts (not (gethash :set dbi)))
811 (mapcar (lambda (obj) (slot-value obj ts)) res))
812 ((and (not ts) (not (gethash :set dbi)))
814 ((and (not ts) (gethash :set dbi))
817 (defun join-qualifier (class object slot-def)
818 (declare (ignore class))
819 (let* ((dbi (view-class-slot-db-info slot-def))
820 (jc (find-class (gethash :join-class dbi)))
821 ;;(ts (gethash :target-slot dbi))
822 ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
823 (foreign-keys (gethash :foreign-key dbi))
824 (home-keys (gethash :home-key dbi)))
825 (when (every #'(lambda (slt)
826 (and (slot-boundp object slt)
827 (not (null (slot-value object slt)))))
828 (if (listp home-keys) home-keys (list home-keys)))
830 (mapcar #'(lambda (hk fk)
831 (let ((fksd (slotdef-for-slot-with-class fk jc)))
837 (view-class-slot-column fksd)
838 :table (view-table jc)))
842 (slot-value object hk))
845 (if (listp home-keys)
848 (if (listp foreign-keys)
850 (list foreign-keys)))))
852 (if (> (length jc) 1)
856 (defun find-all (view-classes
858 &key all set-operation distinct from where group-by having
859 order-by order-by-descending offset limit refresh
860 flatp result-types inner-join on
861 (database *default-database*))
862 "Called by SELECT to generate object query results when the
863 View Classes VIEW-CLASSES are passed as arguments to SELECT."
864 (declare (ignore all set-operation group-by having offset limit inner-join on)
865 (optimize (debug 3) (speed 1)))
868 (remf args :additional-fields)
869 (remf args :result-types)
870 (labels ((table-sql-expr (table)
871 (sql-expression :table (view-table table)))
872 (ref-equal (ref1 ref2)
875 (tables-equal (table-a table-b)
876 (string= (string (slot-value table-a 'name))
877 (string (slot-value table-b 'name))))
878 (build-object (vals vclass selects)
879 (let* ((class-name (class-name vclass))
880 (db-vals (butlast vals (- (list-length vals)
881 (list-length selects))))
882 (obj (make-instance class-name :view-database database)))
883 ;; use refresh keyword here
884 (setf obj (get-slot-values-from-view obj (mapcar #'car selects)
886 (when refresh (instance-refreshed obj))
888 (build-objects (vals sclasses sels)
889 (let ((objects (mapcar #'(lambda (sclass sel)
890 (prog1 (build-object vals sclass sel)
891 (setf vals (nthcdr (list-length sel)
894 (if (and flatp (= (length sclasses) 1))
897 (let* ((*db-deserializing* t)
898 (sclasses (mapcar #'find-class view-classes))
899 (sels (mapcar #'generate-selection-list sclasses))
900 (fullsels (apply #'append sels))
901 (sel-tables (collect-table-refs where))
902 (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
904 :test #'tables-equal))
906 (dolist (ob (listify order-by))
907 (when (and ob (not (member ob (mapcar #'cdr fullsels)
910 (append fullsels (mapcar #'(lambda (att) (cons nil att))
912 (dolist (ob (listify order-by-descending))
913 (when (and ob (not (member ob (mapcar #'cdr fullsels)
916 (append fullsels (mapcar #'(lambda (att) (cons nil att))
918 (dolist (ob (listify distinct))
919 (when (and (typep ob 'sql-ident)
920 (not (member ob (mapcar #'cdr fullsels)
923 (append fullsels (mapcar #'(lambda (att) (cons nil att))
927 (append (mapcar #'cdr fullsels)
929 (list (append (when from (listify from))
931 (list :result-types result-types)
933 (mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
935 (defmethod instance-refreshed ((instance standard-db-object)))
937 (defun select (&rest select-all-args)
938 "The function SELECT selects data from DATABASE, which has a
939 default value of *DEFAULT-DATABASE*, given the constraints
940 specified by the rest of the ARGS. It returns a list of objects
941 as specified by SELECTIONS. By default, the objects will each be
942 represented as lists of attribute values. The argument SELECTIONS
943 consists either of database identifiers, type-modified database
944 identifiers or literal strings. A type-modifed database
945 identifier is an expression such as [foo :string] which means
946 that the values in column foo are returned as Lisp strings. The
947 FLATP argument, which has a default value of nil, specifies if
948 full bracketed results should be returned for each matched
949 entry. If FLATP is nil, the results are returned as a list of
950 lists. If FLATP is t, the results are returned as elements of a
951 list, only if there is only one result per row. The arguments
952 ALL, SET-OPERATION, DISTINCT, FROM, WHERE, GROUP-BY, HAVING and
953 ORDER-by have the same function as the equivalent SQL expression.
954 The SELECT function is common across both the functional and
955 object-oriented SQL interfaces. If selections refers to View
956 Classes then the select operation becomes object-oriented. This
957 means that SELECT returns a list of View Class instances, and
958 SLOT-VALUE becomes a valid SQL operator for use within the where
959 clause. In the View Class case, a second equivalent select call
960 will return the same View Class instance objects. If REFRESH is
961 true, then existing instances are updated if necessary, and in
962 this case you might need to extend the hook INSTANCE-REFRESHED.
963 The default value of REFRESH is nil. SQL expressions used in the
964 SELECT function are specified using the square bracket syntax,
965 once this syntax has been enabled using
966 ENABLE-SQL-READER-SYNTAX."
968 (flet ((select-objects (target-args)
970 (every #'(lambda (arg)
972 (find-class arg nil)))
974 (multiple-value-bind (target-args qualifier-args)
975 (query-get-selections select-all-args)
976 (if (select-objects target-args)
977 (apply #'find-all target-args qualifier-args)
978 (let* ((expr (apply #'make-query select-all-args))
980 (mapcar #'(lambda (attrib)
981 (if (typep attrib 'sql-ident-attribute)
982 (let ((type (slot-value attrib 'type)))
987 (slot-value expr 'selections))))
988 (destructuring-bind (&key (flatp nil)
991 (database *default-database*)
994 (query expr :flatp flatp
996 ;; specifying a type for an attribute overrides result-types
997 (if (some #'(lambda (x) (not (eq t x))) specified-types)
1000 :field-names field-names
1001 :database database)))))))