X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=627989b104c1da1b34f47b68f9ff7a4eb511ca08;hb=b43e20a168dae4ae9d176ebc0fbf18ea6e4517dc;hp=a995c221fcf2b996e77de512bed0866cfb25cf38;hpb=1751e5245c270bd1ee854a98dfe6caa665abe34e;p=clsql.git diff --git a/sql/objects.lisp b/sql/objects.lisp index a995c22..627989b 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -13,7 +13,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql-sys) +(in-package #:clsql) (defclass standard-db-object () ((view-database :initform nil :initarg :view-database :reader view-database @@ -97,7 +97,7 @@ the view. The argument DATABASE has a default value of (when (member (view-class-slot-db-kind slotdef) '(:base :key)) (let ((cdef (list (sql-expression :attribute (view-class-slot-column slotdef)) - (slot-type slotdef)))) + (specified-type slotdef)))) (setf cdef (append cdef (list (view-class-slot-db-type slotdef)))) (let ((const (view-class-slot-db-constraints slotdef))) (when const @@ -169,8 +169,9 @@ superclass of the newly-defined View Class." (defclass ,class ,supers ,slots ,@(if (find :metaclass `,cl-options :key #'car) `,cl-options - (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) - (finalize-inheritance (find-class ',class)))) + (cons '(:metaclass clsql::standard-db-class) `,cl-options))) + (finalize-inheritance (find-class ',class)) + (find-class ',class))) (defun keyslots-for-class (class) (slot-value class 'key-slots)) @@ -232,16 +233,13 @@ superclass of the newly-defined View Class." (car list) list)) -(defun slot-type (slotdef) - (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)) + (slot-type (specified-type slotdef)) (*update-context* (cons (type-of instance) slot-name))) (cond ((and value (null slot-reader)) (setf (slot-value instance slot-name) @@ -261,7 +259,7 @@ superclass of the newly-defined View Class." (defmethod key-value-from-db (slotdef value database) (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) (let ((slot-reader (view-class-slot-db-reader slotdef)) - (slot-type (slot-type slotdef))) + (slot-type (specified-type slotdef))) (cond ((and value (null slot-reader)) (read-sql-value value (delistify slot-type) database)) ((null value) @@ -275,7 +273,7 @@ superclass of the newly-defined View Class." (defun db-value-from-slot (slotdef val database) (let ((dbwriter (view-class-slot-db-writer slotdef)) - (dbtype (slot-type slotdef))) + (dbtype (specified-type slotdef))) (typecase dbwriter (string (format nil dbwriter val)) (function (apply dbwriter (list val))) @@ -287,7 +285,7 @@ superclass of the newly-defined View Class." (database-output-sql-as-type dbtype val database))))))) (defun check-slot-type (slotdef val) - (let* ((slot-type (slot-type slotdef)) + (let* ((slot-type (specified-type slotdef)) (basetype (if (listp slot-type) (car slot-type) slot-type))) (when (and slot-type val) (unless (typep val basetype) @@ -397,7 +395,7 @@ superclass of the newly-defined View Class." (let ((qualifier (key-qualifier-for-instance instance :database vd))) (delete-records :from vt :where qualifier :database vd) (setf (slot-value instance 'view-database) nil)) - (error 'clsql-no-database-error nil)))) + (error 'clsql-base::clsql-no-database-error :database nil)))) (defmethod update-instance-from-records ((instance standard-db-object) &key (database *default-database*)) @@ -430,9 +428,7 @@ superclass of the newly-defined View Class." (defmethod update-slot-with-null ((object standard-db-object) slotname slotdef) - (let ((st (slot-type slotdef)) - (void-value (slot-value slotdef 'void-value))) - (setf (slot-value object slotname) void-value))) + (setf (slot-value object slotname) (slot-value slotdef 'void-value))) (defvar +no-slot-value+ '+no-slot-value+) @@ -470,6 +466,10 @@ superclass of the newly-defined View Class." (format nil "INT(~A)" (car args)) "INT")) +(deftype bigint () + "An integer larger than a 32-bit integer, this width may vary by SQL implementation." + 'integer) + (defmethod database-get-type-specifier ((type (eql 'bigint)) args database) (declare (ignore args database)) "BIGINT") @@ -500,6 +500,10 @@ superclass of the newly-defined View Class." "VARCHAR" "VARCHAR(255)"))) +(deftype universal-time () + "A positive integer as returned by GET-UNIVERSAL-TIME." + '(integer 1 *)) + (defmethod database-get-type-specifier ((type (eql 'universal-time)) args database) (declare (ignore args database)) "BIGINT") @@ -586,8 +590,11 @@ superclass of the newly-defined View Class." (prin1-to-string val))) (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database) - (declare (ignore database)) - (if val "t" "f")) + (case (database-underlying-type database) + (:mysql + (if val 1 0)) + (t + (if val "t" "f")))) (defmethod database-output-sql-as-type ((type (eql 'string)) val database) (declare (ignore database)) @@ -658,8 +665,17 @@ superclass of the newly-defined View Class." (float (read-from-string val))) (defmethod read-sql-value (val (type (eql 'boolean)) database) - (declare (ignore database)) - (equal "t" val)) + (case (database-underlying-type database) + (:mysql + (etypecase val + (string (if (string= "0" val) nil t)) + (integer (if (zerop val) nil t)))) + (:postgresql + (if (eq :odbc (database-type database)) + (if (string= "0" val) nil t) + (equal "t" val))) + (t + (equal "t" val)))) (defmethod read-sql-value (val (type (eql 'univeral-time)) database) (declare (ignore database)) @@ -785,7 +801,7 @@ superclass of the newly-defined View Class." objects)))) (let* ((*db-deserializing* t) (*default-database* (or database - (error 'clsql-no-database-error nil))) + (error 'clsql-base::clsql-no-database-error :database nil))) (sclasses (mapcar #'find-class view-classes)) (sels (mapcar #'generate-selection-list sclasses)) (fullsels (apply #'append sels))