X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=e0d2cef682f51d1738885d4351cfb6f3c5bf3303;hb=fcb0cac1b206dacdb3d1043b5393bbb510a00882;hp=e72e53aa8fc5247d68960d872e7041abc3978b20;hpb=90011694c27b5b22673a34cb6948a2a721a9b6cd;p=clsql.git diff --git a/sql/objects.lisp b/sql/objects.lisp index e72e53a..e0d2cef 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -21,9 +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-auto-sync* nil + "A non-nil value means that creating View Class instances or + setting their slots automatically creates/updates the + corresponding records in the underlying database.") (defvar *db-deserializing* nil) (defvar *db-initializing* nil) @@ -43,20 +44,25 @@ when a new instance of a view-class is created.") (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)) + instance slot-def) + (declare (ignore new-value)) + (let ((slot-name (%svuc-slot-name slot-def)) + (slot-kind (view-class-slot-db-kind slot-def))) + (call-next-method) + (when (and *db-auto-sync* + (not *db-initializing*) + (not *db-deserializing*) + (not (eql slot-kind :virtual))) + (update-record-from-slot instance slot-name)))) (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) - (when (and *update-records-on-make-instance* + (when (and *db-auto-sync* (not *db-deserializing*)) - #+nil (created-object object) (update-records-from-instance object)))) ;; @@ -233,11 +239,6 @@ superclass of the newly-defined View Class." ;; Called by 'get-slot-values-from-view' ;; -(declaim (inline delistify)) -(defun delistify (list) - (if (listp list) - (car list) - list)) (defvar *update-context* nil) @@ -705,13 +706,6 @@ superclass of the newly-defined View Class." ;; ------------------------------------------------------------ ;; Logic for 'faulting in' :join slots -(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 object slot-def))) - (when jq - (select jc :where jq :flatp t :result-types nil))))) - ;; this works, but is inefficient requiring (+ 1 n-rows) ;; SQL queries #+ignore @@ -739,30 +733,72 @@ superclass of the newly-defined View Class." (let* ((dbi (view-class-slot-db-info slot-def)) (ts (gethash :target-slot dbi)) (jc (gethash :join-class dbi)) + (ts-view-table (view-table (find-class ts))) + (jc-view-table (view-table (find-class jc))) (tdbi (view-class-slot-db-info (find ts (class-slots (find-class jc)) :key #'slot-definition-name))) + (retrieval (gethash :retrieval tdbi)) (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))) + (ecase retrieval + (:immediate + (let ((res + (find-all (list ts) + :inner-join (sql-expression :table jc-view-table) + :on (sql-operation + '== + (sql-expression + :attribute (gethash :foreign-key tdbi) + :table ts-view-table) + (sql-expression + :attribute (gethash :home-key tdbi) + :table jc-view-table)) + :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))))) + res))) + (:deferred + ;; just fill in minimal slots + (mapcar + #'(lambda (k) + (let ((instance (make-instance ts :view-database (view-database object))) + (jcc (make-instance jc :view-database (view-database object))) + (fk (car k))) + (setf (slot-value instance (gethash :home-key tdbi)) fk) + (setf (slot-value jcc (gethash :foreign-key dbi)) + key) + (setf (slot-value jcc (gethash :home-key tdbi)) + fk) + (list instance jcc))) + (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table) + :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." + (when objects + (unless class-name + (class-name (class-of (first objects)))) + ) + ) + + +(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 object slot-def))) + (when jq + (select jc :where jq :flatp t :result-types nil))))) (defun fault-join-slot (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) @@ -844,7 +880,6 @@ superclass of the newly-defined View Class." (let* ((class-name (class-name vclass)) (db-vals (butlast vals (- (list-length vals) (list-length selects)))) - (*db-initializing* t) (obj (make-instance class-name :view-database database))) ;; use refresh keyword here (setf obj (get-slot-values-from-view obj (mapcar #'car selects) @@ -861,8 +896,6 @@ superclass of the newly-defined View Class." (car objects) objects)))) (let* ((*db-deserializing* t) - (*default-database* (or database - (error 'clsql-base::clsql-no-database-error :database nil))) (sclasses (mapcar #'find-class view-classes)) (sels (mapcar #'generate-selection-list sclasses)) (fullsels (apply #'append sels))