X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fnew-objects.lisp;h=e7c49ce83f7616175c829f214e30151450dc69a0;hb=a4097e19c5157e87b9991549bc44f3ef598aeb90;hp=e5e06145e6aee105efff7ef5fee03331595a837e;hpb=e3f355aa2b125569097bd7108fbbd14daa23e7aa;p=clsql.git diff --git a/sql/new-objects.lisp b/sql/new-objects.lisp index e5e0614..e7c49ce 100644 --- a/sql/new-objects.lisp +++ b/sql/new-objects.lisp @@ -15,108 +15,48 @@ (in-package #:clsql-sys) - -;; utils - -(defun replaced-string-length (str repl-alist) - (declare (simple-string str) - (optimize (speed 3) (safety 0) (space 0))) - (do* ((i 0 (1+ i)) - (orig-len (length str)) - (new-len orig-len)) - ((= i orig-len) new-len) - (declare (fixnum i orig-len new-len)) - (let* ((c (char str i)) - (match (assoc c repl-alist :test #'char=))) - (declare (character c)) - (when match - (incf new-len (1- (length - (the simple-string (cdr match))))))))) - - -(defun substitute-chars-strings (str repl-alist) - "Replace all instances of a chars with a string. repl-alist is an assoc -list of characters and replacement strings." - (declare (simple-string str) - (optimize (speed 3) (safety 0) (space 0))) - (do* ((orig-len (length str)) - (new-string (make-string (replaced-string-length str repl-alist))) - (spos 0 (1+ spos)) - (dpos 0)) - ((>= spos orig-len) - new-string) - (declare (fixnum spos dpos) (simple-string new-string)) - (let* ((c (char str spos)) - (match (assoc c repl-alist :test #'char=))) - (declare (character c)) - (if match - (let* ((subst (cdr match)) - (len (length subst))) - (declare (fixnum len) - (simple-string subst)) - (dotimes (j len) - (declare (fixnum j)) - (setf (char new-string dpos) (char subst j)) - (incf dpos))) - (progn - (setf (char new-string dpos) c) - (incf dpos)))))) - -(defun string-replace (procstr match-char subst-str) - "Substitutes a string for a single matching character of a string" - (substitute-chars-strings procstr (list (cons match-char subst-str)))) - - (defclass standard-db-object () ((stored :db-kind :virtual :initarg :stored :initform nil)) - (:metaclass view-metaclass) + (:metaclass standard-db-class) (:documentation "Superclass for all CLSQL View Classes.")) -(defvar *deserializing* nil) -(defvar *initializing* nil) +(defvar *db-deserializing* nil) +(defvar *db-initializing* nil) -(defmethod initialize-instance :around ((object standard-db-object) - &rest all-keys &key &allow-other-keys) - (declare (ignore all-keys)) - (let ((*initializing* t)) - (call-next-method) - (unless *deserializing* - #+nil (created-object object) - (update-records-from-instance object)))) - -(defmethod slot-value-using-class ((class view-metaclass) instance slot-def) +(defmethod slot-value-using-class ((class standard-db-class) instance slot-def) (declare (optimize (speed 3))) - (unless *deserializing* - (let ((slot-name (%slot-def-name slot-def)) - (slot-kind (view-class-slot-db-kind slot-def))) + (unless *db-deserializing* + (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 ((*deserializing* t)) + (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 view-metaclass) instance slot-def) +(defmethod (setf slot-value-using-class) :around (new-value (class standard-db-class) instance slot-def) (declare (ignore new-value)) - (let* ((slot-name (%slot-def-name slot-def)) + (let* ((slot-name (slot-definition-name slot-def)) (slot-kind (view-class-slot-db-kind slot-def)) (no-update? (or (eql slot-kind :virtual) - *initializing* - *deserializing*))) + *db-initializing* + *db-deserializing*))) (call-next-method) (unless no-update? (update-record-from-slot instance slot-name)))) -(defun %slot-def-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 ((object standard-db-object) + &rest all-keys &key &allow-other-keys) + (declare (ignore all-keys)) + (let ((*db-initializing* t)) + (call-next-method) + (unless *db-deserializing* + #+nil (created-object object) + (update-records-from-instance object)))) (defun sequence-from-class (view-class-name) (sql-escape @@ -140,7 +80,7 @@ list of characters and replacement strings." ;; Build the database tables required to store the given view class ;; -(defmethod database-pkey-constraint ((class view-metaclass) database) +(defmethod database-pkey-constraint ((class standard-db-class) database) (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))) (when keylist (format nil "CONSTRAINT ~APK PRIMARY KEY~A" @@ -148,40 +88,6 @@ list of characters and replacement strings." (database-output-sql keylist database))))) - -#+noschema -(progn -#.(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 @@ -190,13 +96,11 @@ 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)) -(defmethod %install-class ((self view-metaclass) database &aux schemadef) +(defmethod %install-class ((self standard-db-class) database &aux schemadef) (dolist (slotdef (ordered-class-slots self)) (let ((res (database-generate-column-definition (class-name self) slotdef database))) @@ -223,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)) @@ -271,7 +172,7 @@ SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the superclass of the newly-defined View Class." `(progn (defclass ,class ,supers ,slots ,@options - (:metaclass view-metaclass)) + (:metaclass standard-db-class)) (finalize-inheritance (find-class ',class)))) (defun keyslots-for-class (class) @@ -350,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) @@ -429,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 @@ -518,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) @@ -553,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) @@ -567,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 @@ -594,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) @@ -609,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*))) @@ -780,9 +611,8 @@ 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))) - (setf escaped (string-replace #\Null " " escaped)) - escaped))) - + (clsql-base-sys::substitute-char-string + escaped #\Null " ")))) (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) (declare (ignore database)) @@ -958,9 +788,9 @@ DATABASE-NULL-VALUE on the type of the slot.")) (optimize (debug 3) (speed 1))) ;; (cmsg "Args = ~s" args) (remf args :from) - (let* ((*deserializing* t) + (let* ((*db-deserializing* t) (*default-database* (or database - (error 'usql-nodb-error)))) + (error 'clsql-no-database-error nil)))) (flet ((table-sql-expr (table) (sql-expression :table (view-table table))) (ref-equal (ref1 ref2) @@ -1010,7 +840,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) (mapcar #'build-object res)))))) (defun %make-fresh-object (class-name slots values) - (let* ((*initializing* t) + (let* ((*db-initializing* t) (obj (make-instance class-name :stored t))) (setf obj (get-slot-values-from-view obj slots values))