;;;; (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
(:metaclass standard-db-class)
(:documentation "Superclass for all CLSQL View Classes."))
+(defvar *db-auto-sync* nil
+ "A non-nil value means that creating View Class instances or
+ setting their slots automatically creates/updates the
+ corresponding records in the underlying database.")
+
(defvar *db-deserializing* nil)
(defvar *db-initializing* nil)
(call-next-method))
(defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
- instance slot)
- (declare (ignore new-value instance slot))
- (call-next-method))
+ instance slot-def)
+ (declare (ignore new-value))
+ (let ((slot-name (%svuc-slot-name slot-def))
+ (slot-kind (view-class-slot-db-kind slot-def)))
+ (call-next-method)
+ (when (and *db-auto-sync*
+ (not *db-initializing*)
+ (not *db-deserializing*)
+ (not (eql slot-kind :virtual)))
+ (update-record-from-slot instance slot-name))))
-(defmethod initialize-instance :around ((object standard-db-object)
+(defmethod initialize-instance ((object standard-db-object)
&rest all-keys &key &allow-other-keys)
(declare (ignore all-keys))
(let ((*db-initializing* t))
(call-next-method)
- (unless *db-deserializing*
- #+nil (created-object object)
+ (when (and *db-auto-sync*
+ (not *db-deserializing*))
(update-records-from-instance object))))
;;
(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))
;; Called by 'get-slot-values-from-view'
;;
-(declaim (inline delistify))
-(defun delistify (list)
- (if (listp list)
- (car list)
- list))
-
-(defun slot-type (slotdef)
- (specified-type slotdef))
(defvar *update-context* nil)
(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*))
(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")
(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))))
;; ------------------------------------------------------------
;; Logic for 'faulting in' :join slots
+;; this works, but is inefficient requiring (+ 1 n-rows)
+;; SQL queries
+#+ignore
+(defun fault-join-target-slot (class object slot-def)
+ (let* ((res (fault-join-slot-raw class object slot-def))
+ (dbi (view-class-slot-db-info slot-def))
+ (target-name (gethash :target-slot dbi))
+ (target-class (find-class target-name)))
+ (when res
+ (mapcar (lambda (obj)
+ (list
+ (car
+ (fault-join-slot-raw
+ target-class
+ obj
+ (find target-name (class-slots (class-of obj))
+ :key #'slot-definition-name)))
+ obj))
+ res)
+ #+ignore ;; this doesn't work when attempting to call slot-value
+ (mapcar (lambda (obj)
+ (cons obj (slot-value obj ts))) res))))
+
+(defun fault-join-target-slot (class object slot-def)
+ (let* ((dbi (view-class-slot-db-info slot-def))
+ (ts (gethash :target-slot dbi))
+ (jc (gethash :join-class dbi))
+ (ts-view-table (view-table (find-class ts)))
+ (jc-view-table (view-table (find-class jc)))
+ (tdbi (view-class-slot-db-info
+ (find ts (class-slots (find-class jc))
+ :key #'slot-definition-name)))
+ (retrieval (gethash :retrieval tdbi))
+ (jq (join-qualifier class object slot-def))
+ (key (slot-value object (gethash :home-key dbi))))
+ (when jq
+ (ecase retrieval
+ (:immediate
+ (let ((res
+ (find-all (list ts)
+ :inner-join (sql-expression :table jc-view-table)
+ :on (sql-operation
+ '==
+ (sql-expression
+ :attribute (gethash :foreign-key tdbi)
+ :table ts-view-table)
+ (sql-expression
+ :attribute (gethash :home-key tdbi)
+ :table jc-view-table))
+ :where jq
+ :result-types :auto)))
+ (mapcar #'(lambda (i)
+ (let* ((instance (car i))
+ (jcc (make-instance jc :view-database (view-database instance))))
+ (setf (slot-value jcc (gethash :foreign-key dbi))
+ key)
+ (setf (slot-value jcc (gethash :home-key tdbi))
+ (slot-value instance (gethash :foreign-key tdbi)))
+ (list instance jcc)))
+ res)))
+ (:deferred
+ ;; just fill in minimal slots
+ (mapcar
+ #'(lambda (k)
+ (let ((instance (make-instance ts :view-database (view-database object)))
+ (jcc (make-instance jc :view-database (view-database object)))
+ (fk (car k)))
+ (setf (slot-value instance (gethash :home-key tdbi)) fk)
+ (setf (slot-value jcc (gethash :foreign-key dbi))
+ key)
+ (setf (slot-value jcc (gethash :home-key tdbi))
+ fk)
+ (list instance jcc)))
+ (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
+ :from (sql-expression :table jc-view-table)
+ :where jq)))))))
+
+(defun update-object-joins (objects &key (slots t) (force-p t)
+ class-name (max-len *default-update-objects-max-len*))
+ "Updates the remote join slots, that is those slots defined without :retrieval :immediate."
+ (when objects
+ (unless class-name
+ (class-name (class-of (first objects))))
+ )
+ )
+
+
(defun fault-join-slot-raw (class object slot-def)
(let* ((dbi (view-class-slot-db-info slot-def))
(jc (gethash :join-class dbi)))
(defun fault-join-slot (class object slot-def)
(let* ((dbi (view-class-slot-db-info slot-def))
- (ts (gethash :target-slot dbi))
- (res (fault-join-slot-raw class object slot-def)))
- (when res
- (cond
- ((and ts (gethash :set dbi))
- (mapcar (lambda (obj)
- (cons obj (slot-value obj ts))) res))
- ((and ts (not (gethash :set dbi)))
- (mapcar (lambda (obj) (slot-value obj ts)) res))
- ((and (not ts) (not (gethash :set dbi)))
- (car res))
- ((and (not ts) (gethash :set dbi))
- res)))))
+ (ts (gethash :target-slot dbi)))
+ (if (and ts (gethash :set dbi))
+ (fault-join-target-slot class object slot-def)
+ (let ((res (fault-join-slot-raw class object slot-def)))
+ (when res
+ (cond
+ ((and ts (not (gethash :set dbi)))
+ (mapcar (lambda (obj) (slot-value obj ts)) res))
+ ((and (not ts) (not (gethash :set dbi)))
+ (car res))
+ ((and (not ts) (gethash :set dbi))
+ res)))))))
(defun join-qualifier (class object slot-def)
(declare (ignore class))
(apply #'sql-and jc)
jc))))))
-(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 flatp (database *default-database*))
+(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
+ flatp result-types inner-join on
+ (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)
+ (declare (ignore all set-operation group-by having offset limit inner-join on)
(optimize (debug 3) (speed 1)))
(remf args :from)
(remf args :flatp)
+ (remf args :additional-fields)
(remf args :result-types)
(labels ((table-sql-expr (table)
(sql-expression :table (view-table table)))
(let* ((class-name (class-name vclass))
(db-vals (butlast vals (- (list-length vals)
(list-length selects))))
- (*db-initializing* t)
(obj (make-instance class-name :view-database database)))
;; use refresh keyword here
(setf obj (get-slot-values-from-view obj (mapcar #'car selects)
(car objects)
objects))))
(let* ((*db-deserializing* t)
- (*default-database* (or database
- (error 'clsql-no-database-error nil)))
(sclasses (mapcar #'find-class view-classes))
(sels (mapcar #'generate-selection-list sclasses))
(fullsels (apply #'append sels))
(cons :from
(list (append (when from (listify from))
(listify tables))))
- (list :result-types nil)
+ (list :result-types result-types)
args)))
(mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
(defmethod instance-refreshed ((instance standard-db-object)))
-(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
-values. The selections argument may be either db-identifiers, literal
-strings or view classes. If the argument consists solely of view
-classes, the return value will be instances of objects rather than raw
-tuples."
+(defun select (&rest select-all-args)
+ "The function SELECT selects data from DATABASE, which has a
+default value of *DEFAULT-DATABASE*, given the constraints
+specified by the rest of the ARGS. It returns a list of objects
+as specified by SELECTIONS. By default, the objects will each be
+represented as lists of attribute values. The argument SELECTIONS
+consists either of database identifiers, type-modified database
+identifiers or literal strings. A type-modifed database
+identifier is an expression such as [foo :string] which means
+that the values in column foo are returned as Lisp strings. The
+FLATP argument, which has a default value of nil, specifies if
+full bracketed results should be returned for each matched
+entry. If FLATP is nil, the results are returned as a list of
+lists. If FLATP is t, the results are returned as elements of a
+list, only if there is only one result per row. The arguments
+ALL, SET-OPERATION, DISTINCT, FROM, WHERE, GROUP-BY, HAVING and
+ORDER-by have the same function as the equivalent SQL expression.
+The SELECT function is common across both the functional and
+object-oriented SQL interfaces. If selections refers to View
+Classes then the select operation becomes object-oriented. This
+means that SELECT returns a list of View Class instances, and
+SLOT-VALUE becomes a valid SQL operator for use within the where
+clause. In the View Class case, a second equivalent select call
+will return the same View Class instance objects. If REFRESH is
+true, then existing instances are updated if necessary, and in
+this case you might need to extend the hook INSTANCE-REFRESHED.
+The default value of REFRESH is nil. SQL expressions used in the
+SELECT function are specified using the square bracket syntax,
+once this syntax has been enabled using
+ENABLE-SQL-READER-SYNTAX."
+
(flet ((select-objects (target-args)
(and target-args
(every #'(lambda (arg)
(multiple-value-bind (target-args qualifier-args)
(query-get-selections select-all-args)
(if (select-objects target-args)
- (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
- (query expr :flatp flatp :result-types result-types
- :field-names field-names :database database)))))))
+ (apply #'find-all target-args qualifier-args)
+ (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)))))))
projects / clsql.git / blobdiff