X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=e72e53aa8fc5247d68960d872e7041abc3978b20;hb=90011694c27b5b22673a34cb6948a2a721a9b6cd;hp=833abd79e0510f3a47682bbea747a793fdc27b1a;hpb=5990bfce392a05c10237d4f97b008c4f828028e5;p=clsql.git diff --git a/sql/objects.lisp b/sql/objects.lisp index 833abd7..e72e53a 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -21,6 +21,10 @@ (:metaclass standard-db-class) (:documentation "Superclass for all CLSQL View Classes.")) +(defvar *update-records-on-make-instance* nil + "When T, UPDATE-RECORDS-FROM-INSTANCE will be automatically called +when a new instance of a view-class is created.") + (defvar *db-deserializing* nil) (defvar *db-initializing* nil) @@ -39,17 +43,19 @@ (setf (slot-value instance slot-name) nil)))))) (call-next-method)) +#+ignore ;; not currently used (defmethod (setf slot-value-using-class) (new-value (class standard-db-class) instance slot) (declare (ignore new-value instance slot)) (call-next-method)) -(defmethod initialize-instance :around ((object standard-db-object) +(defmethod initialize-instance ((object standard-db-object) &rest all-keys &key &allow-other-keys) (declare (ignore all-keys)) (let ((*db-initializing* t)) (call-next-method) - (unless *db-deserializing* + (when (and *update-records-on-make-instance* + (not *db-deserializing*)) #+nil (created-object object) (update-records-from-instance object)))) @@ -706,21 +712,72 @@ superclass of the newly-defined View Class." (when jq (select jc :where jq :flatp t :result-types nil))))) -(defun fault-join-slot (class object slot-def) +;; this works, but is inefficient requiring (+ 1 n-rows) +;; SQL queries +#+ignore +(defun fault-join-target-slot (class object slot-def) + (let* ((res (fault-join-slot-raw class object slot-def)) + (dbi (view-class-slot-db-info slot-def)) + (target-name (gethash :target-slot dbi)) + (target-class (find-class target-name))) + (when res + (mapcar (lambda (obj) + (list + (car + (fault-join-slot-raw + target-class + obj + (find target-name (class-slots (class-of obj)) + :key #'slot-definition-name))) + obj)) + res) + #+ignore ;; this doesn't work when attempting to call slot-value + (mapcar (lambda (obj) + (cons obj (slot-value obj ts))) res)))) + +(defun fault-join-target-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 object slot-def))) - (when res - (cond - ((and ts (gethash :set dbi)) - (mapcar (lambda (obj) - (cons obj (slot-value obj ts))) res)) - ((and ts (not (gethash :set dbi))) - (mapcar (lambda (obj) (slot-value obj ts)) res)) - ((and (not ts) (not (gethash :set dbi))) - (car res)) - ((and (not ts) (gethash :set dbi)) - res))))) + (jc (gethash :join-class dbi)) + (tdbi (view-class-slot-db-info + (find ts (class-slots (find-class jc)) + :key #'slot-definition-name))) + (jq (join-qualifier class object slot-def)) + (key (slot-value object (gethash :home-key dbi)))) + (when jq + (let ((res + (find-all (list ts) + :inner-join (sql-expression :attribute jc) + :on (sql-operation + '== + (sql-expression :attribute (gethash :foreign-key tdbi) :table ts) + (sql-expression :attribute (gethash :home-key tdbi) :table jc)) + :where jq + :result-types :auto))) + (mapcar #'(lambda (i) + (let* ((instance (car i)) + (jcc (make-instance jc :view-database (view-database instance)))) + (setf (slot-value jcc (gethash :foreign-key dbi)) + key) + (setf (slot-value jcc (gethash :home-key tdbi)) + (slot-value instance (gethash :foreign-key tdbi))) + (list instance jcc))) + res))))) + +(defun fault-join-slot (class object slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (ts (gethash :target-slot dbi))) + (if (and ts (gethash :set dbi)) + (fault-join-target-slot class object slot-def) + (let ((res (fault-join-slot-raw class object slot-def))) + (when res + (cond + ((and ts (not (gethash :set dbi))) + (mapcar (lambda (obj) (slot-value obj ts)) res)) + ((and (not ts) (not (gethash :set dbi))) + (car res)) + ((and (not ts) (gethash :set dbi)) + res))))))) (defun join-qualifier (class object slot-def) (declare (ignore class)) @@ -761,15 +818,19 @@ superclass of the newly-defined View Class." (apply #'sql-and jc) jc)))))) -(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 (database *default-database*)) +(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*)) "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) + (declare (ignore all set-operation group-by having offset limit inner-join on) (optimize (debug 3) (speed 1))) (remf args :from) (remf args :flatp) + (remf args :additional-fields) (remf args :result-types) (labels ((table-sql-expr (table) (sql-expression :table (view-table table))) @@ -835,7 +896,7 @@ superclass of the newly-defined View Class." (cons :from (list (append (when from (listify from)) (listify tables)))) - (list :result-types nil) + (list :result-types result-types) args))) (mapcar #'(lambda (r) (build-objects r sclasses sels)) res)))) @@ -881,7 +942,7 @@ ENABLE-SQL-READER-SYNTAX." (multiple-value-bind (target-args qualifier-args) (query-get-selections select-all-args) (if (select-objects target-args) - (apply #'find-all target-args qualifier-args) + (apply #'find-all target-args qualifier-args) (let* ((expr (apply #'make-query select-all-args)) (specified-types (mapcar #'(lambda (attrib)