(: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)
(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-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 ((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))))
;;
(error "No slots of type :base in view-class ~A" (class-name vclass)))))
-;;
+
+(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))
+
+
;; Called by 'get-slot-values-from-view'
;;
-(declaim (inline delistify))
-(defun delistify (list)
- (if (listp list)
- (car list)
- list))
-
(defvar *update-context* nil)
(defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
;; ------------------------------------------------------------
;; 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)))))
-
-;; FIXME: Create a single join query for efficiency
+;; 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))
(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))))
+ (let* ((class (find-class class-name))
+ (deferred-joins (generate-retrieval-joins-list class :deferred)))
+ (when deferred-joins
+ (warn "not yet implemented.")
+ ))))
+
+
+(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))
(ts (gethash :target-slot dbi)))
(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 result-types (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 result-types)
- (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)
- (equal (sql ref1)
- (sql ref2)))
- (tables-equal (table-a table-b)
- (string= (string (slot-value table-a 'name))
- (string (slot-value table-b 'name))))
- (build-object (vals vclass selects)
+;; 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)
+ "Used by find-all to build objects."
+ (labels ((build-object (vals vclass jclasses selects immediate-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)))
+ (join-vals (subseq vals (list-length selects)))
+ (obj (make-instance class-name :view-database database))
+ (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))
- (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))))
+ obj)))
+ (let ((objects (mapcar #'(lambda (sclass jclass sel immediate-join)
+ (prog1 (build-object vals sclass jclass sel immediate-join)
+ (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join))
+ vals))))
+ sclasses immediate-join-classes sels immediate-joins)))
+ (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 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 inner-join on)
+ (optimize (debug 3) (speed 1)))
+ (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)
+ (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)
(let* ((*db-deserializing* t)
- (*default-database* (or database
- (error 'clsql-base::clsql-no-database-error :database 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
+ (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 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))))))
- (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 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))))))
+ (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)))
+ (objects (mapcar
+ #'(lambda (r)
+ (build-objects r sclasses immediate-join-classes sels immediate-join-sels database refresh flatp))
+ rows)))
+ objects))))
(defmethod instance-refreshed ((instance standard-db-object)))
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))
- (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)))))))
+ (cond
+ ((select-objects target-args)
+ (let ((caching (getf qualifier-args :caching))
+ (refresh (getf qualifier-args :refresh))
+ (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)
+ (update-cached-results target-args qualifier-args database))
+ (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))