(in-package #:clsql-sys)
(defclass standard-db-object ()
- ((view-database
- :initform nil
- :initarg :view-database
+ ((view-database :initform nil :initarg :view-database :reader view-database
:db-kind :virtual))
(:metaclass standard-db-class)
(:documentation "Superclass for all CLSQL View Classes."))
-(defmethod view-database ((self standard-db-object))
- (slot-value self 'view-database))
-
(defvar *db-deserializing* nil)
(defvar *db-initializing* nil)
-(defmethod slot-value-using-class ((class standard-db-class) instance slot)
+(defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
(declare (optimize (speed 3)))
(unless *db-deserializing*
- (let ((slot-name (%slot-name slot))
- (slot-object (%slot-object slot class)))
- (when (and (eql (view-class-slot-db-kind slot-object) :join)
+ (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)))
+ (when (and (eql slot-kind :join)
(not (slot-boundp instance slot-name)))
(let ((*db-deserializing* t))
(if (view-database instance)
(declare (ignore new-value instance slot))
(call-next-method))
-;; JMM - Can't go around trying to slot-access a symbol! Guess in
-;; CMUCL slot-name is the actual slot _object_, while in lispworks it
-;; is a lowly symbol (the variable is called slot-name after all) so
-;; the object (or in MOP terminology- the "slot definition") has to be
-;; retrieved using find-slot-definition
-
-(defun %slot-name (slot)
- #+lispworks slot
- #-lispworks (slot-definition-name slot))
-
-(defun %slot-object (slot class)
- (declare (ignorable class))
- #+lispworks (clos:find-slot-definition slot class)
- #-lispworks slot)
-
(defmethod initialize-instance :around ((class standard-db-object)
- &rest all-keys
- &key &allow-other-keys)
+ &rest all-keys &key &allow-other-keys)
(declare (ignore all-keys))
(let ((*db-deserializing* t))
(call-next-method)))
(database-output-sql keylist database)))))
-#.(locally-enable-sql-reader-syntax)
-
-(defun ensure-schema-version-table (database)
- (unless (table-exists-p "clsql_object_v" :database database)
- (create-table [clsql_object_v] '(([name] string)
- ([vers] integer)
- ([def] string))
- :database database)))
-
-(defun update-schema-version-records (view-class-name
- &key (database *default-database*))
- (let ((schemadef nil)
- (tclass (find-class view-class-name)))
- (dolist (slotdef (class-slots tclass))
- (let ((res (database-generate-column-definition view-class-name
- slotdef database)))
- (when res (setf schemadef (cons res schemadef)))))
- (when schemadef
- (delete-records :from [clsql_object_v]
- :where [= [name] (sql-escape (class-name tclass))]
- :database database)
- (insert-records :into [clsql_object_v]
- :av-pairs `(([name] ,(sql-escape (class-name tclass)))
- ([vers] ,(car (object-version tclass)))
- ([def] ,(prin1-to-string
- (object-definition tclass))))
- :database database))))
-
-#.(restore-sql-reader-syntax-state)
-
(defun create-view-from-class (view-class-name
&key (database *default-database*))
"Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
(let ((tclass (find-class view-class-name)))
(if tclass
(let ((*default-database* database))
- (%install-class tclass database)
- (ensure-schema-version-table database)
- (update-schema-version-records view-class-name :database database))
+ (%install-class tclass database))
(error "Class ~s not found." view-class-name)))
(values))
(defmethod %install-class ((self standard-db-class) database &aux schemadef)
- (dolist (slotdef (class-slots self))
+ (dolist (slotdef (ordered-class-slots self))
(let ((res (database-generate-column-definition (class-name self)
slotdef database)))
(when res
(let ((tclass (find-class view-class-name)))
(if tclass
(let ((*default-database* database))
- (%uninstall-class tclass)
- (delete-records :from [clsql_object_v]
- :where [= [name] (sql-escape view-class-name)]))
+ (%uninstall-class tclass))
(error "Class ~s not found." view-class-name)))
(values))
(defun generate-selection-list (vclass)
(let ((sels nil))
- (dolist (slotdef (class-slots vclass))
+ (dolist (slotdef (ordered-class-slots vclass))
(let ((res (generate-attribute-reference vclass slotdef)))
(when res
(push (cons slotdef res) sels))))
list))
(defun slot-type (slotdef)
- (let ((slot-type (slot-definition-type slotdef)))
- (if (listp slot-type)
- (cons (find-symbol (symbol-name (car slot-type)) :clsql-sys)
- (cdr slot-type))
- (find-symbol (symbol-name slot-type) :clsql-sys))))
+ (specified-type slotdef))
+
+(defvar *update-context* nil)
(defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
(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)))
+ (let* ((slot-reader (view-class-slot-db-reader slotdef))
+ (slot-name (slot-definition-name slotdef))
+ (slot-type (slot-type slotdef))
+ (*update-context* (cons (type-of instance) slot-name)))
(cond ((and value (null slot-reader))
(setf (slot-value instance slot-name)
(read-sql-value value (delistify slot-type)
(mapc #'update-slot slotdeflist values)
obj))
-
-(defun synchronize-keys (src srckey dest destkey)
- (let ((skeys (if (listp srckey) srckey (list srckey)))
- (dkeys (if (listp destkey) destkey (list destkey))))
- (mapcar #'(lambda (sk dk)
- (setf (slot-value dest dk)
- (typecase sk
- (symbol
- (slot-value src sk))
- (t sk))))
- skeys dkeys)))
-
-(defun desynchronize-keys (dest destkey)
- (let ((dkeys (if (listp destkey) destkey (list destkey))))
- (mapcar #'(lambda (dk)
- (setf (slot-value dest dk) nil))
- dkeys)))
-
-(defmethod add-to-relation ((target standard-db-object)
- slot-name
- (value standard-db-object))
- (let* ((objclass (class-of target))
- (sdef (or (slotdef-for-slot-with-class slot-name objclass)
- (error "~s is not an known slot on ~s" slot-name target)))
- (dbinfo (view-class-slot-db-info sdef))
- (join-class (gethash :join-class dbinfo))
- (homekey (gethash :home-key dbinfo))
- (foreignkey (gethash :foreign-key dbinfo))
- (to-many (gethash :set dbinfo)))
- (unless (equal (type-of value) join-class)
- (error 'clsql-type-error :slotname slot-name :typespec join-class
- :value value))
- (when (gethash :target-slot dbinfo)
- (error "add-to-relation does not work with many-to-many relations yet."))
- (if to-many
- (progn
- (synchronize-keys target homekey value foreignkey)
- (if (slot-boundp target slot-name)
- (unless (member value (slot-value target slot-name))
- (setf (slot-value target slot-name)
- (append (slot-value target slot-name) (list value))))
- (setf (slot-value target slot-name) (list value))))
- (progn
- (synchronize-keys value foreignkey target homekey)
- (setf (slot-value target slot-name) value)))))
-
-(defmethod remove-from-relation ((target standard-db-object)
- slot-name (value standard-db-object))
- (let* ((objclass (class-of target))
- (sdef (slotdef-for-slot-with-class slot-name objclass))
- (dbinfo (view-class-slot-db-info sdef))
- (homekey (gethash :home-key dbinfo))
- (foreignkey (gethash :foreign-key dbinfo))
- (to-many (gethash :set dbinfo)))
- (when (gethash :target-slot dbinfo)
- (error "remove-relation does not work with many-to-many relations yet."))
- (if to-many
- (progn
- (desynchronize-keys value foreignkey)
- (if (slot-boundp target slot-name)
- (setf (slot-value target slot-name)
- (remove value
- (slot-value target slot-name)
- :test #'equal))))
- (progn
- (desynchronize-keys target homekey)
- (setf (slot-value target slot-name)
- nil)))))
-
(defgeneric update-record-from-slot (object slot &key database)
(:documentation
"The generic function UPDATE-RECORD-FROM-SLOT updates an individual
(db-value-from-slot slot value database)))))
(let* ((view-class (class-of obj))
(view-class-table (view-table view-class))
- (slots (remove-if-not #'slot-storedp (class-slots view-class)))
+ (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))
(record-values (mapcar #'slot-value-list slots)))
(unless record-values
(error "No settable slots."))
(db-value-from-slot slot value database)))))
(let* ((view-class (class-of obj))
(view-class-table (view-table view-class))
- (slots (remove-if-not #'slot-storedp (class-slots view-class)))
+ (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))
(record-values (mapcar #'slot-value-list slots)))
(unless record-values
(error "No settable slots."))
(setf (slot-value obj 'view-database) database))
(values)))
-;; Perhaps the slot class is not correct in all CLOS implementations,
-;; tho I have not run across a problem yet.
-
(defmethod handle-cascade-delete-rule ((instance standard-db-object)
(slot
view-class-effective-slot-definition))
(let* ((view-class (class-of instance))
(joins (remove-if #'(lambda (sd)
(not (equal (view-class-slot-db-kind sd) :join)))
- (class-slots view-class))))
+ (ordered-class-slots view-class))))
(dolist (slot joins)
(let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot))))
(cond
(res (apply #'select (append (mapcar #'cdr sels)
(list :from view-table
:where view-qual)))))
- (get-slot-values-from-view instance (mapcar #'car sels) (car res))))
+ (when res
+ (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
(defgeneric update-slot-from-record (instance slot &key database)
(:documentation
nil, otherwise its value will be set to the result of calling
DATABASE-NULL-VALUE on the type of the slot."))
-(defmethod update-slot-with-null ((instance standard-db-object)
+(defmethod update-slot-with-null ((object standard-db-object)
slotname
slotdef)
(let ((st (slot-type slotdef))
(allowed (slot-value slotdef 'nulls-ok)))
(if allowed
- (setf (slot-value instance slotname) nil)
- (setf (slot-value instance slotname)
+ (setf (slot-value object slotname) nil)
+ (setf (slot-value object slotname)
(database-null-value st)))))
(defvar +no-slot-value+ '+no-slot-value+)
(defmethod read-sql-value (val (type (eql 'symbol)) database)
(declare (ignore database))
(when (< 0 (length val))
- (if (find #\: val)
- (read-from-string val)
- (intern (string-upcase val) "KEYWORD"))))
+ (unless (string= val "NIL")
+ (intern (string-upcase val)
+ (symbol-package *update-context*)))))
(defmethod read-sql-value (val (type (eql 'integer)) database)
(declare (ignore database))
;; ------------------------------------------------------------
;; Logic for 'faulting in' :join slots
-(defun fault-join-slot-raw (class instance slot-def)
+(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 instance slot-def)))
+ (let ((jq (join-qualifier class object slot-def)))
(when jq
(select jc :where jq)))))
-(defun fault-join-slot (class instance slot-def)
+(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 instance slot-def)))
+ (res (fault-join-slot-raw class object slot-def)))
(when res
(cond
((and ts (gethash :set dbi))
((and (not ts) (gethash :set dbi))
res)))))
-(defun join-qualifier (class instance slot-def)
+(defun join-qualifier (class object slot-def)
(declare (ignore class))
(let* ((dbi (view-class-slot-db-info slot-def))
(jc (find-class (gethash :join-class dbi)))
(foreign-keys (gethash :foreign-key dbi))
(home-keys (gethash :home-key dbi)))
(when (every #'(lambda (slt)
- (and (slot-boundp instance slt)
- (not (null (slot-value instance slt)))))
+ (and (slot-boundp object slt)
+ (not (null (slot-value object slt)))))
(if (listp home-keys) home-keys (list home-keys)))
(let ((jc
(mapcar #'(lambda (hk fk)
(t fk))
(typecase hk
(symbol
- (slot-value instance hk))
+ (slot-value object hk))
(t
hk)))))
(if (listp home-keys)
(apply #'sql-and jc)
jc))))))
+(defmethod postinitialize ((self t))
+ )
(defun find-all (view-classes &rest args &key all set-operation distinct from
where group-by having order-by order-by-descending offset limit
(postinitialize obj)
obj))
-(defmethod postinitialize ((self t))
- )
-
(defun 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
target-args))))
(multiple-value-bind (target-args qualifier-args)
(query-get-selections select-all-args)
+ ;; (cmsg "Qual args = ~s" qualifier-args)
(if (select-objects target-args)
(apply #'find-all target-args qualifier-args)
(let ((expr (apply #'make-query select-all-args)))
projects / clsql.git / blobdiff