;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;;
-;;;; $Id:
+;;;; $Id$
;;;;
;;;; The CLSQL Object Oriented Data Manipulation Language (OODML).
;;;;
;; 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)
(error "No view-table for class ~A" classname))
(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))
- "VARCHAR(255)")
+ (format nil "VARCHAR(~D)" *default-varchar-length*))
(defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type)
(declare (ignore database db-type))
(defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type)
(declare (ignore args database db-type))
"BIGINT")
-
-(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
- database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "VARCHAR(~A)" (car args))
- "VARCHAR(255)"))
-(defmethod database-get-type-specifier ((type (eql 'simple-string)) args
+(deftype varchar ()
+ "A variable length string for the SQL varchar type."
+ 'string)
+
+(defmethod database-get-type-specifier ((type (eql 'varchar)) args
database db-type)
(declare (ignore database db-type))
(if args
(format nil "VARCHAR(~A)" (car args))
- "VARCHAR(255)"))
+ (format nil "VARCHAR(~D)" *default-varchar-length*)))
(defmethod database-get-type-specifier ((type (eql 'string)) args database db-type)
(declare (ignore database db-type))
(if args
- (format nil "VARCHAR(~A)" (car args))
- "VARCHAR(255)"))
+ (format nil "CHAR(~A)" (car args))
+ (format nil "VARCHAR(~D)" *default-varchar-length*)))
(deftype universal-time ()
"A positive integer as returned by GET-UNIVERSAL-TIME."
(declare (ignore database args db-type))
"INT8")
-(deftype raw-string (&optional len)
- "A string which is not trimmed when retrieved from the database"
+#+ignore
+(deftype char (&optional len)
+ "A lisp type for the SQL CHAR type."
`(string ,len))
-(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "VARCHAR(~A)" (car args))
- "VARCHAR"))
-
(defmethod database-get-type-specifier ((type (eql 'float)) args database db-type)
(declare (ignore database db-type))
(if args
(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
+ ((and (consp args) (= (length args) 2))
+ (format nil "NUMBER(~D,~D)" (first args) (second args)))
+ ((and (consp args) (= (length args) 1))
+ (format nil "NUMBER(~D)" (first args)))
+ (t
+ "NUMBER")))
+
+(defmethod database-get-type-specifier ((type (eql 'char)) args database db-type)
+ (declare (ignore database db-type))
+ (if args
+ (format nil "CHAR(~D)" (first args))
+ "CHAR(1)"))
+
+
(defmethod database-output-sql-as-type (type val database db-type)
(declare (ignore type database db-type))
val)
(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))
(declare (ignore database db-type))
(if val "t" "f"))
-(defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type)
+(defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database db-type)
(declare (ignore database db-type))
- val)
+ (if val "t" "f"))
-(defmethod database-output-sql-as-type ((type (eql 'simple-string))
- val database db-type)
+(defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type)
(declare (ignore database db-type))
val)
-(defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
+(defmethod database-output-sql-as-type ((type (eql 'char))
val database db-type)
(declare (ignore database db-type))
- val)
+ (etypecase val
+ (character (write-to-string val))
+ (string val)))
(defmethod read-sql-value (val type database db-type)
(declare (ignore type database db-type))
(declare (ignore database db-type))
val)
-(defmethod read-sql-value (val (type (eql 'simple-string)) database db-type)
- (declare (ignore database db-type))
- val)
-
-(defmethod read-sql-value (val (type (eql 'simple-base-string)) database db-type)
+(defmethod read-sql-value (val (type (eql 'varchar)) database db-type)
(declare (ignore database db-type))
val)
-(defmethod read-sql-value (val (type (eql 'raw-string)) database db-type)
+(defmethod read-sql-value (val (type (eql 'char)) database db-type)
(declare (ignore database db-type))
- val)
-
+ (schar val 0))
+
(defmethod read-sql-value (val (type (eql 'keyword)) database db-type)
(declare (ignore database db-type))
(when (< 0 (length val))
(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))
(declare (ignore database db-type))
(equal "t" val))
-(defmethod read-sql-value (val (type (eql 'univeral-time)) database db-type)
+(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
+ (string
+ (unless (string-equal "NIL" val)
+ (read-from-string val)))
+ (number val)))
+
+(defmethod read-sql-value (val (type (eql 'universal-time)) database db-type)
(declare (ignore database db-type))
(unless (eq 'NULL val)
(etypecase val
(record-caches database)) results)
results)
-(defun update-cached-results (targets qualifiers database)
- ;; FIXME: this routine will need to update slots in cached objects, perhaps adding or removing objects from cached
- ;; for now, dump cache entry and perform fresh search
- (let ((res (apply #'find-all targets qualifiers)))
- (setf (gethash (compute-records-cache-key targets qualifiers)
- (record-caches database)) res)
- res))
+
+;;; 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))))