X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=e0d2cef682f51d1738885d4351cfb6f3c5bf3303;hb=fcb0cac1b206dacdb3d1043b5393bbb510a00882;hp=33aab570302cf7dc098cf48a1bfc2d469841b38d;hpb=7e20a5285824bbbd2aa6fae61da73465ed2e8557;p=clsql.git diff --git a/sql/objects.lisp b/sql/objects.lisp index 33aab57..e0d2cef 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -13,7 +13,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql-sys) +(in-package #:clsql) (defclass standard-db-object () ((view-database :initform nil :initarg :view-database :reader view-database @@ -21,6 +21,11 @@ (:metaclass standard-db-class) (:documentation "Superclass for all CLSQL View Classes.")) +(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) @@ -40,17 +45,24 @@ (call-next-method)) (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 :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* - #+nil (created-object object) + (when (and *db-auto-sync* + (not *db-deserializing*)) (update-records-from-instance object)))) ;; @@ -169,7 +181,7 @@ superclass of the newly-defined View Class." (defclass ,class ,supers ,slots ,@(if (find :metaclass `,cl-options :key #'car) `,cl-options - (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) + (cons '(:metaclass clsql::standard-db-class) `,cl-options))) (finalize-inheritance (find-class ',class)) (find-class ',class))) @@ -227,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) @@ -699,6 +706,93 @@ superclass of the newly-defined View Class." ;; ------------------------------------------------------------ ;; Logic for 'faulting in' :join slots +;; 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)) + (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 + (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))) + (: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))) @@ -708,19 +802,18 @@ superclass of the newly-defined View Class." (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 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))))) + (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 +854,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))) @@ -783,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) @@ -800,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)) @@ -835,20 +929,43 @@ 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)))) (defmethod instance-refreshed ((instance standard-db-object))) -(defmethod 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 -default, the records are each represented as lists of attribute -values. The selections argument may be either db-identifiers, literal -strings or view classes. If the argument consists solely of view -classes, the return value will be instances of objects rather than raw -tuples." +(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." + (flet ((select-objects (target-args) (and target-args (every #'(lambda (arg) @@ -858,14 +975,29 @@ tuples." (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) - (let ((expr (apply #'make-query select-all-args))) - (destructuring-bind (&key (flatp nil) - (result-types :auto) - (field-names t) - (database *default-database*) - &allow-other-keys) - qualifier-args - (query expr :flatp flatp :result-types result-types - :field-names field-names :database database))))))) + (apply #'find-all target-args qualifier-args) + (let* ((expr (apply #'make-query select-all-args)) + (specified-types + (mapcar #'(lambda (attrib) + (if (typep attrib 'sql-ident-attribute) + (let ((type (slot-value attrib 'type))) + (if type + type + t)) + t)) + (slot-value expr 'selections)))) + (destructuring-bind (&key (flatp nil) + (result-types :auto) + (field-names t) + (database *default-database*) + &allow-other-keys) + qualifier-args + (query expr :flatp flatp + :result-types + ;; specifying a type for an attribute overrides result-types + (if (some #'(lambda (x) (not (eq t x))) specified-types) + specified-types + result-types) + :field-names field-names + :database database)))))))