(defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
(declare (optimize (speed 3)))
(unless *db-deserializing*
- (let ((slot-name (slot-defition-name-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)))
(when (and (eql slot-kind :join)
(not (slot-boundp instance slot-name)))
(let ((*db-deserializing* t))
(setf (slot-value instance slot-name)
(fault-join-slot class instance slot-def))))))
- (call-next-method))
+ (call-next-method))
(defmethod (setf slot-value-using-class) :around (new-value (class standard-db-class) instance slot-def)
(declare (ignore new-value))
(database-output-sql keylist database)))))
-
-
(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)
- #+noschema (ensure-schema-version-table database)
- #+noschema (update-schema-version-records view-class-name :database database))
+ (%install-class tclass database))
(error "Class ~s not found." view-class-name)))
(values))
(let ((tclass (find-class view-class-name)))
(if tclass
(let ((*default-database* database))
- (%uninstall-class tclass)
- #+nil
- (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))
list))
(defun slot-type (slotdef)
- (specified-type slotdef)
- #+ignore
- (let ((slot-type (specified-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)
(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
(let* ((att (view-class-slot-column sd))
(val (db-value-from-slot sd (slot-value obj slot) database)))
(cond ((and vct sd stored?)
- (update-records :table (sql-expression :table vct)
+ (update-records (sql-expression :table vct)
:attributes (list (sql-expression :attribute att))
:values (list val)
:where (key-qualifier-for-instance obj :database database)
(db-value-from-slot s val database))))
sds)))
(cond ((and avps stored?)
- (update-records :table (sql-expression :table vct)
+ (update-records (sql-expression :table vct)
:av-pairs avps
:where (key-qualifier-for-instance
obj :database database)
(error "Unable to update records"))))
t)
-
(defgeneric update-records-from-instance (object &key database)
(:documentation
"Using an instance of a view class, update the database table that
(unless record-values
(error "No settable slots."))
(if (slot-value obj 'stored)
- (update-records :table (sql-expression :table view-class-table)
+ (update-records (sql-expression :table view-class-table)
:av-pairs record-values
:where (key-qualifier-for-instance
obj :database database)
(setf (symbol-function (intern (symbol-name '#:store-instance)))
(symbol-function 'update-records-from-instance))
+(defgeneric delete-instance-records (instance)
+ (:documentation
+ "Deletes the records represented by INSTANCE from the database
+associated with it. If instance has no associated database, an error
+is signalled."))
+
(defmethod delete-instance-records ((object standard-db-object))
(let ((vt (sql-expression :table (view-table (class-of object))))
(qualifier (key-qualifier-for-instance object :database *default-database*)))
(defmethod database-get-type-specifier (type args database)
(declare (ignore type args))
- (if (member (database-type database) '(:postgresql :postgresql-socket))
+ (if (member (database-underlying-type database) '(:postgresql :postgresql-socket))
"VARCHAR"
"VARCHAR(255)"))
database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (member (database-type database) '(:postgresql :postgresql-socket))
+ (if (member (database-underlying-type database) '(:postgresql :postgresql-socket))
"VARCHAR"
"VARCHAR(255)")))
database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (member (database-type database) '(:postgresql :postgresql-socket))
+ (if (member (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 (member (database-type database) '(:postgresql :postgresql-socket))
+ (if (member (database-underlying-type database) '(:postgresql :postgresql-socket))
"VARCHAR"
"VARCHAR(255)")))
(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
(declare (ignore args))
- (case (database-type database)
+ (case (database-underlying-type database)
(:postgresql
"TIMESTAMP WITHOUT TIME ZONE")
(:postgresql-socket
(declare (ignore database))
(progv '(*print-circle* *print-array*) '(t t)
(let ((escaped (prin1-to-string val)))
- (clsql-base-sys::substitute-char-string
+ (clsql-base::substitute-char-string
escaped #\Null " "))))
(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
projects / clsql.git / blobdiff