;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:clsql)
+(in-package #:clsql-sys)
(defclass standard-db-object ()
((view-database :initform nil :initarg :view-database :reader view-database
(defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
instance slot-def)
(declare (ignore new-value))
- (let ((slot-name (%svuc-slot-name slot-def))
- (slot-kind (view-class-slot-db-kind slot-def)))
+ (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*)
(defclass ,class ,supers ,slots
,@(if (find :metaclass `,cl-options :key #'car)
`,cl-options
- (cons '(:metaclass clsql::standard-db-class) `,cl-options)))
+ (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
(finalize-inheritance (find-class ',class))
(find-class ',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-base::clsql-no-database-error :database nil))))
+ (error 'clsql-no-database-error :database nil))))
(defmethod update-instance-from-records ((instance standard-db-object)
&key (database *default-database*))
(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)"))
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)")))
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)")))
(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)")))
(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)
(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)
(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."
+ "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
- (class-name (class-of (first objects))))
+ (setq 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.")
- ))))
-
+ (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))
;; 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)
+(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)
- (let* ((class-name (class-name vclass))
- (db-vals (butlast vals (- (list-length vals)
+ (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)))
- (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))
+ (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))))
-
+ #'(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)
- (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)))
+ (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))))
+ 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*))
+ 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 inner-join on)
(remf args :flatp)
(remf args :additional-fields)
(remf args :result-types)
+ (remf args :instances)
(let* ((*db-deserializing* t)
(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-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 (mapcar #'append sels immediate-join-sels)))
jcs))
immediate-join-classes)
sel-tables)
- :test #'tables-equal)))
- (res nil))
+ :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)
(when where (listify where))))))
jclasses jslots)))
sclasses immediate-join-classes immediate-join-slots)
- (setq res
- (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)))
- (mapcar #'(lambda (r)
- (build-objects r sclasses immediate-join-classes sels immediate-join-sels database refresh flatp))
- res))))
+ (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)))
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 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))
projects / clsql.git / blobdiff