(if vd
(let ((qualifier (key-qualifier-for-instance instance :database vd)))
(delete-records :from vt :where qualifier :database vd)
- (setf (slot-value instance 'view-database) nil))
+ (setf (slot-value instance 'view-database) nil)
+ (values))
(signal-no-database-error vd))))
(defmethod update-instance-from-records ((instance standard-db-object)
(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."
(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."
(declare (ignore database db-type))
val)
-(defmethod database-output-sql-as-type ((type (eql 'char))
- val database db-type)
+(defmethod database-output-sql-as-type ((type (eql 'char)) val database db-type)
(declare (ignore database db-type))
(etypecase val
(character (write-to-string val))
(string val)))
+(defmethod database-output-sql-as-type ((type (eql 'float)) val database db-type)
+ (declare (ignore database db-type))
+ (let ((*read-default-float-format* (type-of val)))
+ (format nil "~F" val)))
+
(defmethod read-sql-value (val type database db-type)
(declare (ignore type database db-type))
(read-from-string val))
(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
View Classes VIEW-CLASSES are passed as arguments to SELECT."
(declare (ignore all set-operation group-by having offset limit inner-join on)
(optimize (debug 3) (speed 1)))
- (labels ((ref-equal (ref1 ref2)
- (equal (sql ref1)
- (sql ref2)))
- (table-sql-expr (table)
- (sql-expression :table (view-table table)))
- (tables-equal (table-a table-b)
- (when (and table-a table-b)
- (string= (string (slot-value table-a 'name))
- (string (slot-value table-b 'name))))))
+ (flet ((ref-equal (ref1 ref2)
+ (string= (sql-output ref1 database)
+ (sql-output ref2 database)))
+ (table-sql-expr (table)
+ (sql-expression :table (view-table table)))
+ (tables-equal (table-a table-b)
+ (when (and table-a table-b)
+ (string= (string (slot-value table-a 'name))
+ (string (slot-value table-b 'name))))))
(remf args :from)
(remf args :where)
(remf args :flatp)
for each record selected in the query, the results are returned
as elements of a list."
- (flet ((select-objects (target-args)
- (and target-args
- (every #'(lambda (arg)
- (and (symbolp arg)
- (find-class arg nil)))
- target-args))))
- (multiple-value-bind (target-args qualifier-args)
- (query-get-selections select-all-args)
- (unless (or *default-database* (getf qualifier-args :database))
- (signal-no-database-error nil))
-
- (cond
- ((select-objects target-args)
- (let ((caching (getf qualifier-args :caching t))
- (result-types (getf qualifier-args :result-types :auto))
- (refresh (getf qualifier-args :refresh nil))
- (database (or (getf qualifier-args :database) *default-database*))
- (order-by (getf qualifier-args :order-by)))
- (remf qualifier-args :caching)
- (remf qualifier-args :refresh)
- (remf qualifier-args :result-types)
-
-
- ;; Add explicity table name to order-by if not specified and only
- ;; one selected table. This is required so FIND-ALL won't duplicate
- ;; the field
- (when (and order-by (= 1 (length target-args)))
- (let ((table-name (view-table (find-class (car target-args))))
- (order-by-list (copy-seq (listify order-by))))
-
- (loop for i from 0 below (length order-by-list)
- do (etypecase (nth i order-by-list)
- (sql-ident-attribute
- (unless (slot-value (nth i order-by-list) 'qualifier)
- (setf (slot-value (nth i order-by-list) 'qualifier) table-name)))
- (cons
- (unless (slot-value (car (nth i order-by-list)) 'qualifier)
- (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name)))))
- (setf (getf qualifier-args :order-by) order-by-list)))
-
- (cond
- ((null caching)
- (apply #'find-all target-args
- (append qualifier-args (list :result-types result-types))))
- (t
- (let ((cached (records-cache-results target-args qualifier-args database)))
- (cond
- ((and cached (not refresh))
- cached)
- ((and cached refresh)
- (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto)))))
- (setf (records-cache-results target-args qualifier-args database) results)
- results))
- (t
- (let ((results (apply #'find-all target-args (append qualifier-args
- '(:result-types :auto)))))
- (setf (records-cache-results target-args qualifier-args database) results)
- results))))))))
- (t
- (let* ((expr (apply #'make-query select-all-args))
- (specified-types
- (mapcar #'(lambda (attrib)
- (if (typep attrib 'sql-ident-attribute)
- (let ((type (slot-value attrib 'type)))
- (if type
- type
- t))
- t))
- (slot-value expr 'selections))))
- (destructuring-bind (&key (flatp nil)
- (result-types :auto)
- (field-names t)
- (database *default-database*)
- &allow-other-keys)
- qualifier-args
- (query expr :flatp flatp
- :result-types
- ;; specifying a type for an attribute overrides result-types
- (if (some #'(lambda (x) (not (eq t x))) specified-types)
- specified-types
- result-types)
- :field-names field-names
- :database database))))))))
+ (flet ((select-objects (target-args)
+ (and target-args
+ (every #'(lambda (arg)
+ (and (symbolp arg)
+ (find-class arg nil)))
+ target-args))))
+ (multiple-value-bind (target-args qualifier-args)
+ (query-get-selections select-all-args)
+ (unless (or *default-database* (getf qualifier-args :database))
+ (signal-no-database-error nil))
+
+ (cond
+ ((select-objects target-args)
+ (let ((caching (getf qualifier-args :caching t))
+ (result-types (getf qualifier-args :result-types :auto))
+ (refresh (getf qualifier-args :refresh nil))
+ (database (or (getf qualifier-args :database) *default-database*))
+ (order-by (getf qualifier-args :order-by)))
+ (remf qualifier-args :caching)
+ (remf qualifier-args :refresh)
+ (remf qualifier-args :result-types)
+
+ ;; Add explicity table name to order-by if not specified and only
+ ;; one selected table. This is required so FIND-ALL won't duplicate
+ ;; the field
+ (when (and order-by (= 1 (length target-args)))
+ (let ((table-name (view-table (find-class (car target-args))))
+ (order-by-list (copy-seq (listify order-by))))
+
+ (loop for i from 0 below (length order-by-list)
+ do (etypecase (nth i order-by-list)
+ (sql-ident-attribute
+ (unless (slot-value (nth i order-by-list) 'qualifier)
+ (setf (slot-value (nth i order-by-list) 'qualifier) table-name)))
+ (cons
+ (unless (slot-value (car (nth i order-by-list)) 'qualifier)
+ (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name)))))
+ (setf (getf qualifier-args :order-by) order-by-list)))
+
+ (cond
+ ((null caching)
+ (apply #'find-all target-args
+ (append qualifier-args
+ (list :result-types result-types :refresh refresh))))
+ (t
+ (let ((cached (records-cache-results target-args qualifier-args database)))
+ (cond
+ ((and cached (not refresh))
+ cached)
+ ((and cached refresh)
+ (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto :refresh ,refresh)))))
+ (setf (records-cache-results target-args qualifier-args database) results)
+ results))
+ (t
+ (let ((results (apply #'find-all target-args (append qualifier-args
+ `(:result-types :auto :refresh ,refresh)))))
+ (setf (records-cache-results target-args qualifier-args database) results)
+ results))))))))
+ (t
+ (let* ((expr (apply #'make-query select-all-args))
+ (specified-types
+ (mapcar #'(lambda (attrib)
+ (if (typep attrib 'sql-ident-attribute)
+ (let ((type (slot-value attrib 'type)))
+ (if type
+ type
+ t))
+ t))
+ (slot-value expr 'selections))))
+ (destructuring-bind (&key (flatp nil)
+ (result-types :auto)
+ (field-names t)
+ (database *default-database*)
+ &allow-other-keys)
+ qualifier-args
+ (query expr :flatp flatp
+ :result-types
+ ;; specifying a type for an attribute overrides result-types
+ (if (some #'(lambda (x) (not (eq t x))) specified-types)
+ specified-types
+ result-types)
+ :field-names field-names
+ :database database))))))))
(defun compute-records-cache-key (targets qualifiers)
(list targets
(unless (record-caches database)
(setf (record-caches database)
(make-hash-table :test 'equal
- #+allegro :values #+allegro :weak)))
+ #+allegro :values #+allegro :weak
+ #+lispworks :weak-kind #+lispworks :value)))
(setf (gethash (compute-records-cache-key targets qualifiers)
(record-caches database)) results)
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))))
projects / clsql.git / blobdiff