X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=38c5f498ace16816ff1556eb09bd6bb28019150f;hb=a4097e19c5157e87b9991549bc44f3ef598aeb90;hp=1991b70c151f6e9b86f2781dc7ccf29ee3fde70b;hpb=5a6f424f3c8920f8f11bbf1e3aed6b4c2c7e6af8;p=clsql.git diff --git a/sql/objects.lisp b/sql/objects.lisp index 1991b70..38c5f49 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -1,37 +1,36 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; $Id: $ +;;;; ************************************************************************* ;;;; -;;;; Description ========================================================== -;;;; ====================================================================== +;;;; $Id$ ;;;; ;;;; The CLSQL Object Oriented Data Definitional Language (OODDL) ;;;; and Object Oriented Data Manipulation Language (OODML). ;;;; -;;;; ====================================================================== +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* (in-package #:clsql-sys) (defclass standard-db-object () - ((view-database - :initform nil - :initarg :view-database + ((view-database :initform nil :initarg :view-database :reader view-database :db-kind :virtual)) (:metaclass standard-db-class) (:documentation "Superclass for all CLSQL View Classes.")) -(defmethod view-database ((self standard-db-object)) - (slot-value self 'view-database)) - (defvar *db-deserializing* nil) (defvar *db-initializing* nil) -(defmethod slot-value-using-class ((class standard-db-class) instance slot) +(defmethod slot-value-using-class ((class standard-db-class) instance slot-def) (declare (optimize (speed 3))) (unless *db-deserializing* - (let ((slot-name (%slot-name slot)) - (slot-object (%slot-object slot class))) - (when (and (eql (view-class-slot-db-kind slot-object) :join) + (let* ((slot-name (%svuc-slot-name slot-def)) + (slot-object (%svuc-slot-object slot-def class)) + (slot-kind (view-class-slot-db-kind slot-object))) + (when (and (eql slot-kind :join) (not (slot-boundp instance slot-name))) (let ((*db-deserializing* t)) (if (view-database instance) @@ -45,27 +44,14 @@ (declare (ignore new-value instance slot)) (call-next-method)) -;; JMM - Can't go around trying to slot-access a symbol! Guess in -;; CMUCL slot-name is the actual slot _object_, while in lispworks it -;; is a lowly symbol (the variable is called slot-name after all) so -;; the object (or in MOP terminology- the "slot definition") has to be -;; retrieved using find-slot-definition - -(defun %slot-name (slot) - #+lispworks slot - #-lispworks (slot-definition-name slot)) - -(defun %slot-object (slot class) - (declare (ignorable class)) - #+lispworks (clos:find-slot-definition slot class) - #-lispworks slot) - -(defmethod initialize-instance :around ((class standard-db-object) - &rest all-keys - &key &allow-other-keys) +(defmethod initialize-instance :around ((object standard-db-object) + &rest all-keys &key &allow-other-keys) (declare (ignore all-keys)) - (let ((*db-deserializing* t)) - (call-next-method))) + (let ((*db-initializing* t)) + (call-next-method) + (unless *db-deserializing* + #+nil (created-object object) + (update-records-from-instance object)))) (defun sequence-from-class (view-class-name) (sql-escape @@ -97,36 +83,6 @@ (database-output-sql keylist database))))) -#.(locally-enable-sql-reader-syntax) - -(defun ensure-schema-version-table (database) - (unless (table-exists-p "clsql_object_v" :database database) - (create-table [clsql_object_v] '(([name] (string 32)) - ([vers] integer) - ([def] (string 32))) - :database database))) - -(defun update-schema-version-records (view-class-name - &key (database *default-database*)) - (let ((schemadef nil) - (tclass (find-class view-class-name))) - (dolist (slotdef (class-slots tclass)) - (let ((res (database-generate-column-definition view-class-name - slotdef database))) - (when res (setf schemadef (cons res schemadef))))) - (when schemadef - (delete-records :from [clsql_object_v] - :where [= [name] (sql-escape (class-name tclass))] - :database database) - (insert-records :into [clsql_object_v] - :av-pairs `(([name] ,(sql-escape (class-name tclass))) - ([vers] ,(car (object-version tclass))) - ([def] ,(prin1-to-string - (object-definition tclass)))) - :database database)))) - -#.(restore-sql-reader-syntax-state) - (defun create-view-from-class (view-class-name &key (database *default-database*)) "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines @@ -135,14 +91,12 @@ the view. The argument DATABASE has a default value of (let ((tclass (find-class view-class-name))) (if tclass (let ((*default-database* database)) - (%install-class tclass database) - (ensure-schema-version-table database) - (update-schema-version-records view-class-name :database database)) + (%install-class tclass database)) (error "Class ~s not found." view-class-name))) (values)) (defmethod %install-class ((self standard-db-class) database &aux schemadef) - (dolist (slotdef (class-slots self)) + (dolist (slotdef (ordered-class-slots self)) (let ((res (database-generate-column-definition (class-name self) slotdef database))) (when res @@ -159,8 +113,6 @@ the view. The argument DATABASE has a default value of ;; Drop the tables which store the given view class ;; -#.(locally-enable-sql-reader-syntax) - (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 @@ -168,14 +120,10 @@ which defines that view. The argument DATABASE has a default value of (let ((tclass (find-class view-class-name))) (if tclass (let ((*default-database* database)) - (%uninstall-class tclass) - (delete-records :from [clsql_object_v] - :where [= [name] (sql-escape view-class-name)])) + (%uninstall-class tclass)) (error "Class ~s not found." view-class-name))) (values)) -#.(restore-sql-reader-syntax-state) - (defun %uninstall-class (self &key (database *default-database*)) (drop-table (sql-expression :table (view-table self)) :if-does-not-exist :ignore @@ -189,13 +137,21 @@ which defines that view. The argument DATABASE has a default value of ;; (defun list-classes (&key (test #'identity) - (root-class 'standard-db-object) - (database *default-database*)) - "Returns a list of View Classes connected to a given DATABASE which -defaults to *DEFAULT-DATABASE*." - (declare (ignore root-class)) - (remove-if #'(lambda (c) (not (funcall test c))) - (database-view-classes database))) + (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*." + (flet ((find-superclass (class) + (member root-class (class-precedence-list class)))) + (let ((view-classes (and database (database-view-classes database)))) + (when view-classes + (remove-if #'(lambda (c) (or (not (funcall test c)) + (not (find-superclass c)))) + view-classes))))) ;; ;; Define a new view class @@ -259,7 +215,7 @@ superclass of the newly-defined View Class." (defun generate-selection-list (vclass) (let ((sels nil)) - (dolist (slotdef (class-slots vclass)) + (dolist (slotdef (ordered-class-slots vclass)) (let ((res (generate-attribute-reference vclass slotdef))) (when res (push (cons slotdef res) sels)))) @@ -278,6 +234,7 @@ superclass of the newly-defined View Class." (let ((cdef (list (sql-expression :attribute (view-class-slot-column slotdef)) (slot-type slotdef)))) + (setf cdef (append cdef (list (view-class-slot-db-type slotdef)))) (let ((const (view-class-slot-db-constraints slotdef))) (when const (setq cdef (append cdef (list const))))) @@ -294,17 +251,16 @@ superclass of the newly-defined View Class." list)) (defun slot-type (slotdef) - (let ((slot-type (slot-definition-type slotdef))) - (if (listp slot-type) - (cons (find-symbol (symbol-name (car slot-type)) :clsql-sys) - (cdr slot-type)) - (find-symbol (symbol-name slot-type) :clsql-sys)))) + (specified-type slotdef)) + +(defvar *update-context* nil) (defmethod update-slot-from-db ((instance standard-db-object) slotdef value) (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) - (let ((slot-reader (view-class-slot-db-reader slotdef)) - (slot-name (slot-definition-name slotdef)) - (slot-type (slot-type slotdef))) + (let* ((slot-reader (view-class-slot-db-reader slotdef)) + (slot-name (slot-definition-name slotdef)) + (slot-type (slot-type slotdef)) + (*update-context* (cons (type-of instance) slot-name))) (cond ((and value (null slot-reader)) (setf (slot-value instance slot-name) (read-sql-value value (delistify slot-type) @@ -368,75 +324,6 @@ superclass of the newly-defined View Class." (mapc #'update-slot slotdeflist values) obj)) - -(defun synchronize-keys (src srckey dest destkey) - (let ((skeys (if (listp srckey) srckey (list srckey))) - (dkeys (if (listp destkey) destkey (list destkey)))) - (mapcar #'(lambda (sk dk) - (setf (slot-value dest dk) - (typecase sk - (symbol - (slot-value src sk)) - (t sk)))) - skeys dkeys))) - -(defun desynchronize-keys (dest destkey) - (let ((dkeys (if (listp destkey) destkey (list destkey)))) - (mapcar #'(lambda (dk) - (setf (slot-value dest dk) nil)) - dkeys))) - -(defmethod add-to-relation ((target standard-db-object) - slot-name - (value standard-db-object)) - (let* ((objclass (class-of target)) - (sdef (or (slotdef-for-slot-with-class slot-name objclass) - (error "~s is not an known slot on ~s" slot-name target))) - (dbinfo (view-class-slot-db-info sdef)) - (join-class (gethash :join-class dbinfo)) - (homekey (gethash :home-key dbinfo)) - (foreignkey (gethash :foreign-key dbinfo)) - (to-many (gethash :set dbinfo))) - (unless (equal (type-of value) join-class) - (error 'clsql-type-error :slotname slot-name :typespec join-class - :value value)) - (when (gethash :target-slot dbinfo) - (error "add-to-relation does not work with many-to-many relations yet.")) - (if to-many - (progn - (synchronize-keys target homekey value foreignkey) - (if (slot-boundp target slot-name) - (unless (member value (slot-value target slot-name)) - (setf (slot-value target slot-name) - (append (slot-value target slot-name) (list value)))) - (setf (slot-value target slot-name) (list value)))) - (progn - (synchronize-keys value foreignkey target homekey) - (setf (slot-value target slot-name) value))))) - -(defmethod remove-from-relation ((target standard-db-object) - slot-name (value standard-db-object)) - (let* ((objclass (class-of target)) - (sdef (slotdef-for-slot-with-class slot-name objclass)) - (dbinfo (view-class-slot-db-info sdef)) - (homekey (gethash :home-key dbinfo)) - (foreignkey (gethash :foreign-key dbinfo)) - (to-many (gethash :set dbinfo))) - (when (gethash :target-slot dbinfo) - (error "remove-relation does not work with many-to-many relations yet.")) - (if to-many - (progn - (desynchronize-keys value foreignkey) - (if (slot-boundp target slot-name) - (setf (slot-value target slot-name) - (remove value - (slot-value target slot-name) - :test #'equal)))) - (progn - (desynchronize-keys target homekey) - (setf (slot-value target slot-name) - nil))))) - (defgeneric update-record-from-slot (object slot &key database) (:documentation "The generic function UPDATE-RECORD-FROM-SLOT updates an individual @@ -463,10 +350,11 @@ are derived from the View Class definition.")) obj :database database) :database (view-database obj))) ((and vct sd (not (view-database obj))) - (install-instance obj :database database)) + (warn "Ignoring (install-instance obj :database database))") + t) (t (error "Unable to update record."))))) - (values)) + t) (defgeneric update-record-from-slots (object slots &key database) (:documentation @@ -526,7 +414,7 @@ associated with that database.")) (db-value-from-slot slot value database))))) (let* ((view-class (class-of obj)) (view-class-table (view-table view-class)) - (slots (remove-if-not #'slot-storedp (class-slots view-class))) + (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class))) (record-values (mapcar #'slot-value-list slots))) (unless record-values (error "No settable slots.")) @@ -543,94 +431,6 @@ associated with that database.")) (setf (slot-value obj 'view-database) database))) (values)))) -(defmethod install-instance ((obj standard-db-object) - &key (database *default-database*)) - (labels ((slot-storedp (slot) - (and (member (view-class-slot-db-kind slot) '(:base :key)) - (slot-boundp obj (slot-definition-name slot)))) - (slot-value-list (slot) - (let ((value (slot-value obj (slot-definition-name slot)))) - (check-slot-type slot value) - (list (sql-expression :attribute (view-class-slot-column slot)) - (db-value-from-slot slot value database))))) - (let* ((view-class (class-of obj)) - (view-class-table (view-table view-class)) - (slots (remove-if-not #'slot-storedp (class-slots view-class))) - (record-values (mapcar #'slot-value-list slots))) - (unless record-values - (error "No settable slots.")) - (unless - (let ((obj-db (slot-value obj 'view-database))) - (when obj-db - (equal obj-db database)))) - (insert-records :into (sql-expression :table view-class-table) - :av-pairs record-values - :database database) - (setf (slot-value obj 'view-database) database)) - (values))) - -;; Perhaps the slot class is not correct in all CLOS implementations, -;; tho I have not run across a problem yet. - -(defmethod handle-cascade-delete-rule ((instance standard-db-object) - (slot - view-class-effective-slot-definition)) - (let ((val (slot-value instance (slot-definition-name slot)))) - (typecase val - (list - (if (gethash :target-slot (view-class-slot-db-info slot)) - ;; For relations with target-slot, we delete just the join instance - (mapcar #'(lambda (obj) - (delete-instance-records obj)) - (fault-join-slot-raw (class-of instance) instance slot)) - (dolist (obj val) - (delete-instance-records obj)))) - (standard-db-object - (delete-instance-records val))))) - -(defmethod nullify-join-foreign-keys ((instance standard-db-object) slot) - (let* ((dbi (view-class-slot-db-info slot)) - (fkeys (gethash :foreign-keys dbi))) - (mapcar #'(lambda (fk) - (if (view-class-slot-nulls-ok slot) - (setf (slot-value instance fk) nil) - (warn "Nullify delete rule cannot set slot not allowing nulls to nil"))) - (if (listp fkeys) fkeys (list fkeys))))) - -(defmethod handle-nullify-delete-rule ((instance standard-db-object) - (slot - view-class-effective-slot-definition)) - (let ((dbi (view-class-slot-db-info slot))) - (if (gethash :set dbi) - (if (gethash :target-slot (view-class-slot-db-info slot)) - ;;For relations with target-slot, we delete just the join instance - (mapcar #'(lambda (obj) - (nullify-join-foreign-keys obj slot)) - (fault-join-slot-raw (class-of instance) instance slot)) - (dolist (obj (slot-value instance (slot-definition-name slot))) - (nullify-join-foreign-keys obj slot))) - (nullify-join-foreign-keys - (slot-value instance (slot-definition-name slot)) slot)))) - -(defmethod propogate-deletes ((instance standard-db-object)) - (let* ((view-class (class-of instance)) - (joins (remove-if #'(lambda (sd) - (not (equal (view-class-slot-db-kind sd) :join))) - (class-slots view-class)))) - (dolist (slot joins) - (let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot)))) - (cond - ((eql delete-rule :cascade) - (handle-cascade-delete-rule instance slot)) - ((eql delete-rule :deny) - (when (slot-value instance (slot-definition-name slot)) - (error - "Unable to delete slot ~A, because it has a deny delete rule." - slot))) - ((eql delete-rule :nullify) - (handle-nullify-delete-rule instance slot)) - (t t)))))) - (defgeneric delete-instance-records (instance) (:documentation "Deletes the records represented by INSTANCE from the database @@ -642,11 +442,9 @@ is signalled.")) (vd (or (view-database instance) *default-database*))) (when vd (let ((qualifier (key-qualifier-for-instance instance :database vd))) - (with-transaction (:database vd) - (propogate-deletes instance) - (delete-records :from vt :where qualifier :database vd) - (setf (slot-value instance 'view-database) nil))))) - (values)) + (delete-records :from vt :where qualifier :database vd) + (setf (slot-value instance 'view-database) nil)))) + #+ignore (odcl::deleted-object object)) (defgeneric update-instance-from-records (instance &key database) (:documentation @@ -665,7 +463,8 @@ database that INSTANCE is associated with, or the value of (res (apply #'select (append (mapcar #'cdr sels) (list :from view-table :where view-qual))))) - (get-slot-values-from-view instance (mapcar #'car sels) (car res)))) + (when res + (get-slot-values-from-view instance (mapcar #'car sels) (car res))))) (defgeneric update-slot-from-record (instance slot &key database) (:documentation @@ -691,17 +490,19 @@ database that INSTANCE is associated with, or the value of will be converted into.")) (defmethod database-null-value ((type t)) - (cond - ((subtypep type 'string) "") - ((subtypep type 'integer) 0) - ((subtypep type 'float) (float 0.0)) - ((subtypep type 'list) nil) - ((subtypep type 'boolean) nil) - ((subtypep type 'symbol) nil) - ((subtypep type 'keyword) nil) - ((subtypep type 'wall-time) nil) - (t - (error "Unable to handle null for type ~A" type)))) + (cond + ((subtypep type 'string) nil) + ((subtypep type 'integer) nil) + ((subtypep type 'list) nil) + ((subtypep type 'boolean) nil) + ((eql type t) nil) + ((subtypep type 'symbol) nil) + ((subtypep type 'keyword) nil) + ((subtypep type 'wall-time) nil) + ((subtypep type 'duration) nil) + ((subtypep type 'money) nil) + (t + (error "Unable to handle null for type ~A" type)))) (defgeneric update-slot-with-null (instance slotname slotdef) (:documentation "Called to update a slot when its column has a NULL @@ -709,14 +510,14 @@ value. If nulls are allowed for the column, the slot's value will be nil, otherwise its value will be set to the result of calling DATABASE-NULL-VALUE on the type of the slot.")) -(defmethod update-slot-with-null ((instance standard-db-object) +(defmethod update-slot-with-null ((object standard-db-object) slotname slotdef) (let ((st (slot-type slotdef)) (allowed (slot-value slotdef 'nulls-ok))) (if allowed - (setf (slot-value instance slotname) nil) - (setf (slot-value instance slotname) + (setf (slot-value object slotname) nil) + (setf (slot-value object slotname) (database-null-value st))))) (defvar +no-slot-value+ '+no-slot-value+) @@ -789,6 +590,10 @@ DATABASE-NULL-VALUE on the type of the slot.")) (t "TIMESTAMP"))) (defmethod database-get-type-specifier ((type (eql 'duration)) args database) + (declare (ignore database args)) + "VARCHAR") + +(defmethod database-get-type-specifier ((type (eql 'money)) args database) (declare (ignore database args)) "INT8") @@ -825,7 +630,9 @@ DATABASE-NULL-VALUE on the type of the slot.")) (defmethod database-output-sql-as-type ((type (eql 'list)) val database) (declare (ignore database)) (progv '(*print-circle* *print-array*) '(t t) - (prin1-to-string val))) + (let ((escaped (prin1-to-string val))) + (clsql-base-sys::substitute-char-string + escaped #\Null " ")))) (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) (declare (ignore database)) @@ -900,9 +707,9 @@ DATABASE-NULL-VALUE on the type of the slot.")) (defmethod read-sql-value (val (type (eql 'symbol)) database) (declare (ignore database)) (when (< 0 (length val)) - (if (find #\: val) - (read-from-string val) - (intern (string-upcase val) "KEYWORD")))) + (unless (string= val "NIL") + (intern (string-upcase val) + (symbol-package *update-context*))))) (defmethod read-sql-value (val (type (eql 'integer)) database) (declare (ignore database)) @@ -925,21 +732,26 @@ DATABASE-NULL-VALUE on the type of the slot.")) (unless (eq 'NULL val) (parse-timestring val))) +(defmethod read-sql-value (val (type (eql 'duration)) database) + (declare (ignore database)) + (unless (or (eq 'NULL val) + (equal "NIL" val)) + (parse-timestring val))) ;; ------------------------------------------------------------ ;; Logic for 'faulting in' :join slots -(defun fault-join-slot-raw (class instance slot-def) +(defun fault-join-slot-raw (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) (jc (gethash :join-class dbi))) - (let ((jq (join-qualifier class instance slot-def))) + (let ((jq (join-qualifier class object slot-def))) (when jq (select jc :where jq))))) -(defun fault-join-slot (class instance slot-def) +(defun fault-join-slot (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) (ts (gethash :target-slot dbi)) - (res (fault-join-slot-raw class instance slot-def))) + (res (fault-join-slot-raw class object slot-def))) (when res (cond ((and ts (gethash :set dbi)) @@ -952,7 +764,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) ((and (not ts) (gethash :set dbi)) res))))) -(defun join-qualifier (class instance slot-def) +(defun join-qualifier (class object slot-def) (declare (ignore class)) (let* ((dbi (view-class-slot-db-info slot-def)) (jc (find-class (gethash :join-class dbi))) @@ -961,8 +773,8 @@ DATABASE-NULL-VALUE on the type of the slot.")) (foreign-keys (gethash :foreign-key dbi)) (home-keys (gethash :home-key dbi))) (when (every #'(lambda (slt) - (and (slot-boundp instance slt) - (not (null (slot-value instance slt))))) + (and (slot-boundp object slt) + (not (null (slot-value object slt))))) (if (listp home-keys) home-keys (list home-keys))) (let ((jc (mapcar #'(lambda (hk fk) @@ -977,7 +789,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) (t fk)) (typecase hk (symbol - (slot-value instance hk)) + (slot-value object hk)) (t hk))))) (if (listp home-keys) @@ -991,15 +803,21 @@ DATABASE-NULL-VALUE on the type of the slot.")) (apply #'sql-and jc) jc)))))) +(defmethod postinitialize ((self t)) + ) (defun find-all (view-classes &rest args &key all set-operation distinct from where group-by having order-by order-by-descending offset limit (database *default-database*)) "tweeze me apart someone pleeze" - (declare (ignore all set-operation from group-by having offset limit) + (declare (ignore all set-operation group-by having + offset limit) (optimize (debug 3) (speed 1))) + ;; (cmsg "Args = ~s" args) + (remf args :from) (let* ((*db-deserializing* t) - (*default-database* (or database (error 'clsql-nodb-error)))) + (*default-database* (or database + (error 'clsql-no-database-error nil)))) (flet ((table-sql-expr (table) (sql-expression :table (view-table table))) (ref-equal (ref1 ref2) @@ -1013,59 +831,40 @@ DATABASE-NULL-VALUE on the type of the slot.")) (sels (mapcar #'generate-selection-list sclasses)) (fullsels (apply #'append sels)) (sel-tables (collect-table-refs where)) - (tables - (remove-duplicates - (append (mapcar #'table-sql-expr sclasses) sel-tables) - :test #'tables-equal)) + (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses) sel-tables) + :test #'tables-equal)) (res nil)) (dolist (ob (listify order-by)) (when (and ob (not (member ob (mapcar #'cdr fullsels) :test #'ref-equal))) - (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) + (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)))))) + (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) (dolist (ob (listify distinct)) - (when (and (typep ob 'sql-ident) - (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) - ;;(format t "~%fullsels is : ~A" fullsels) + (when (and (typep ob 'sql-ident) (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + ;; (cmsg "Tables = ~s" tables) + ;; (cmsg "From = ~s" from) (setq res (apply #'select (append (mapcar #'cdr fullsels) - (cons :from (list tables)) args))) - (flet ((build-instance (vals) - (flet ((%build-instance (vclass selects) + (cons :from (list (append (when from (listify from)) (listify tables)))) args))) + (flet ((build-object (vals) + (flet ((%build-object (vclass selects) (let ((class-name (class-name vclass)) - (db-vals (butlast vals - (- (list-length vals) - (list-length selects)))) - cache-key) - (setf vals (nthcdr (list-length selects) vals)) - (loop for select in selects - for value in db-vals - do - (when (eql (slot-value (car select) 'db-kind) - :key) - (push - (key-value-from-db (car select) value - *default-database*) - cache-key))) - (push class-name cache-key) - (%make-fresh-object class-name - (mapcar #'car selects) - db-vals)))) - (let ((instances (mapcar #'%build-instance sclasses sels))) + (db-vals (butlast vals (- (list-length vals) + (list-length selects))))) + ;; (setf vals (nthcdr (list-length selects) vals)) + (%make-fresh-object class-name (mapcar #'car selects) db-vals)))) + (let ((objects (mapcar #'%build-object sclasses sels))) (if (= (length sclasses) 1) - (car instances) - instances))))) - (remove-if #'null (mapcar #'build-instance res))))))) + (car objects) + objects))))) + (mapcar #'build-object res)))))) (defun %make-fresh-object (class-name slots values) (let* ((*db-initializing* t) @@ -1075,9 +874,6 @@ DATABASE-NULL-VALUE on the type of the slot.")) (postinitialize obj) obj)) -(defmethod postinitialize ((self t)) - ) - (defun select (&rest select-all-args) "Selects data from database given the constraints specified. Returns a list of lists of record values as specified by select-all-args. By @@ -1094,6 +890,7 @@ tuples." target-args)))) (multiple-value-bind (target-args qualifier-args) (query-get-selections select-all-args) + ;; (cmsg "Qual args = ~s" qualifier-args) (if (select-objects target-args) (apply #'find-all target-args qualifier-args) (let ((expr (apply #'make-query select-all-args)))