;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:clsql-sys)
+(in-package #:clsql)
(defclass standard-db-object ()
((view-database :initform nil :initarg :view-database :reader view-database
(when (member (view-class-slot-db-kind slotdef) '(:base :key))
(let ((cdef
(list (sql-expression :attribute (view-class-slot-column slotdef))
- (slot-type slotdef))))
+ (specified-type slotdef))))
(setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
(let ((const (view-class-slot-db-constraints slotdef)))
(when const
(defclass ,class ,supers ,slots
,@(if (find :metaclass `,cl-options :key #'car)
`,cl-options
- (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
- (finalize-inheritance (find-class ',class))))
+ (cons '(:metaclass clsql::standard-db-class) `,cl-options)))
+ (finalize-inheritance (find-class ',class))
+ (find-class ',class)))
(defun keyslots-for-class (class)
(slot-value class 'key-slots))
(car list)
list))
-(defun slot-type (slotdef)
- (specified-type slotdef))
-
(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 (slot-type slotdef))
+ (slot-type (specified-type slotdef))
(*update-context* (cons (type-of instance) slot-name)))
(cond ((and value (null slot-reader))
(setf (slot-value instance slot-name)
(defmethod key-value-from-db (slotdef value database)
(declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
(let ((slot-reader (view-class-slot-db-reader slotdef))
- (slot-type (slot-type slotdef)))
+ (slot-type (specified-type slotdef)))
(cond ((and value (null slot-reader))
(read-sql-value value (delistify slot-type) database))
((null value)
(defun db-value-from-slot (slotdef val database)
(let ((dbwriter (view-class-slot-db-writer slotdef))
- (dbtype (slot-type slotdef)))
+ (dbtype (specified-type slotdef)))
(typecase dbwriter
(string (format nil dbwriter val))
(function (apply dbwriter (list val)))
(database-output-sql-as-type dbtype val database)))))))
(defun check-slot-type (slotdef val)
- (let* ((slot-type (slot-type slotdef))
+ (let* ((slot-type (specified-type slotdef))
(basetype (if (listp slot-type) (car slot-type) slot-type)))
(when (and slot-type val)
(unless (typep val basetype)
(let ((qualifier (key-qualifier-for-instance instance :database vd)))
(delete-records :from vt :where qualifier :database vd)
(setf (slot-value instance 'view-database) nil))
- (error 'clsql-no-database-error nil))))
+ (error 'clsql-base::clsql-no-database-error :database nil))))
(defmethod update-instance-from-records ((instance standard-db-object)
&key (database *default-database*))
(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+)
(format nil "INT(~A)" (car args))
"INT"))
+(deftype bigint ()
+ "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
+ 'integer)
+
(defmethod database-get-type-specifier ((type (eql 'bigint)) args database)
(declare (ignore args database))
"BIGINT")
"VARCHAR"
"VARCHAR(255)")))
+(deftype universal-time ()
+ "A positive integer as returned by GET-UNIVERSAL-TIME."
+ '(integer 1 *))
+
(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database)
(declare (ignore args database))
"BIGINT")
(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))
(float (read-from-string val)))
(defmethod read-sql-value (val (type (eql 'boolean)) database)
- (declare (ignore database))
- (equal "t" val))
+ (case (database-underlying-type database)
+ (:mysql
+ (etypecase val
+ (string (if (string= "0" val) nil t))
+ (integer (if (zerop val) nil t))))
+ (:postgresql
+ (if (eq :odbc (database-type database))
+ (if (string= "0" val) nil t)
+ (equal "t" val)))
+ (t
+ (equal "t" val))))
(defmethod read-sql-value (val (type (eql 'univeral-time)) database)
(declare (ignore database))
objects))))
(let* ((*db-deserializing* t)
(*default-database* (or database
- (error 'clsql-no-database-error nil)))
+ (error 'clsql-base::clsql-no-database-error :database nil)))
(sclasses (mapcar #'find-class view-classes))
(sels (mapcar #'generate-selection-list sclasses))
(fullsels (apply #'append sels))
(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
(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
(query expr :flatp flatp :result-types result-types
- :database database)))))))
+ :field-names field-names :database database)))))))