X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fnew-objects.lisp;h=d2013b74009e325b04bf13968e9799bf6922bc1e;hp=fc050cb944584d361f884079782c889513fd3b15;hb=9bbed78051e80e6ab76ae47834136035602bbbf1;hpb=5068697a98c10224f3a3e0a7125ba64cf3d3b4fb diff --git a/sql/new-objects.lisp b/sql/new-objects.lisp index fc050cb..d2013b7 100644 --- a/sql/new-objects.lisp +++ b/sql/new-objects.lisp @@ -28,14 +28,15 @@ (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)) @@ -87,8 +88,6 @@ (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 @@ -97,9 +96,7 @@ the view. The argument DATABASE has a default value of (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)) @@ -130,10 +127,7 @@ which defines that view. The argument DATABASE has a default value of (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)) @@ -257,13 +251,7 @@ superclass of the newly-defined View Class." 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) @@ -336,75 +324,6 @@ superclass of the newly-defined View Class." (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 @@ -425,7 +344,7 @@ are derived from the View Class definition.")) (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) @@ -460,7 +379,7 @@ names are derived from the view class definition.")) (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) @@ -474,7 +393,6 @@ names are derived from the view class definition.")) (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 @@ -501,7 +419,7 @@ associated with that database.")) (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) @@ -516,6 +434,12 @@ associated with that 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*))) @@ -600,7 +524,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) (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)")) @@ -615,7 +539,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) 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)"))) @@ -623,20 +547,20 @@ DATABASE-NULL-VALUE on the type of the slot.")) 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 @@ -687,7 +611,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) (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)