X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=0232917ff4662b7ca80ae62d79b75b86cfd4c08d;hb=f69c5bfba59d54628f9a08b83413ec3df3c92432;hp=f2d82e62e8fd2c7e737d4e43d636832e7d29cba2;hpb=afe872863374de73b2f2ef767e742a40d7465e4a;p=clsql.git diff --git a/sql/objects.lisp b/sql/objects.lisp index f2d82e6..0232917 100644 --- 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 - :where view-qual))))) + :where view-qual) + (list :result-types nil))))) (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)) - (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))))) @@ -428,9 +430,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+) @@ -456,7 +456,7 @@ superclass of the newly-defined View Class." (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)")) @@ -467,12 +467,16 @@ superclass of the newly-defined View Class." (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)) - (if (clsql-base-sys::in (database-underlying-type database) + (if (clsql-base::in (database-underlying-type database) :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)) - (if (clsql-base-sys::in (database-underlying-type database) + (if (clsql-base::in (database-underlying-type database) :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)) - (if (clsql-base-sys::in (database-underlying-type database) + (if (clsql-base::in (database-underlying-type database) :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) @@ -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))) - (clsql-base-sys::substitute-char-string + (clsql-base::substitute-char-string 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) - (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)) @@ -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)) - (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 - (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) @@ -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) + (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)) - (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)) @@ -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 - (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)) @@ -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 - 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) + (remf args :flatp) + (remf args :result-types) (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) - (build-object vals sclass sel)) + (prog1 (build-object vals sclass sel) + (setf vals (nthcdr (list-length sel) + vals)))) sclasses sels))) - (if (= (length sclasses) 1) + (if (and flatp (= (length sclasses) 1)) (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)) - (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))) -(defun select (&rest select-all-args) +(defmethod 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 @@ -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) + (result-types :auto) + (field-names t) (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))))))) +