projects
/
clsql.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
r9209: read tinyint as integer for odbc, handle boolean reading/writing fields
[clsql.git]
/
sql
/
objects.lisp
diff --git
a/sql/objects.lisp
b/sql/objects.lisp
index f2d82e62e8fd2c7e737d4e43d636832e7d29cba2..0232917ff4662b7ca80ae62d79b75b86cfd4c08d 100644
(file)
--- a/
sql/objects.lisp
+++ b/
sql/objects.lisp
@@
-408,7
+408,8
@@
superclass of the newly-defined View Class."
(sels (generate-selection-list view-class))
(res (apply #'select (append (mapcar #'cdr sels)
(list :from view-table
(sels (generate-selection-list view-class))
(res (apply #'select (append (mapcar #'cdr sels)
(list :from view-table
- :where view-qual)))))
+ :where view-qual)
+ (list :result-types nil)))))
(when res
(get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
(when res
(get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
@@
-420,7
+421,8
@@
superclass of the newly-defined View Class."
(view-qual (key-qualifier-for-instance instance :database vd))
(slot-def (slotdef-for-slot-with-class slot view-class))
(att-ref (generate-attribute-reference view-class slot-def))
(view-qual (key-qualifier-for-instance instance :database vd))
(slot-def (slotdef-for-slot-with-class slot view-class))
(att-ref (generate-attribute-reference view-class slot-def))
- (res (select att-ref :from view-table :where view-qual)))
+ (res (select att-ref :from view-table :where view-qual
+ :result-types nil)))
(when res
(get-slot-values-from-view instance (list slot-def) (car res)))))
(when res
(get-slot-values-from-view instance (list slot-def) (car res)))))
@@
-428,9
+430,7
@@
superclass of the newly-defined View Class."
(defmethod update-slot-with-null ((object standard-db-object)
slotname
slotdef)
(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+)
(defvar +no-slot-value+ '+no-slot-value+)
@@
-456,7
+456,7
@@
superclass of the newly-defined View Class."
(defmethod database-get-type-specifier (type args database)
(declare (ignore type args))
(defmethod database-get-type-specifier (type args database)
(declare (ignore type args))
- (if (clsql-base
-sys
::in (database-underlying-type database)
+ (if (clsql-base::in (database-underlying-type database)
:postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)"))
:postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)"))
@@
-467,12
+467,16
@@
superclass of the newly-defined View Class."
(if args
(format nil "INT(~A)" (car args))
"INT"))
(if args
(format nil "INT(~A)" (car args))
"INT"))
+
+(defmethod database-get-type-specifier ((type (eql 'bigint)) args database)
+ (declare (ignore args database))
+ "BIGINT")
(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
database)
(if args
(format nil "VARCHAR(~A)" (car args))
(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (clsql-base
-sys
::in (database-underlying-type database)
+ (if (clsql-base::in (database-underlying-type database)
:postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)")))
:postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)")))
@@
-481,7
+485,7
@@
superclass of the newly-defined View Class."
database)
(if args
(format nil "VARCHAR(~A)" (car args))
database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (clsql-base
-sys
::in (database-underlying-type database)
+ (if (clsql-base::in (database-underlying-type database)
:postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)")))
:postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)")))
@@
-489,11
+493,15
@@
superclass of the newly-defined View Class."
(defmethod database-get-type-specifier ((type (eql 'string)) args database)
(if args
(format nil "VARCHAR(~A)" (car args))
(defmethod database-get-type-specifier ((type (eql 'string)) args database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (clsql-base
-sys
::in (database-underlying-type database)
+ (if (clsql-base::in (database-underlying-type database)
:postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)")))
:postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)")))
+(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database)
+ (declare (ignore args database))
+ "BIGINT")
+
(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
(declare (ignore args))
(case (database-underlying-type database)
(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
(declare (ignore args))
(case (database-underlying-type database)
@@
-545,7
+553,7
@@
superclass of the newly-defined View Class."
(declare (ignore database))
(progv '(*print-circle* *print-array*) '(t t)
(let ((escaped (prin1-to-string val)))
(declare (ignore database))
(progv '(*print-circle* *print-array*) '(t t)
(let ((escaped (prin1-to-string val)))
- (clsql-base
-sys
::substitute-char-string
+ (clsql-base::substitute-char-string
escaped #\Null " "))))
(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
escaped #\Null " "))))
(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
@@
-576,8
+584,11
@@
superclass of the newly-defined View Class."
(prin1-to-string val)))
(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database)
(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))
(defmethod database-output-sql-as-type ((type (eql 'string)) val database)
(declare (ignore database))
@@
-622,15
+633,24
@@
superclass of the newly-defined View Class."
(defmethod read-sql-value (val (type (eql 'symbol)) database)
(declare (ignore database))
(when (< 0 (length val))
(defmethod read-sql-value (val (type (eql 'symbol)) database)
(declare (ignore database))
(when (< 0 (length val))
- (unless (string= val (clsql-base
-sys
:symbol-name-default-case "NIL"))
- (intern (clsql-base
-sys
:symbol-name-default-case val)
+ (unless (string= val (clsql-base:symbol-name-default-case "NIL"))
+ (intern (clsql-base:symbol-name-default-case val)
(symbol-package *update-context*)))))
(defmethod read-sql-value (val (type (eql 'integer)) database)
(declare (ignore database))
(etypecase val
(string
(symbol-package *update-context*)))))
(defmethod read-sql-value (val (type (eql 'integer)) database)
(declare (ignore database))
(etypecase val
(string
- (read-from-string val))
+ (unless (string-equal "NIL" val)
+ (parse-integer val)))
+ (number val)))
+
+(defmethod read-sql-value (val (type (eql 'bigint)) database)
+ (declare (ignore database))
+ (etypecase val
+ (string
+ (unless (string-equal "NIL" val)
+ (parse-integer val)))
(number val)))
(defmethod read-sql-value (val (type (eql 'float)) database)
(number val)))
(defmethod read-sql-value (val (type (eql 'float)) database)
@@
-639,8
+659,21
@@
superclass of the newly-defined View Class."
(float (read-from-string val)))
(defmethod read-sql-value (val (type (eql 'boolean)) database)
(float (read-from-string val)))
(defmethod read-sql-value (val (type (eql 'boolean)) database)
+ (case (database-underlying-type database)
+ (:mysql
+ (etypecase val
+ (string (if (string= "0" val) nil t))
+ (integer (if (zerop val) nil t))))
+ (t
+ (equal "t" val))))
+
+(defmethod read-sql-value (val (type (eql 'univeral-time)) database)
(declare (ignore database))
(declare (ignore database))
- (equal "t" val))
+ (unless (eq 'NULL val)
+ (etypecase val
+ (string
+ (parse-integer val))
+ (number val))))
(defmethod read-sql-value (val (type (eql 'wall-time)) database)
(declare (ignore database))
(defmethod read-sql-value (val (type (eql 'wall-time)) database)
(declare (ignore database))
@@
-661,7
+694,7
@@
superclass of the newly-defined View Class."
(jc (gethash :join-class dbi)))
(let ((jq (join-qualifier class object slot-def)))
(when jq
(jc (gethash :join-class dbi)))
(let ((jq (join-qualifier class object slot-def)))
(when jq
- (select jc :where jq)))))
+ (select jc :where jq
:flatp t :result-types nil
)))))
(defun fault-join-slot (class object slot-def)
(let* ((dbi (view-class-slot-db-info slot-def))
(defun fault-join-slot (class object slot-def)
(let* ((dbi (view-class-slot-db-info slot-def))
@@
-720,11
+753,14
@@
superclass of the newly-defined View Class."
(defun find-all (view-classes &rest args &key all set-operation distinct from
where group-by having order-by order-by-descending offset limit
(defun find-all (view-classes &rest args &key all set-operation distinct from
where group-by having order-by order-by-descending offset limit
- refresh (database *default-database*))
- "tweeze me apart someone pleeze"
+ refresh flatp (database *default-database*))
+ "Called by SELECT to generate object query results when the
+ View Classes VIEW-CLASSES are passed as arguments to SELECT."
(declare (ignore all set-operation group-by having offset limit)
(optimize (debug 3) (speed 1)))
(remf args :from)
(declare (ignore all set-operation group-by having offset limit)
(optimize (debug 3) (speed 1)))
(remf args :from)
+ (remf args :flatp)
+ (remf args :result-types)
(labels ((table-sql-expr (table)
(sql-expression :table (view-table table)))
(ref-equal (ref1 ref2)
(labels ((table-sql-expr (table)
(sql-expression :table (view-table table)))
(ref-equal (ref1 ref2)
@@
-746,9
+782,11
@@
superclass of the newly-defined View Class."
obj))
(build-objects (vals sclasses sels)
(let ((objects (mapcar #'(lambda (sclass sel)
obj))
(build-objects (vals sclasses sels)
(let ((objects (mapcar #'(lambda (sclass sel)
- (build-object vals sclass sel))
+ (prog1 (build-object vals sclass sel)
+ (setf vals (nthcdr (list-length sel)
+ vals))))
sclasses sels)))
sclasses sels)))
- (if (
= (length sclasses) 1
)
+ (if (
and flatp (= (length sclasses) 1)
)
(car objects)
objects))))
(let* ((*db-deserializing* t)
(car objects)
objects))))
(let* ((*db-deserializing* t)
@@
-786,12
+824,14
@@
superclass of the newly-defined View Class."
(append (mapcar #'cdr fullsels)
(cons :from
(list (append (when from (listify from))
(append (mapcar #'cdr fullsels)
(cons :from
(list (append (when from (listify from))
- (listify tables)))) args)))
+ (listify tables))))
+ (list :result-types nil)
+ args)))
(mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
(defmethod instance-refreshed ((instance standard-db-object)))
(mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
(defmethod instance-refreshed ((instance standard-db-object)))
-(def
un
select (&rest select-all-args)
+(def
method
select (&rest select-all-args)
"Selects data from database given the constraints specified. Returns
a list of lists of record values as specified by select-all-args. By
default, the records are each represented as lists of attribute
"Selects data from database given the constraints specified. Returns
a list of lists of record values as specified by select-all-args. By
default, the records are each represented as lists of attribute
@@
-811,11
+851,11
@@
tuples."
(apply #'find-all target-args qualifier-args)
(let ((expr (apply #'make-query select-all-args)))
(destructuring-bind (&key (flatp nil)
(apply #'find-all target-args qualifier-args)
(let ((expr (apply #'make-query select-all-args)))
(destructuring-bind (&key (flatp nil)
+ (result-types :auto)
+ (field-names t)
(database *default-database*)
&allow-other-keys)
qualifier-args
(database *default-database*)
&allow-other-keys)
qualifier-args
- (let ((res (query expr :database database)))
- (if (and flatp
- (= (length (slot-value expr 'selections)) 1))
- (mapcar #'car res)
- res))))))))
+ (query expr :flatp flatp :result-types result-types
+ :field-names field-names :database database)))))))
+