X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fobjects.lisp;h=63cef6a2d27f97dc394b78d645bc76165704cd74;hp=ce6022c131130cc7ced8137419c468c8ee77c071;hb=21ae7203d719886a1f044992e463d5f463727ac0;hpb=8a8ee2d7d791b7a3efaed06420802a925d16fca3 diff --git a/sql/objects.lisp b/sql/objects.lisp index ce6022c..63cef6a 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -72,9 +72,8 @@ (defun create-view-from-class (view-class-name &key (database *default-database*)) - "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines -the view. The argument DATABASE has a default value of -*DEFAULT-DATABASE*." + "Creates a table as defined by the View Class VIEW-CLASS-NAME +in DATABASE which defaults to *DEFAULT-DATABASE*." (let ((tclass (find-class view-class-name))) (if tclass (let ((*default-database* database)) @@ -90,7 +89,7 @@ the view. The argument DATABASE has a default value of (push res schemadef)))) (unless schemadef (error "Class ~s has no :base slots" self)) - (create-table (sql-expression :table (view-table self)) schemadef + (create-table (sql-expression :table (view-table self)) (nreverse schemadef) :database database :constraints (database-pkey-constraint self database)) (push self (database-view-classes database)) @@ -123,9 +122,8 @@ the view. The argument DATABASE has a default value of ;; (defun drop-view-from-class (view-class-name &key (database *default-database*)) - "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME -which defines that view. The argument DATABASE has a default value of -*DEFAULT-DATABASE*." + "Removes a table defined by the View Class VIEW-CLASS-NAME from +DATABASE which defaults to *DEFAULT-DATABASE*." (let ((tclass (find-class view-class-name))) (if tclass (let ((*default-database* database)) @@ -148,12 +146,10 @@ which defines that view. The argument DATABASE has a default value of (defun list-classes (&key (test #'identity) (root-class (find-class 'standard-db-object)) (database *default-database*)) - "The LIST-CLASSES function collects all the classes below -ROOT-CLASS, which defaults to standard-db-object, that are connected -to the supplied DATABASE and which satisfy the TEST function. The -default for the TEST argument is identity. By default, LIST-CLASSES -returns a list of all the classes connected to the default database, -*DEFAULT-DATABASE*." + "Returns a list of all the View Classes which are connected to +DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend +from the class ROOT-CLASS and which satisfy the function TEST. By +default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY." (flet ((find-superclass (class) (member root-class (class-precedence-list class)))) (let ((view-classes (and database (database-view-classes database)))) @@ -167,17 +163,40 @@ returns a list of all the classes connected to the default database, ;; (defmacro def-view-class (class supers slots &rest cl-options) - "Extends the syntax of defclass to allow special slots to be mapped -onto the attributes of database views. The macro DEF-VIEW-CLASS -creates a class called CLASS which maps onto a database view. Such a -class is called a View Class. The macro DEF-VIEW-CLASS extends the -syntax of DEFCLASS to allow special base slots to be mapped onto the -attributes of database views (presently single tables). When a select -query that names a View Class is submitted, then the corresponding -database view is queried, and the slots in the resulting View Class -instances are filled with attribute values from the database. If -SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the -superclass of the newly-defined View Class." + "Creates a View Class called CLASS whose slots SLOTS can map +onto the attributes of a table in a database. If SUPERS is nil +then the superclass of CLASS will be STANDARD-DB-OBJECT, +otherwise SUPERS is a list of superclasses for CLASS which must +include STANDARD-DB-OBJECT or a descendent of this class. The +syntax of DEFCLASS is extended through the addition of a class +option :base-table which defines the database table onto which +the View Class maps and which defaults to CLASS. The DEFCLASS +syntax is also extended through additional slot +options. The :db-kind slot option specifies the kind of DB +mapping which is performed for this slot and defaults to :base +which indicates that the slot maps to an ordinary column of the +database table. A :db-kind value of :key indicates that this slot +is a special kind of :base slot which maps onto a column which is +one of the unique keys for the database table, the value :join +indicates this slot represents a join onto another View Class +which contains View Class objects, and the value :virtual +indicates a standard CLOS slot which does not map onto columns of +the database table. If a slot is specified with :db-kind :join, +the slot option :db-info contains a list which specifies the +nature of the join. For slots of :db-kind :base or :key, +the :type slot option has a special interpretation such that Lisp +types, such as string, integer and float are automatically +converted into appropriate SQL types for the column onto which +the slot maps. This behaviour may be over-ridden using +the :db-type slot option which is a string specifying the +vendor-specific database type for this slot's column definition +in the database. The :column slot option specifies the name of +the SQL column which the slot maps onto, if :db-kind is +not :virtual, and defaults to the slot name. The :void-value slot +option specifies the value to store if the SQL value is NULL and +defaults to NIL. The :db-constraints slot option is a string +representing an SQL table constraint expression or a list of such +strings." `(progn (defclass ,class ,supers ,slots ,@(if (find :metaclass `,cl-options :key #'car) @@ -272,8 +291,10 @@ superclass of the newly-defined View Class." (cond ((and value (null slot-reader)) (setf (slot-value instance slot-name) (read-sql-value value (delistify slot-type) - (view-database instance)))) - ((null value) + (view-database instance) + (database-underlying-type + (view-database instance))))) + ((null value) (update-slot-with-null instance slot-name slotdef)) ((typep slot-reader 'string) (setf (slot-value instance slot-name) @@ -289,7 +310,8 @@ superclass of the newly-defined View Class." (let ((slot-reader (view-class-slot-db-reader slotdef)) (slot-type (specified-type slotdef))) (cond ((and value (null slot-reader)) - (read-sql-value value (delistify slot-type) database)) + (read-sql-value value (delistify slot-type) database + (database-underlying-type database))) ((null value) nil) ((typep slot-reader 'string) @@ -306,21 +328,21 @@ superclass of the newly-defined View Class." (string (format nil dbwriter val)) (function (apply dbwriter (list val))) (t - (typecase dbtype - (cons - (database-output-sql-as-type (car dbtype) val database)) - (t - (database-output-sql-as-type dbtype val database))))))) + (database-output-sql-as-type + (typecase dbtype + (cons (car dbtype)) + (t dbtype)) + val database (database-underlying-type database)))))) (defun check-slot-type (slotdef val) (let* ((slot-type (specified-type slotdef)) (basetype (if (listp slot-type) (car slot-type) slot-type))) (when (and slot-type val) (unless (typep val basetype) - (error 'clsql-type-error - :slotname (slot-definition-name slotdef) - :typespec slot-type - :value val))))) + (error 'sql-user-error + :message + (format nil "Invalid value ~A in slot ~A, not of type ~A." + val (slot-definition-name slotdef) slot-type)))))) ;; ;; Called by find-all @@ -423,7 +445,7 @@ superclass of the newly-defined View Class." (let ((qualifier (key-qualifier-for-instance instance :database vd))) (delete-records :from vt :where qualifier :database vd) (setf (slot-value instance 'view-database) nil)) - (error 'clsql-no-database-error :database nil)))) + (signal-no-database-error vd)))) (defmethod update-instance-from-records ((instance standard-db-object) &key (database *default-database*)) @@ -480,16 +502,12 @@ superclass of the newly-defined View Class." (error "No view-table for class ~A" classname)) (sql-expression :table (view-table class)))) -(defmethod database-get-type-specifier (type args database) - (declare (ignore type args)) - (if (in (database-underlying-type database) - :postgresql :postgresql-socket) - "VARCHAR" - "VARCHAR(255)")) +(defmethod database-get-type-specifier (type args database db-type) + (declare (ignore type args database db-type)) + "VARCHAR(255)") -(defmethod database-get-type-specifier ((type (eql 'integer)) args database) - (declare (ignore database)) - ;;"INT8") +(defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type) + (declare (ignore database db-type)) (if args (format nil "INT(~A)" (car args)) "INT")) @@ -498,100 +516,89 @@ superclass of the newly-defined View Class." "An integer larger than a 32-bit integer, this width may vary by SQL implementation." 'integer) -(defmethod database-get-type-specifier ((type (eql 'bigint)) args database) - (declare (ignore args database)) +(defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type) + (declare (ignore args database db-type)) "BIGINT") (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args - database) + database db-type) + (declare (ignore database db-type)) (if args (format nil "VARCHAR(~A)" (car args)) - (if (in (database-underlying-type database) - :postgresql :postgresql-socket) - "VARCHAR" - "VARCHAR(255)"))) + "VARCHAR(255)")) (defmethod database-get-type-specifier ((type (eql 'simple-string)) args - database) + database db-type) + (declare (ignore database db-type)) (if args (format nil "VARCHAR(~A)" (car args)) - (if (in (database-underlying-type database) - :postgresql :postgresql-socket) - "VARCHAR" - "VARCHAR(255)"))) + "VARCHAR(255)")) -(defmethod database-get-type-specifier ((type (eql 'string)) args database) +(defmethod database-get-type-specifier ((type (eql 'string)) args database db-type) + (declare (ignore database db-type)) (if args (format nil "VARCHAR(~A)" (car args)) - (if (in (database-underlying-type database) - :postgresql :postgresql-socket) - "VARCHAR" - "VARCHAR(255)"))) + "VARCHAR(255)")) (deftype universal-time () "A positive integer as returned by GET-UNIVERSAL-TIME." '(integer 1 *)) -(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database) - (declare (ignore args database)) +(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database db-type) + (declare (ignore args database db-type)) "BIGINT") -(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database) - (declare (ignore args)) - (case (database-underlying-type database) - ((:postgresql :postgresql-socket) - "TIMESTAMP WITHOUT TIME ZONE") - (:mysql - "DATETIME") - (t "TIMESTAMP"))) - -(defmethod database-get-type-specifier ((type (eql 'duration)) args database) - (declare (ignore database args)) +(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database db-type) + (declare (ignore args database db-type)) + "TIMESTAMP") + +(defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type) + (declare (ignore database args db-type)) "VARCHAR") -(defmethod database-get-type-specifier ((type (eql 'money)) args database) - (declare (ignore database args)) +(defmethod database-get-type-specifier ((type (eql 'money)) args database db-type) + (declare (ignore database args db-type)) "INT8") (deftype raw-string (&optional len) "A string which is not trimmed when retrieved from the database" `(string ,len)) -(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database) - (declare (ignore database)) +(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database db-type) + (declare (ignore database db-type)) (if args (format nil "VARCHAR(~A)" (car args)) "VARCHAR")) -(defmethod database-get-type-specifier ((type (eql 'float)) args database) - (declare (ignore database)) +(defmethod database-get-type-specifier ((type (eql 'float)) args database db-type) + (declare (ignore database db-type)) (if args (format nil "FLOAT(~A)" (car args)) "FLOAT")) -(defmethod database-get-type-specifier ((type (eql 'long-float)) args database) - (declare (ignore database)) +(defmethod database-get-type-specifier ((type (eql 'long-float)) args database db-type) + (declare (ignore database db-type)) (if args (format nil "FLOAT(~A)" (car args)) "FLOAT")) -(defmethod database-get-type-specifier ((type (eql 'boolean)) args database) - (declare (ignore args database)) +(defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type) + (declare (ignore args database db-type)) "BOOL") -(defmethod database-output-sql-as-type (type val database) - (declare (ignore type database)) +(defmethod database-output-sql-as-type (type val database db-type) + (declare (ignore type database db-type)) val) -(defmethod database-output-sql-as-type ((type (eql 'list)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'list)) val database db-type) + (declare (ignore database db-type)) (progv '(*print-circle* *print-array*) '(t t) (let ((escaped (prin1-to-string val))) (substitute-char-string escaped #\Null " ")))) -(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type) + (declare (ignore database db-type)) (if (keywordp val) (symbol-name val) (if val @@ -601,125 +608,117 @@ superclass of the newly-defined View Class." (symbol-name val)) ""))) -(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type) + (declare (ignore database db-type)) (if val (symbol-name val) "")) -(defmethod database-output-sql-as-type ((type (eql 'vector)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'vector)) val database db-type) + (declare (ignore database db-type)) (progv '(*print-circle* *print-array*) '(t t) (prin1-to-string val))) -(defmethod database-output-sql-as-type ((type (eql 'array)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'array)) val database db-type) + (declare (ignore database db-type)) (progv '(*print-circle* *print-array*) '(t t) (prin1-to-string val))) -(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database) - (case (database-underlying-type database) - (:mysql - (if val 1 0)) - (t - (if val "t" "f")))) +(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database db-type) + (declare (ignore database db-type)) + (if val "t" "f")) -(defmethod database-output-sql-as-type ((type (eql 'string)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type) + (declare (ignore database db-type)) val) (defmethod database-output-sql-as-type ((type (eql 'simple-string)) - val database) - (declare (ignore database)) + val database db-type) + (declare (ignore database db-type)) val) (defmethod database-output-sql-as-type ((type (eql 'simple-base-string)) - val database) - (declare (ignore database)) + val database db-type) + (declare (ignore database db-type)) val) -(defmethod read-sql-value (val type database) - (declare (ignore type database)) +(defmethod read-sql-value (val type database db-type) + (declare (ignore type database db-type)) (read-from-string val)) -(defmethod read-sql-value (val (type (eql 'string)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'string)) database db-type) + (declare (ignore database db-type)) val) -(defmethod read-sql-value (val (type (eql 'simple-string)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'simple-string)) database db-type) + (declare (ignore database db-type)) val) -(defmethod read-sql-value (val (type (eql 'simple-base-string)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'simple-base-string)) database db-type) + (declare (ignore database db-type)) val) -(defmethod read-sql-value (val (type (eql 'raw-string)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'raw-string)) database db-type) + (declare (ignore database db-type)) val) -(defmethod read-sql-value (val (type (eql 'keyword)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'keyword)) database db-type) + (declare (ignore database db-type)) (when (< 0 (length val)) (intern (symbol-name-default-case val) (find-package '#:keyword)))) -(defmethod read-sql-value (val (type (eql 'symbol)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'symbol)) database db-type) + (declare (ignore database db-type)) (when (< 0 (length val)) (unless (string= val (symbol-name-default-case "NIL")) (intern (symbol-name-default-case val) (symbol-package *update-context*))))) -(defmethod read-sql-value (val (type (eql 'integer)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'integer)) database db-type) + (declare (ignore database db-type)) (etypecase val (string (unless (string-equal "NIL" val) (parse-integer val))) (number val))) -(defmethod read-sql-value (val (type (eql 'bigint)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'bigint)) database db-type) + (declare (ignore database db-type)) (etypecase val (string (unless (string-equal "NIL" val) (parse-integer val))) (number val))) -(defmethod read-sql-value (val (type (eql 'float)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'float)) database db-type) + (declare (ignore database db-type)) ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...) - (float (read-from-string val))) - -(defmethod read-sql-value (val (type (eql 'boolean)) database) - (case (database-underlying-type database) - (:mysql - (etypecase val - (string (if (string= "0" val) nil t)) - (integer (if (zerop val) nil t)))) - (:postgresql - (if (eq :odbc (database-type database)) - (if (string= "0" val) nil t) - (equal "t" val))) - (t - (equal "t" val)))) - -(defmethod read-sql-value (val (type (eql 'univeral-time)) database) - (declare (ignore database)) + (etypecase val + (string + (float (read-from-string val))) + (float + val))) + +(defmethod read-sql-value (val (type (eql 'boolean)) database db-type) + (declare (ignore database db-type)) + (equal "t" val)) + +(defmethod read-sql-value (val (type (eql 'univeral-time)) database db-type) + (declare (ignore database db-type)) (unless (eq 'NULL val) (etypecase val (string (parse-integer val)) (number val)))) -(defmethod read-sql-value (val (type (eql 'wall-time)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'wall-time)) database db-type) + (declare (ignore database db-type)) (unless (eq 'NULL val) (parse-timestring val))) -(defmethod read-sql-value (val (type (eql 'duration)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'duration)) database db-type) + (declare (ignore database db-type)) (unless (or (eq 'NULL val) (equal "NIL" val)) (parse-timestring val))) @@ -804,18 +803,82 @@ superclass of the newly-defined View Class." :from (sql-expression :table jc-view-table) :where jq))))))) -(defun update-object-joins (objects &key (slots t) (force-p t) - class-name (max-len *default-update-objects-max-len*)) - "Updates the remote join slots, that is those slots defined without :retrieval :immediate." + +;;; Remote Joins + +(defvar *default-update-objects-max-len* nil + "The default value to use for the MAX-LEN keyword argument to + UPDATE-OBJECT-JOINS.") + +(defun update-objects-joins (objects &key (slots t) (force-p t) + class-name (max-len + *default-update-objects-max-len*)) + "Updates from the records of the appropriate database tables +the join slots specified by SLOTS in the supplied list of View +Class instances OBJECTS. SLOTS is t by default which means that +all join slots with :retrieval :immediate are updated. CLASS-NAME +is used to specify the View Class of all instance in OBJECTS and +default to nil which means that the class of the first instance +in OBJECTS is used. FORCE-P is t by default which means that all +join slots are updated whereas a value of nil means that only +unbound join slots are updated. MAX-LEN defaults to +*DEFAULT-UPDATE-OBJECTS-MAX-LEN* and when non-nil specifies that +UPDATE-OBJECT-JOINS may issue multiple database queries with a +maximum of MAX-LEN instances updated in each query." + (assert (or (null max-len) (plusp max-len))) (when objects (unless class-name - (class-name (class-of (first objects)))) + (setq class-name (class-name (class-of (first objects))))) (let* ((class (find-class class-name)) - (deferred-joins (generate-retrieval-joins-list class :deferred))) - (when deferred-joins - (warn "not yet implemented.") - )))) - + (class-slots (ordered-class-slots class)) + (slotdefs + (if (eq t slots) + (generate-retrieval-joins-list class :deferred) + (remove-if #'null + (mapcar #'(lambda (name) + (let ((slotdef (find name class-slots :key #'slot-definition-name))) + (unless slotdef + (warn "Unable to find slot named ~S in class ~S." name class)) + slotdef)) + slots))))) + (dolist (slotdef slotdefs) + (let* ((dbi (view-class-slot-db-info slotdef)) + (slotdef-name (slot-definition-name slotdef)) + (foreign-key (gethash :foreign-key dbi)) + (home-key (gethash :home-key dbi)) + (object-keys + (remove-duplicates + (if force-p + (mapcar #'(lambda (o) (slot-value o home-key)) objects) + (remove-if #'null + (mapcar + #'(lambda (o) (if (slot-boundp o slotdef-name) + nil + (slot-value o home-key))) + objects))))) + (n-object-keys (length object-keys)) + (query-len (or max-len n-object-keys))) + + (do ((i 0 (+ i query-len))) + ((>= i n-object-keys)) + (let* ((keys (if max-len + (subseq object-keys i (min (+ i query-len) n-object-keys)) + object-keys)) + (results (find-all (list (gethash :join-class dbi)) + :where (make-instance 'sql-relational-exp + :operator 'in + :sub-expressions (list (sql-expression :attribute foreign-key) + keys)) + :result-types :auto + :flatp t))) + (dolist (object objects) + (when (or force-p (not (slot-boundp object slotdef-name))) + (let ((res (find (slot-value object home-key) results + :key #'(lambda (res) (slot-value res foreign-key)) + :test #'equal))) + (when res + (setf (slot-value object slotdef-name) res))))))))))) + (values)) (defun fault-join-slot-raw (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) @@ -882,49 +945,51 @@ superclass of the newly-defined View Class." ;; For example, for (select 'employee-address) in test suite => ;; select addr.*,ea_join.* FROM addr,ea_join WHERE ea_join.aaddressid=addr.addressid\g -(defun build-objects (vals sclasses immediate-join-classes sels immediate-joins database refresh flatp) +(defun build-objects (vals sclasses immediate-join-classes sels immediate-joins database refresh flatp instances) "Used by find-all to build objects." - (labels ((build-object (vals vclass jclasses selects immediate-selects) - (let* ((class-name (class-name vclass)) - (db-vals (butlast vals (- (list-length vals) + (labels ((build-object (vals vclass jclasses selects immediate-selects instance) + (let* ((db-vals (butlast vals (- (list-length vals) (list-length selects)))) + (obj (if instance instance (make-instance (class-name vclass) :view-database database))) (join-vals (subseq vals (list-length selects))) - (obj (make-instance class-name :view-database database)) (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database))) jclasses))) ;;(format t "db-vals: ~S, join-values: ~S~%" db-vals join-vals) ;; use refresh keyword here - (setf obj (get-slot-values-from-view obj (mapcar #'car selects) - db-vals)) + (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals)) (mapc #'(lambda (jc) (get-slot-values-from-view jc (mapcar #'car immediate-selects) join-vals)) joins) (mapc - #'(lambda (jc) (let ((slot (find (class-name (class-of jc)) (class-slots vclass) - :key #'(lambda (slot) (when (and (eq :join (view-class-slot-db-kind slot)) - (eq (slot-definition-name slot) - (gethash :join-class (view-class-slot-db-info slot)))) - (slot-definition-name slot)))))) - (when slot - (setf (slot-value obj (slot-definition-name slot)) jc)))) - + #'(lambda (jc) + (let ((slot (find (class-name (class-of jc)) (class-slots vclass) + :key #'(lambda (slot) + (when (and (eq :join (view-class-slot-db-kind slot)) + (eq (slot-definition-name slot) + (gethash :join-class (view-class-slot-db-info slot)))) + (slot-definition-name slot)))))) + (when slot + (setf (slot-value obj (slot-definition-name slot)) jc)))) joins) (when refresh (instance-refreshed obj)) obj))) - (let ((objects (mapcar #'(lambda (sclass jclass sel immediate-join) - (prog1 (build-object vals sclass jclass sel immediate-join) - (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join)) - vals)))) - sclasses immediate-join-classes sels immediate-joins))) + (let* ((objects + (mapcar #'(lambda (sclass jclass sel immediate-join instance) + (prog1 + (build-object vals sclass jclass sel immediate-join instance) + (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join)) + vals)))) + sclasses immediate-join-classes sels immediate-joins instances))) (if (and flatp (= (length sclasses) 1)) (car objects) - objects)))) + objects)))) (defun find-all (view-classes &rest args &key all set-operation distinct from where group-by having - order-by order-by-descending offset limit refresh - flatp result-types inner-join on - (database *default-database*)) + order-by offset limit refresh flatp result-types + inner-join on + (database *default-database*) + instances) "Called by SELECT to generate object query results when the View Classes VIEW-CLASSES are passed as arguments to SELECT." (declare (ignore all set-operation group-by having offset limit inner-join on) @@ -943,14 +1008,17 @@ superclass of the newly-defined View Class." (remf args :flatp) (remf args :additional-fields) (remf args :result-types) + (remf args :instances) (let* ((*db-deserializing* t) (sclasses (mapcar #'find-class view-classes)) - (immediate-join-slots (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses)) - (immediate-join-classes (mapcar #'(lambda (jcs) - (mapcar #'(lambda (slotdef) - (find-class (gethash :join-class (view-class-slot-db-info slotdef)))) - jcs)) - immediate-join-slots)) + (immediate-join-slots + (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses)) + (immediate-join-classes + (mapcar #'(lambda (jcs) + (mapcar #'(lambda (slotdef) + (find-class (gethash :join-class (view-class-slot-db-info slotdef)))) + jcs)) + immediate-join-slots)) (immediate-join-sels (mapcar #'generate-immediate-joins-selection-list sclasses)) (sels (mapcar #'generate-selection-list sclasses)) (fullsels (apply #'append (mapcar #'append sels immediate-join-sels))) @@ -963,19 +1031,16 @@ superclass of the newly-defined View Class." jcs)) immediate-join-classes) sel-tables) - :test #'tables-equal)))) - (dolist (ob (listify order-by)) + :test #'tables-equal))) + (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob))) + (listify order-by)))) + + (dolist (ob order-by-slots) (when (and ob (not (member ob (mapcar #'cdr fullsels) :test #'ref-equal))) (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) - (dolist (ob (listify order-by-descending)) - (when (and ob (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) + (append fullsels (mapcar #'(lambda (att) (cons nil att)) + order-by-slots))))) (dolist (ob (listify distinct)) (when (and (typep ob 'sql-ident) (not (member ob (mapcar #'cdr fullsels) @@ -1008,44 +1073,70 @@ superclass of the newly-defined View Class." (list :result-types result-types) (when where (list :where where)) args))) + (instances-to-add (- (length rows) (length instances))) + (perhaps-extended-instances + (if (plusp instances-to-add) + (append instances (do ((i 0 (1+ i)) + (res nil)) + ((= i instances-to-add) res) + (push (make-list (length sclasses) :initial-element nil) res))) + instances)) (objects (mapcar - #'(lambda (r) - (build-objects r sclasses immediate-join-classes sels immediate-join-sels database refresh flatp)) - rows))) + #'(lambda (row instance) + (build-objects row sclasses immediate-join-classes sels + immediate-join-sels database refresh flatp + (if (and flatp (atom instance)) + (list instance) + instance))) + rows perhaps-extended-instances))) objects)))) (defmethod instance-refreshed ((instance standard-db-object))) (defun select (&rest select-all-args) - "The function SELECT selects data from DATABASE, which has a -default value of *DEFAULT-DATABASE*, given the constraints -specified by the rest of the ARGS. It returns a list of objects -as specified by SELECTIONS. By default, the objects will each be -represented as lists of attribute values. The argument SELECTIONS -consists either of database identifiers, type-modified database -identifiers or literal strings. A type-modifed database -identifier is an expression such as [foo :string] which means -that the values in column foo are returned as Lisp strings. The -FLATP argument, which has a default value of nil, specifies if -full bracketed results should be returned for each matched -entry. If FLATP is nil, the results are returned as a list of -lists. If FLATP is t, the results are returned as elements of a -list, only if there is only one result per row. The arguments -ALL, SET-OPERATION, DISTINCT, FROM, WHERE, GROUP-BY, HAVING and -ORDER-by have the same function as the equivalent SQL expression. -The SELECT function is common across both the functional and -object-oriented SQL interfaces. If selections refers to View -Classes then the select operation becomes object-oriented. This -means that SELECT returns a list of View Class instances, and -SLOT-VALUE becomes a valid SQL operator for use within the where -clause. In the View Class case, a second equivalent select call -will return the same View Class instance objects. If REFRESH is -true, then existing instances are updated if necessary, and in -this case you might need to extend the hook INSTANCE-REFRESHED. -The default value of REFRESH is nil. SQL expressions used in the -SELECT function are specified using the square bracket syntax, -once this syntax has been enabled using -ENABLE-SQL-READER-SYNTAX." + "Executes a query on DATABASE, which has a default value of +*DEFAULT-DATABASE*, specified by the SQL expressions supplied +using the remaining arguments in SELECT-ALL-ARGS. The SELECT +argument can be used to generate queries in both functional and +object oriented contexts. + +In the functional case, the required arguments specify the +columns selected by the query and may be symbolic SQL expressions +or strings representing attribute identifiers. Type modified +identifiers indicate that the values selected from the specified +column are converted to the specified lisp type. The keyword +arguments ALL, DISTINCT, FROM, GROUP-by, HAVING, ORDER-BY, +SET-OPERATION and WHERE are used to specify, using the symbolic +SQL syntax, the corresponding components of the SQL query +generated by the call to SELECT. RESULT-TYPES is a list of +symbols which specifies the lisp type for each field returned by +the query. If RESULT-TYPES is nil all results are returned as +strings whereas the default value of :auto means that the lisp +types are automatically computed for each field. FIELD-NAMES is t +by default which means that the second value returned is a list +of strings representing the columns selected by the query. If +FIELD-NAMES is nil, the list of column names is not returned as a +second value. + +In the object oriented case, the required arguments to SELECT are +symbols denoting View Classes which specify the database tables +to query. In this case, SELECT returns a list of View Class +instances whose slots are set from the attribute values of the +records in the specified table. Slot-value is a legal operator +which can be employed as part of the symbolic SQL syntax used in +the WHERE keyword argument to SELECT. REFRESH is nil by default +which means that the View Class instances returned are retrieved +from a cache if an equivalent call to SELECT has previously been +issued. If REFRESH is true, the View Class instances returned are +updated as necessary from the database and the generic function +INSTANCE-REFRESHED is called to perform any necessary operations +on the updated instances. + +In both object oriented and functional contexts, FLATP has a +default value of nil which means that the results are returned as +a list of lists. If FLATP is t and only one result is returned +for each record selected in the query, the results are returned +as elements of a list." (flet ((select-objects (target-args) (and target-args @@ -1055,25 +1146,54 @@ ENABLE-SQL-READER-SYNTAX." target-args)))) (multiple-value-bind (target-args qualifier-args) (query-get-selections select-all-args) + (unless (or *default-database* (getf qualifier-args :database)) + (signal-no-database-error nil)) + (cond ((select-objects target-args) - (let ((caching (getf qualifier-args :caching)) - (refresh (getf qualifier-args :refresh)) - (database (or (getf qualifier-args :database) *default-database*))) + (let ((caching (getf qualifier-args :caching t)) + (result-types (getf qualifier-args :result-types :auto)) + (refresh (getf qualifier-args :refresh nil)) + (database (or (getf qualifier-args :database) *default-database*)) + (order-by (getf qualifier-args :order-by))) (remf qualifier-args :caching) (remf qualifier-args :refresh) + (remf qualifier-args :result-types) + + + ;; Add explicity table name to order-by if not specified and only + ;; one selected table. This is required so FIND-ALL won't duplicate + ;; the field + (when (and order-by (= 1 (length target-args))) + (let ((table-name (view-table (find-class (car target-args)))) + (order-by-list (copy-seq (listify order-by)))) + + (loop for i from 0 below (length order-by-list) + do (etypecase (nth i order-by-list) + (sql-ident-attribute + (unless (slot-value (nth i order-by-list) 'qualifier) + (setf (slot-value (nth i order-by-list) 'qualifier) table-name))) + (cons + (unless (slot-value (car (nth i order-by-list)) 'qualifier) + (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name))))) + (setf (getf qualifier-args :order-by) order-by-list))) + (cond ((null caching) - (apply #'find-all target-args qualifier-args)) + (apply #'find-all target-args + (append qualifier-args (list :result-types result-types)))) (t (let ((cached (records-cache-results target-args qualifier-args database))) (cond ((and cached (not refresh)) cached) ((and cached refresh) - (update-cached-results target-args qualifier-args database)) + (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto))))) + (setf (records-cache-results target-args qualifier-args database) results) + results)) (t - (let ((results (apply #'find-all target-args qualifier-args))) + (let ((results (apply #'find-all target-args (append qualifier-args + '(:result-types :auto))))) (setf (records-cache-results target-args qualifier-args database) results) results)))))))) (t @@ -1112,6 +1232,7 @@ ENABLE-SQL-READER-SYNTAX." (when value (push (list arg (typecase value + (cons (cons (sql (car value)) (cdr value))) (%sql-expression (sql value)) (t value))) results))))))