X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fobjects.lisp;h=8fa98903a85450c436d20258b91cdb4c81345c68;hp=9598ea643d3172bf8acdd209be7fd443e42b52a6;hb=155c60b5195d618ef93541699694d57a21be3246;hpb=9711a224f9684aaaba08e20eaab826be1beee460 diff --git a/sql/objects.lisp b/sql/objects.lisp index 9598ea6..8fa9890 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -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,25 @@ (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-object (%svuc-slot-object slot-def class)) + (slot-kind (view-class-slot-db-kind slot-object))) + (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)))) ;; @@ -97,7 +110,7 @@ the view. The argument DATABASE has a default value of (when (member (view-class-slot-db-kind slotdef) '(:base :key)) (let ((cdef (list (sql-expression :attribute (view-class-slot-column slotdef)) - (slot-type slotdef)))) + (specified-type slotdef)))) (setf cdef (append cdef (list (view-class-slot-db-type slotdef)))) (let ((const (view-class-slot-db-constraints slotdef))) (when const @@ -170,7 +183,8 @@ superclass of the newly-defined View Class." ,@(if (find :metaclass `,cl-options :key #'car) `,cl-options (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) - (finalize-inheritance (find-class ',class)))) + (finalize-inheritance (find-class ',class)) + (find-class ',class))) (defun keyslots-for-class (class) (slot-value class 'key-slots)) @@ -222,18 +236,30 @@ superclass of the newly-defined View Class." (error "No slots of type :base in view-class ~A" (class-name vclass))))) -;; -;; Called by 'get-slot-values-from-view' -;; -(declaim (inline delistify)) -(defun delistify (list) - (if (listp list) - (car list) - list)) +(defun generate-retrieval-joins-list (vclass retrieval-method) + "Returns list of immediate join slots for a class." + (let ((join-slotdefs nil)) + (dolist (slotdef (ordered-class-slots vclass) join-slotdefs) + (when (and (eq :join (view-class-slot-db-kind slotdef)) + (eq retrieval-method (gethash :retrieval (view-class-slot-db-info slotdef)))) + (push slotdef join-slotdefs))))) + +(defun generate-immediate-joins-selection-list (vclass) + "Returns list of immediate join slots for a class." + (let (sels) + (dolist (joined-slot (generate-retrieval-joins-list vclass :immediate) sels) + (let* ((join-class-name (gethash :join-class (view-class-slot-db-info joined-slot))) + (join-class (when join-class-name (find-class join-class-name)))) + (dolist (slotdef (ordered-class-slots join-class)) + (let ((res (generate-attribute-reference join-class slotdef))) + (when res + (push (cons slotdef res) sels)))))) + sels)) -(defun slot-type (slotdef) - (specified-type slotdef)) + +;; Called by 'get-slot-values-from-view' +;; (defvar *update-context* nil) @@ -241,7 +267,7 @@ superclass of the newly-defined View Class." (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)) + (slot-type (specified-type slotdef)) (*update-context* (cons (type-of instance) slot-name))) (cond ((and value (null slot-reader)) (setf (slot-value instance slot-name) @@ -261,7 +287,7 @@ superclass of the newly-defined View Class." (defmethod key-value-from-db (slotdef value database) (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) (let ((slot-reader (view-class-slot-db-reader slotdef)) - (slot-type (slot-type slotdef))) + (slot-type (specified-type slotdef))) (cond ((and value (null slot-reader)) (read-sql-value value (delistify slot-type) database)) ((null value) @@ -275,7 +301,7 @@ superclass of the newly-defined View Class." (defun db-value-from-slot (slotdef val database) (let ((dbwriter (view-class-slot-db-writer slotdef)) - (dbtype (slot-type slotdef))) + (dbtype (specified-type slotdef))) (typecase dbwriter (string (format nil dbwriter val)) (function (apply dbwriter (list val))) @@ -287,7 +313,7 @@ superclass of the newly-defined View Class." (database-output-sql-as-type dbtype val database))))))) (defun check-slot-type (slotdef val) - (let* ((slot-type (slot-type slotdef)) + (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) @@ -397,7 +423,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 nil)))) + (error 'clsql-no-database-error :database nil)))) (defmethod update-instance-from-records ((instance standard-db-object) &key (database *default-database*)) @@ -456,7 +482,7 @@ superclass of the newly-defined View Class." (defmethod database-get-type-specifier (type args database) (declare (ignore type args)) - (if (clsql-base::in (database-underlying-type database) + (if (in (database-underlying-type database) :postgresql :postgresql-socket) "VARCHAR" "VARCHAR(255)")) @@ -468,6 +494,10 @@ superclass of the newly-defined View Class." (format nil "INT(~A)" (car args)) "INT")) +(deftype bigint () + "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)) "BIGINT") @@ -476,7 +506,7 @@ superclass of the newly-defined View Class." database) (if args (format nil "VARCHAR(~A)" (car args)) - (if (clsql-base::in (database-underlying-type database) + (if (in (database-underlying-type database) :postgresql :postgresql-socket) "VARCHAR" "VARCHAR(255)"))) @@ -485,7 +515,7 @@ superclass of the newly-defined View Class." database) (if args (format nil "VARCHAR(~A)" (car args)) - (if (clsql-base::in (database-underlying-type database) + (if (in (database-underlying-type database) :postgresql :postgresql-socket) "VARCHAR" "VARCHAR(255)"))) @@ -493,11 +523,15 @@ superclass of the newly-defined View Class." (defmethod database-get-type-specifier ((type (eql 'string)) args database) (if args (format nil "VARCHAR(~A)" (car args)) - (if (clsql-base::in (database-underlying-type database) + (if (in (database-underlying-type database) :postgresql :postgresql-socket) "VARCHAR" "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)) "BIGINT") @@ -553,7 +587,7 @@ superclass of the newly-defined View Class." (declare (ignore database)) (progv '(*print-circle* *print-array*) '(t t) (let ((escaped (prin1-to-string val))) - (clsql-base::substitute-char-string + (substitute-char-string escaped #\Null " ")))) (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) @@ -633,8 +667,8 @@ superclass of the newly-defined View Class." (defmethod read-sql-value (val (type (eql 'symbol)) database) (declare (ignore database)) (when (< 0 (length val)) - (unless (string= val (clsql-base:symbol-name-default-case "NIL")) - (intern (clsql-base:symbol-name-default-case 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) @@ -665,9 +699,9 @@ superclass of the newly-defined View Class." (string (if (string= "0" val) nil t)) (integer (if (zerop val) nil t)))) (:postgresql - (if (database-type :odbc) + (if (eq :odbc (database-type database)) (if (string= "0" val) nil t) - (equal "t" val))) + (equal "t" val))) (t (equal "t" val)))) @@ -693,6 +727,141 @@ 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." + (assert (or (null max-len) (plusp max-len))) + (when objects + (unless class-name + (setq class-name (class-name (class-of (first objects))))) + (let* ((class (find-class class-name)) + (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)) + :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)) (jc (gethash :join-class dbi))) @@ -702,19 +871,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)) @@ -755,94 +923,186 @@ 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*)) +;; FIXME: add retrieval immediate for efficiency +;; 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 instances) + "Used by find-all to build objects." + (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))) + (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)) + (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)))) + joins) + (when refresh (instance-refreshed obj)) + obj))) + (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)))) + +(defun find-all (view-classes + &rest args + &key all set-operation distinct from where group-by having + 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) + (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 :result-types) - (labels ((table-sql-expr (table) - (sql-expression :table (view-table table))) - (ref-equal (ref1 ref2) + (labels ((ref-equal (ref1 ref2) (equal (sql ref1) (sql ref2))) + (table-sql-expr (table) + (sql-expression :table (view-table table))) (tables-equal (table-a table-b) - (string= (string (slot-value table-a 'name)) - (string (slot-value table-b 'name)))) - (build-object (vals vclass selects) - (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) - db-vals)) - (when refresh (instance-refreshed obj)) - obj)) - (build-objects (vals sclasses sels) - (let ((objects (mapcar #'(lambda (sclass sel) - (prog1 (build-object vals sclass sel) - (setf vals (nthcdr (list-length sel) - vals)))) - sclasses sels))) - (if (and flatp (= (length sclasses) 1)) - (car objects) - objects)))) + (when (and table-a table-b) + (string= (string (slot-value table-a 'name)) + (string (slot-value table-b 'name)))))) + (remf args :from) + (remf args :where) + (remf args :flatp) + (remf args :additional-fields) + (remf args :result-types) + (remf args :instances) (let* ((*db-deserializing* t) - (*default-database* (or database - (error 'clsql-no-database-error nil))) (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-sels (mapcar #'generate-immediate-joins-selection-list sclasses)) (sels (mapcar #'generate-selection-list sclasses)) - (fullsels (apply #'append sels)) + (fullsels (apply #'append (mapcar #'append sels immediate-join-sels))) (sel-tables (collect-table-refs where)) - (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)))))) - (dolist (ob (listify order-by-descending)) - (when (and ob (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels + (tables (remove-if #'null + (remove-duplicates (append (mapcar #'table-sql-expr sclasses) + (mapcar #'(lambda (jcs) + (mapcan #'(lambda (jc) + (when jc (table-sql-expr jc))) + jcs)) + immediate-join-classes) + sel-tables) + :test #'tables-equal)))) + (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)))))) - (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)))))) - (setq res - (apply #'select - (append (mapcar #'cdr fullsels) - (cons :from - (list (append (when from (listify from)) - (listify tables)))) - (list :result-types nil) - args))) - (mapcar #'(lambda (r) (build-objects r sclasses sels)) res)))) + (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)))))) + (mapcar #'(lambda (vclass jclasses jslots) + (when jclasses + (mapcar + #'(lambda (jclass jslot) + (let ((dbi (view-class-slot-db-info jslot))) + (setq where + (append + (list (sql-operation '== + (sql-expression + :attribute (gethash :foreign-key dbi) + :table (view-table jclass)) + (sql-expression + :attribute (gethash :home-key dbi) + :table (view-table vclass)))) + (when where (listify where)))))) + jclasses jslots))) + sclasses immediate-join-classes immediate-join-slots) + (let* ((rows (apply #'select + (append (mapcar #'cdr fullsels) + (cons :from + (list (append (when from (listify from)) + (listify tables)))) + (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 (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))) -(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) @@ -851,15 +1111,87 @@ tuples." target-args)))) (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))))))) + (cond + ((select-objects target-args) + (let ((caching (getf qualifier-args :caching t)) + (refresh (getf qualifier-args :refresh nil)) + (database (or (getf qualifier-args :database) *default-database*))) + (remf qualifier-args :caching) + (remf qualifier-args :refresh) + (cond + ((null caching) + (apply #'find-all target-args qualifier-args)) + (t + (let ((cached (records-cache-results target-args qualifier-args database))) + (cond + ((and cached (not refresh)) + cached) + ((and cached refresh) + (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached))))) + (setf (records-cache-results target-args qualifier-args database) results) + results)) + (t + (let ((results (apply #'find-all target-args qualifier-args))) + (setf (records-cache-results target-args qualifier-args database) results) + results)))))))) + (t + (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)))))))) + +(defun compute-records-cache-key (targets qualifiers) + (list targets + (do ((args *select-arguments* (cdr args)) + (results nil)) + ((null args) results) + (let* ((arg (car args)) + (value (getf qualifiers arg))) + (when value + (push (list arg + (typecase value + (%sql-expression (sql value)) + (t value))) + results)))))) + +(defun records-cache-results (targets qualifiers database) + (when (record-caches database) + (gethash (compute-records-cache-key targets qualifiers) (record-caches database)))) + +(defun (setf records-cache-results) (results targets qualifiers database) + (unless (record-caches database) + (setf (record-caches database) + (make-hash-table :test 'equal + #+allegro :values #+allegro :weak))) + (setf (gethash (compute-records-cache-key targets qualifiers) + (record-caches database)) results) + results) + +(defun update-cached-results (targets qualifiers database) + ;; FIXME: this routine will need to update slots in cached objects, perhaps adding or removing objects from cached + ;; for now, dump cache entry and perform fresh search + (let ((res (apply #'find-all targets qualifiers))) + (setf (gethash (compute-records-cache-key targets qualifiers) + (record-caches database)) res) + res))