(if vd
(let ((qualifier (key-qualifier-for-instance instance :database vd)))
(delete-records :from vt :where qualifier :database vd)
+ (setf (record-caches vd) nil)
(setf (slot-value instance 'view-database) nil)
(values))
(signal-no-database-error vd))))
"INT")
(deftype smallint ()
- "An integer smaller than a 32-bit integer, this width may vary by SQL implementation."
+ "An integer smaller than a 32-bit integer. this width may vary by SQL implementation."
'integer)
(defmethod database-get-type-specifier ((type (eql 'smallint)) args database db-type)
(declare (ignore args database db-type))
"INT")
+(deftype mediumint ()
+ "An integer smaller than a 32-bit integer, but may be larger than a smallint. This width may vary by SQL implementation."
+ 'integer)
+
+(defmethod database-get-type-specifier ((type (eql 'mediumint)) args database db-type)
+ (declare (ignore args database db-type))
+ "INT")
+
(deftype bigint ()
"An integer larger than a 32-bit integer, this width may vary by SQL implementation."
'integer)
:attribute (gethash :home-key tdbi)
:table jc-view-table))
:where jq
- :result-types :auto)))
+ :result-types :auto
+ :database (view-database object))))
(mapcar #'(lambda (i)
(let* ((instance (car i))
(jcc (make-instance jc :view-database (view-database instance))))
(list instance jcc)))
(select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
:from (sql-expression :table jc-view-table)
- :where jq)))))))
+ :where jq
+ :database (view-database object))))))))
;;; Remote Joins
keys))
:result-types :auto
: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)))
+ (let ((res (remove-if-not #'(lambda (obj)
+ (equal obj (slot-value
+ object
+ home-key)))
+ results
+ :key #'(lambda (res)
+ (slot-value res
+ foreign-key)))))
(when res
- (setf (slot-value object slotdef-name) res)))))))))))
+ (setf (slot-value object slotdef-name)
+ (if (gethash :set dbi) res (car 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)))
(let ((jq (join-qualifier class object slot-def)))
(when jq
- (select jc :where jq :flatp t :result-types nil)))))
+ (select jc :where jq :flatp t :result-types nil
+ :database (view-database object))))))
(defun fault-join-slot (class object slot-def)
(let* ((dbi (view-class-slot-db-info slot-def))
(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)
+
+ ;;(format t "joins: ~S~%db-vals: ~S~%join-values: ~S~%selects: ~S~%immediate-selects: ~S~%"
+ ;;joins db-vals join-vals selects immediate-selects)
+
;; 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))
+ (mapc #'(lambda (jo)
+ ;; find all immediate-select slots and join-vals for this object
+ (let* ((slots (class-slots (class-of jo)))
+ (pos-list (remove-if #'null
+ (mapcar
+ #'(lambda (s)
+ (position s immediate-selects
+ :key #'car
+ :test #'eq))
+ slots))))
+ (get-slot-values-from-view jo
+ (mapcar #'car
+ (mapcar #'(lambda (pos)
+ (nth pos immediate-selects))
+ pos-list))
+ (mapcar #'(lambda (pos) (nth pos join-vals))
+ pos-list))))
joins)
(mapc
#'(lambda (jc)
(fullsels (apply #'append (mapcar #'append sels immediate-join-sels)))
(sel-tables (collect-table-refs where))
(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)))
+ (remove-duplicates
+ (append (mapcar #'table-sql-expr sclasses)
+ (mapcan #'(lambda (jc-list)
+ (mapcar
+ #'(lambda (jc) (when jc (table-sql-expr jc)))
+ jc-list))
+ immediate-join-classes)
+ sel-tables)
+ :test #'tables-equal)))
(order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
- (listify order-by))))
-
+ (listify order-by)))
+ (join-where nil))
+
+
+ ;;(format t "sclasses: ~W~%ijc: ~W~%tables: ~W~%" sclasses immediate-join-classes tables)
+
(dolist (ob order-by-slots)
(when (and ob (not (member ob (mapcar #'cdr fullsels)
:test #'ref-equal)))
(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))))))
+ (setq join-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 join-where (listify join-where))))))
jclasses jslots)))
sclasses immediate-join-classes immediate-join-slots)
+ (when where
+ (setq where (listify where)))
+ (cond
+ ((and where join-where)
+ (setq where (list (apply #'sql-and where join-where))))
+ ((and (null where) (> (length join-where) 1))
+ (setq where (list (apply #'sql-and join-where)))))
+
(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))
+ (when where
+ (list :where where))
args)))
(instances-to-add (- (length rows) (length instances)))
(perhaps-extended-instances
(defmethod instance-refreshed ((instance standard-db-object)))
+(defvar *default-caching* t
+ "Controls whether SELECT caches objects by default. The CommonSQL
+specification states caching is on by default.")
+
(defun select (&rest select-all-args)
"Executes a query on DATABASE, which has a default value of
*DEFAULT-DATABASE*, specified by the SQL expressions supplied
(cond
((select-objects target-args)
- (let ((caching (getf qualifier-args :caching t))
+ (let ((caching (getf qualifier-args :caching *default-caching*))
(result-types (getf qualifier-args :result-types :auto))
(refresh (getf qualifier-args :refresh nil))
(database (or (getf qualifier-args :database) *default-database*))
(unless (record-caches database)
(setf (record-caches database)
(make-hash-table :test 'equal
- #+allegro :values #+allegro :weak
+ #+allegro :values #+allegro :weak
+ #+clisp :weak #+clisp :value
#+lispworks :weak-kind #+lispworks :value)))
(setf (gethash (compute-records-cache-key targets qualifiers)
(record-caches database)) results)
projects / clsql.git / blobdiff