((typep slot-reader 'string)
(setf (slot-value instance slot-name)
(format nil slot-reader value)))
- ((typep slot-reader 'function)
+ ((typep slot-reader '(or symbol function))
(setf (slot-value instance slot-name)
(apply slot-reader (list value))))
(t
nil)
((typep slot-reader 'string)
(format nil slot-reader value))
- ((typep slot-reader 'function)
+ ((typep slot-reader '(or symbol function))
(apply slot-reader (list value)))
(t
(error "Slot reader is of an unusual type.")))))
(dbtype (specified-type slotdef)))
(typecase dbwriter
(string (format nil dbwriter val))
- (function (apply dbwriter (list val)))
+ ((and (or symbol function) (not null)) (apply dbwriter (list val)))
(t
(database-output-sql-as-type
(typecase dbtype
(error "Unable to update records"))))
(values))
-(defmethod update-records-from-instance ((obj standard-db-object)
- &key (database *default-database*))
- (let ((database (or (view-database obj) database)))
+(defmethod update-records-from-instance ((obj standard-db-object) &key database)
+ (let ((database (or database (view-database obj) *default-database*)))
(labels ((slot-storedp (slot)
(and (member (view-class-slot-db-kind slot) '(:base :key))
(slot-boundp obj (slot-definition-name slot))))
(if vd
(let ((qualifier (key-qualifier-for-instance instance :database vd)))
(delete-records :from vt :where qualifier :database vd)
- (setf (records-caches vd) nil)
+ (setf (record-caches vd) nil)
(setf (slot-value instance 'view-database) nil)
(values))
(signal-no-database-error vd))))
(sels (generate-selection-list view-class))
(res (apply #'select (append (mapcar #'cdr sels)
(list :from view-table
- :where view-qual)
- (list :result-types nil)))))
+ :where view-qual
+ :result-types nil
+ :database vd)))))
(when res
(get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
(declare (ignore args database db-type))
"TIMESTAMP")
+(defmethod database-get-type-specifier ((type (eql 'date)) args database db-type)
+ (declare (ignore args database db-type))
+ "DATE")
+
(defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type)
(declare (ignore database args db-type))
"VARCHAR")
(unless (eq 'NULL val)
(parse-timestring val)))
+(defmethod read-sql-value (val (type (eql 'date)) database db-type)
+ (declare (ignore database db-type))
+ (unless (eq 'NULL val)
+ (parse-datestring val)))
+
(defmethod read-sql-value (val (type (eql 'duration)) database db-type)
(declare (ignore database db-type))
(unless (or (eq 'NULL val)
(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)))
+ (ts (gethash :target-slot dbi))
+ (jc (gethash :join-class dbi))
(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)))
+ (tdbi (view-class-slot-db-info
+ (find ts (class-slots (find-class jc))
+ :key #'slot-definition-name)))
(retrieval (gethash :retrieval tdbi))
+ (tsc (gethash :join-class tdbi))
+ (ts-view-table (view-table (find-class tsc)))
(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)
+ (find-all (list tsc)
:inner-join (sql-expression :table jc-view-table)
:on (sql-operation
'==
: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))))
;; just fill in minimal slots
(mapcar
#'(lambda (k)
- (let ((instance (make-instance ts :view-database (view-database object)))
+ (let ((instance (make-instance tsc :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)
(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
(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))
- :result-types :auto
- :flatp t)))
+ (results (unless (gethash :target-slot dbi)
+ (find-all (list (gethash :join-class dbi))
+ :where (make-instance 'sql-relational-exp
+ :operator 'in
+ :sub-expressions (list (sql-expression :attribute foreign-key)
+ keys))
+ :result-types :auto
+ :flatp t)) ))
(dolist (object objects)
(when (or force-p (not (slot-boundp object slotdef-name)))
- (let ((res (remove-if-not #'(lambda (obj)
- (equal obj (slot-value
- object
- home-key)))
- results
- :key #'(lambda (res)
- (slot-value res
- foreign-key)))))
+ (let ((res (if results
+ (remove-if-not #'(lambda (obj)
+ (equal obj (slot-value
+ object
+ home-key)))
+ results
+ :key #'(lambda (res)
+ (slot-value res
+ foreign-key)))
+
+ (progn
+ (when (gethash :target-slot dbi)
+ (fault-join-target-slot class object slotdef))))))
(when res
(setf (slot-value object slotdef-name)
(if (gethash :set dbi) res (car res)))))))))))))