(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
;; 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"
(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
(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)))
(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))
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)
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)))
- (setf escaped (string-replace #\Null " " escaped))
- escaped)))
-
+ (clsql-base::substitute-char-string
+ escaped #\Null " "))))
(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
(declare (ignore database))
(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)
(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))
projects / clsql.git / blobdiff