X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Foodml.lisp;h=78fd88648db8ca12cd081605d7d7bcf84d3c5e6c;hp=8b1d0ef7b6b436c136f8850768442f16efaeb0e0;hb=b5890c31a60303397efedb2110f46c6388426170;hpb=7c7edf1d85706148f55a8507a261d024defa0c7c diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 8b1d0ef..78fd886 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -87,14 +87,11 @@ ;; Called by 'get-slot-values-from-view' ;; -(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 (specified-type slotdef)) - (*update-context* (cons (type-of instance) slot-name))) + (slot-type (specified-type slotdef))) (cond ((and value (null slot-reader)) (setf (slot-value instance slot-name) (read-sql-value value (delistify slot-type) @@ -310,17 +307,31 @@ (sql-expression :table (view-table class)))) -(defparameter *default-varchar-length* 255) - (defmethod database-get-type-specifier (type args database db-type) (declare (ignore type args database db-type)) - (format nil "VARCHAR(~D)" *default-varchar-length*)) + (format nil "VARCHAR(~D)" *default-string-length*)) (defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type) (declare (ignore database db-type)) (if args (format nil "INT(~A)" (car args)) - "INT")) + "INT")) + +(deftype tinyint () + "An 8-bit integer, this width may vary by SQL implementation." + 'integer) + +(defmethod database-get-type-specifier ((type (eql 'tinyint)) args database db-type) + (declare (ignore args database db-type)) + "INT") + +(deftype smallint () + "An integer smaller than a 32-bit integer, this width may vary by SQL implementation." + 'integer) + +(defmethod database-get-type-specifier ((type (eql 'smallint)) args database db-type) + (declare (ignore args database db-type)) + "INT") (deftype bigint () "An integer larger than a 32-bit integer, this width may vary by SQL implementation." @@ -339,13 +350,13 @@ (declare (ignore database db-type)) (if args (format nil "VARCHAR(~A)" (car args)) - (format nil "VARCHAR(~D)" *default-varchar-length*))) + (format nil "VARCHAR(~D)" *default-string-length*))) (defmethod database-get-type-specifier ((type (eql 'string)) args database db-type) (declare (ignore database db-type)) (if args (format nil "CHAR(~A)" (car args)) - (format nil "VARCHAR(~D)" *default-varchar-length*))) + (format nil "VARCHAR(~D)" *default-string-length*))) (deftype universal-time () "A positive integer as returned by GET-UNIVERSAL-TIME." @@ -384,10 +395,18 @@ (format nil "FLOAT(~A)" (car args)) "FLOAT")) +(deftype generalized-boolean () + "A type which outputs a SQL boolean value, though any lisp type can be stored in the slot." + t) + (defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type) (declare (ignore args database db-type)) "BOOL") +(defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args database db-type) + (declare (ignore args database db-type)) + "BOOL") + (defmethod database-get-type-specifier ((type (eql 'number)) args database db-type) (declare (ignore database db-type)) (cond @@ -418,14 +437,12 @@ (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type) (declare (ignore database db-type)) - (if (keywordp val) - (symbol-name val) - (if val - (concatenate 'string - (package-name (symbol-package val)) - "::" - (symbol-name val)) - ""))) + (if val + (concatenate 'string + (package-name (symbol-package val)) + "::" + (symbol-name val)) + "")) (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type) (declare (ignore database db-type)) @@ -447,6 +464,10 @@ (declare (ignore database db-type)) (if val "t" "f")) +(defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database db-type) + (declare (ignore database db-type)) + (if val "t" "f")) + (defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type) (declare (ignore database db-type)) val) @@ -484,8 +505,7 @@ (declare (ignore database db-type)) (when (< 0 (length val)) (unless (string= val (symbol-name-default-case "NIL")) - (intern (symbol-name-default-case val) - (symbol-package *update-context*))))) + (read-from-string val)))) (defmethod read-sql-value (val (type (eql 'integer)) database db-type) (declare (ignore database db-type)) @@ -495,6 +515,14 @@ (parse-integer val))) (number val))) +(defmethod read-sql-value (val (type (eql 'smallint)) database db-type) + (declare (ignore database db-type)) + (etypecase val + (string + (unless (string-equal "NIL" val) + (parse-integer val))) + (number val))) + (defmethod read-sql-value (val (type (eql 'bigint)) database db-type) (declare (ignore database db-type)) (etypecase val @@ -516,6 +544,10 @@ (declare (ignore database db-type)) (equal "t" val)) +(defmethod read-sql-value (val (type (eql 'generalized-boolean)) database db-type) + (declare (ignore database db-type)) + (equal "t" val)) + (defmethod read-sql-value (val (type (eql 'number)) database db-type) (declare (ignore database db-type)) (etypecase val @@ -1071,3 +1103,27 @@ as elements of a list." results) + +;;; Serialization functions + +(defun write-instance-to-stream (obj stream) + "Writes an instance to a stream where it can be later be read. +NOTE: an error will occur if a slot holds a value which can not be written readably." + (let* ((class (class-of obj)) + (alist '())) + (dolist (slot (ordered-class-slots (class-of obj))) + (let ((name (slot-definition-name slot))) + (when (and (not (eq 'view-database name)) + (slot-boundp obj name)) + (push (cons name (slot-value obj name)) alist)))) + (setq alist (reverse alist)) + (write (cons (class-name class) alist) :stream stream :readably t)) + obj) + +(defun read-instance-from-stream (stream) + (let ((raw (read stream nil nil))) + (when raw + (let ((obj (make-instance (car raw)))) + (dolist (pair (cdr raw)) + (setf (slot-value obj (car pair)) (cdr pair))) + obj))))