;;;; (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
#+nil (created-object object)
(update-records-from-instance object))))
-(defun sequence-from-class (view-class-name)
- (sql-escape
- (concatenate
- 'string
- (symbol-name (view-table (find-class view-class-name)))
- "-SEQ")))
-
-(defun create-sequence-from-class (view-class-name
- &key (database *default-database*))
- (create-sequence (sequence-from-class view-class-name) :database database))
-
-(defun drop-sequence-from-class (view-class-name
- &key (if-does-not-exist :error)
- (database *default-database*))
- (drop-sequence (sequence-from-class view-class-name)
- :if-does-not-exist if-does-not-exist
- :database database))
-
;;
;; Build the database tables required to store the given view class
;;
-(defmethod database-pkey-constraint ((class standard-db-class) database)
- (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
- (when keylist
- (convert-to-db-default-case
- (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
- (database-output-sql (view-table class) database)
- (database-output-sql keylist database))
- database))))
-
-
(defun create-view-from-class (view-class-name
&key (database *default-database*))
"Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
(push self (database-view-classes database))
t)
+(defmethod database-pkey-constraint ((class standard-db-class) database)
+ (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
+ (when keylist
+ (convert-to-db-default-case
+ (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
+ (database-output-sql (view-table class) database)
+ (database-output-sql keylist database))
+ database))))
+
+(defmethod database-generate-column-definition (class slotdef database)
+ (declare (ignore database class))
+ (when (member (view-class-slot-db-kind slotdef) '(:base :key))
+ (let ((cdef
+ (list (sql-expression :attribute (view-class-slot-column 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
+ (setq cdef (append cdef (list const)))))
+ cdef)))
+
+
;;
;; Drop the tables which store the given view class
;;
;; Define a new view class
;;
-(defmacro def-view-class (class supers slots &rest options)
+(defmacro def-view-class (class supers slots &rest cl-options)
"Extends the syntax of defclass to allow special slots to be mapped
onto the attributes of database views. The macro DEF-VIEW-CLASS
creates a class called CLASS which maps onto a database view. Such a
SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the
superclass of the newly-defined View Class."
`(progn
- (defclass ,class ,supers ,slots ,@options
- (:metaclass standard-db-class))
- (finalize-inheritance (find-class ',class))))
+ (defclass ,class ,supers ,slots
+ ,@(if (find :metaclass `,cl-options :key #'car)
+ `,cl-options
+ (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))
sels
(error "No slots of type :base in view-class ~A" (class-name vclass)))))
-;;
-;; Used by 'create-view-from-class'
-;;
-
-
-(defmethod database-generate-column-definition (class slotdef database)
- (declare (ignore database class))
- (when (member (view-class-slot-db-kind slotdef) '(:base :key))
- (let ((cdef
- (list (sql-expression :attribute (view-class-slot-column slotdef))
- (slot-type slotdef))))
- (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
- (let ((const (view-class-slot-db-constraints slotdef)))
- (when const
- (setq cdef (append cdef (list const)))))
- cdef)))
;;
;; Called by 'get-slot-values-from-view'
(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)
(mapc #'update-slot slotdeflist values)
obj))
-(defgeneric update-record-from-slot (object slot &key database)
- (:documentation
- "The generic function UPDATE-RECORD-FROM-SLOT updates an individual
-data item in the column represented by SLOT. The DATABASE is only used
-if OBJECT is not yet associated with any database, in which case a
-record is created in DATABASE. Only SLOT is initialized in this case;
-other columns in the underlying database receive default values. The
-argument SLOT is the CLOS slot name; the corresponding column names
-are derived from the View Class definition."))
-
(defmethod update-record-from-slot ((obj standard-db-object) slot &key
- (database *default-database*))
- (let* ((vct (view-table (class-of obj)))
+ (database *default-database*))
+ (let* ((database (or (view-database obj) database))
+ (vct (view-table (class-of obj)))
(sd (slotdef-for-slot-with-class slot (class-of obj))))
(check-slot-type sd (slot-value obj slot))
(let* ((att (view-class-slot-column sd))
(val (db-value-from-slot sd (slot-value obj slot) database)))
(cond ((and vct sd (view-database obj))
(update-records (sql-expression :table vct)
- :attributes (list (sql-expression
- :attribute att))
+ :attributes (list (sql-expression :attribute att))
:values (list val)
:where (key-qualifier-for-instance
obj :database database)
- :database (view-database obj)))
+ :database database))
((and vct sd (not (view-database obj)))
- (warn "Ignoring (install-instance obj :database database))")
- t)
+ (insert-records :into (sql-expression :table vct)
+ :attributes (list (sql-expression :attribute att))
+ :values (list val)
+ :database database)
+ (setf (slot-value obj 'view-database) database))
(t
(error "Unable to update record.")))))
- t)
-
-(defgeneric update-record-from-slots (object slots &key database)
- (:documentation
- "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the
-columns represented by SLOTS. The DATABASE is only used if OBJECT is
-not yet associated with any database, in which case a record is
-created in DATABASE. Only slots are initialized in this case; other
-columns in the underlying database receive default values. The
-argument SLOTS contains the CLOS slot names; the corresponding column
-names are derived from the view class definition."))
+ (values))
(defmethod update-record-from-slots ((obj standard-db-object) slots &key
(database *default-database*))
- (let* ((vct (view-table (class-of obj)))
+ (let* ((database (or (view-database obj) database))
+ (vct (view-table (class-of obj)))
(sds (slotdefs-for-slots-with-class slots (class-of obj)))
(avps (mapcar #'(lambda (s)
(let ((val (slot-value
:av-pairs avps
:where (key-qualifier-for-instance
obj :database database)
- :database (view-database obj)))
+ :database database))
((and avps (not (view-database obj)))
(insert-records :into (sql-expression :table vct)
:av-pairs avps
(error "Unable to update records"))))
(values))
-(defgeneric update-records-from-instance (object &key database)
- (:documentation
- "Using an instance of a view class, update the database table that
-stores its instance data. If the instance is already associated with a
-database, that database is used, and database is ignored. If instance
-is not yet associated with a database, a record is created for
-instance in the appropriate table of database and the instance becomes
-associated with that database."))
-
(defmethod update-records-from-instance ((obj standard-db-object)
&key (database *default-database*))
- (labels ((slot-storedp (slot)
- (and (member (view-class-slot-db-kind slot) '(:base :key))
- (slot-boundp obj (slot-definition-name slot))))
- (slot-value-list (slot)
- (let ((value (slot-value obj (slot-definition-name slot))))
- (check-slot-type slot value)
- (list (sql-expression :attribute (view-class-slot-column slot))
- (db-value-from-slot slot value database)))))
- (let* ((view-class (class-of obj))
- (view-class-table (view-table view-class))
- (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))
- (record-values (mapcar #'slot-value-list slots)))
- (unless record-values
- (error "No settable slots."))
- (if (view-database obj)
- (update-records (sql-expression :table view-class-table)
- :av-pairs record-values
- :where (key-qualifier-for-instance
- obj :database database)
- :database (view-database obj))
- (progn
- (insert-records :into (sql-expression :table view-class-table)
- :av-pairs record-values
- :database database)
- (setf (slot-value obj 'view-database) database)))
- (values))))
-
-(defgeneric delete-instance-records (instance)
- (:documentation
- "Deletes the records represented by INSTANCE from the database
-associated with it. If instance has no associated database, an error
-is signalled."))
+ (let ((database (or (view-database obj) database)))
+ (labels ((slot-storedp (slot)
+ (and (member (view-class-slot-db-kind slot) '(:base :key))
+ (slot-boundp obj (slot-definition-name slot))))
+ (slot-value-list (slot)
+ (let ((value (slot-value obj (slot-definition-name slot))))
+ (check-slot-type slot value)
+ (list (sql-expression :attribute (view-class-slot-column slot))
+ (db-value-from-slot slot value database)))))
+ (let* ((view-class (class-of obj))
+ (view-class-table (view-table view-class))
+ (slots (remove-if-not #'slot-storedp
+ (ordered-class-slots view-class)))
+ (record-values (mapcar #'slot-value-list slots)))
+ (unless record-values
+ (error "No settable slots."))
+ (if (view-database obj)
+ (update-records (sql-expression :table view-class-table)
+ :av-pairs record-values
+ :where (key-qualifier-for-instance
+ obj :database database)
+ :database database)
+ (progn
+ (insert-records :into (sql-expression :table view-class-table)
+ :av-pairs record-values
+ :database database)
+ (setf (slot-value obj 'view-database) database))))))
+ (values))
(defmethod delete-instance-records ((instance standard-db-object))
(let ((vt (sql-expression :table (view-table (class-of instance))))
- (vd (or (view-database instance) *default-database*)))
- (when 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))))
- #+ignore (odcl::deleted-object object))
-
-(defgeneric update-instance-from-records (instance &key database)
- (:documentation
- "Updates the values in the slots of the View Class instance
-INSTANCE using the data in the database DATABASE which defaults to the
-database that INSTANCE is associated with, or the value of
-*DEFAULT-DATABASE*."))
+ (vd (view-database instance)))
+ (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))
+ (error 'clsql-base::clsql-no-database-error :database nil))))
(defmethod update-instance-from-records ((instance standard-db-object)
&key (database *default-database*))
(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)))))
-(defgeneric update-slot-from-record (instance slot &key database)
- (:documentation
- "Updates the value in the slot SLOT of the View Class instance
-INSTANCE using the data in the database DATABASE which defaults to the
-database that INSTANCE is associated with, or the value of
-*DEFAULT-DATABASE*."))
-
(defmethod update-slot-from-record ((instance standard-db-object)
slot &key (database *default-database*))
(let* ((view-class (find-class (class-name (class-of instance))))
(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)))
- (get-slot-values-from-view instance (list slot-def) (car res))))
-
-
-(defgeneric database-null-value (type)
- (:documentation "Return an expression of type TYPE which SQL NULL values
-will be converted into."))
+ (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)))))
-(defmethod database-null-value ((type t))
- (cond
- ((subtypep type 'string) nil)
- ((subtypep type 'integer) nil)
- ((subtypep type 'list) nil)
- ((subtypep type 'boolean) nil)
- ((eql type t) nil)
- ((subtypep type 'symbol) nil)
- ((subtypep type 'keyword) nil)
- ((subtypep type 'wall-time) nil)
- ((subtypep type 'duration) nil)
- ((subtypep type 'money) nil)
- (t
- (error "Unable to handle null for type ~A" type))))
-
-(defgeneric update-slot-with-null (instance slotname slotdef)
- (:documentation "Called to update a slot when its column has a NULL
-value. If nulls are allowed for the column, the slot's value will be
-nil, otherwise its value will be set to the result of calling
-DATABASE-NULL-VALUE on the type of the slot."))
(defmethod update-slot-with-null ((object standard-db-object)
slotname
slotdef)
- (let ((st (slot-type slotdef))
- (allowed (slot-value slotdef 'nulls-ok)))
- (if allowed
- (setf (slot-value object slotname) nil)
- (setf (slot-value object slotname)
- (database-null-value st)))))
+ (setf (slot-value object slotname) (slot-value slotdef 'void-value)))
(defvar +no-slot-value+ '+no-slot-value+)
(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)"))
(if args
(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")
(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)")))
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 '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)")))
+(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")
+
(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
(declare (ignore args))
(case (database-underlying-type database)
(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)
(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 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)
(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))))
+ (: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))
- (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))
(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))
(apply #'sql-and jc)
jc))))))
-(defmethod postinitialize ((self t))
- )
-
(defun find-all (view-classes &rest args &key all set-operation distinct from
where group-by having order-by order-by-descending offset limit
- (database *default-database*))
- "tweeze me apart someone pleeze"
- (declare (ignore all set-operation group-by having
- offset limit)
+ 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)))
- ;; (cmsg "Args = ~s" args)
(remf args :from)
- (let* ((*db-deserializing* t)
- (*default-database* (or database
- (error 'clsql-no-database-error nil))))
- (flet ((table-sql-expr (table)
- (sql-expression :table (view-table table)))
- (ref-equal (ref1 ref2)
- (equal (sql ref1)
- (sql ref2)))
- (tables-equal (table-a table-b)
- (string= (string (slot-value table-a 'name))
- (string (slot-value table-b 'name)))))
-
- (let* ((sclasses (mapcar #'find-class view-classes))
- (sels (mapcar #'generate-selection-list sclasses))
- (fullsels (apply #'append sels))
- (sel-tables (collect-table-refs where))
- (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses) sel-tables)
- :test #'tables-equal))
- (res nil))
+ (remf args :flatp)
+ (remf args :result-types)
+ (labels ((table-sql-expr (table)
+ (sql-expression :table (view-table table)))
+ (ref-equal (ref1 ref2)
+ (equal (sql ref1)
+ (sql ref2)))
+ (tables-equal (table-a table-b)
+ (string= (string (slot-value table-a 'name))
+ (string (slot-value table-b 'name))))
+ (build-object (vals vclass selects)
+ (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)
+ db-vals))
+ (when refresh (instance-refreshed obj))
+ obj))
+ (build-objects (vals sclasses sels)
+ (let ((objects (mapcar #'(lambda (sclass sel)
+ (prog1 (build-object vals sclass sel)
+ (setf vals (nthcdr (list-length sel)
+ vals))))
+ sclasses sels)))
+ (if (and flatp (= (length sclasses) 1))
+ (car objects)
+ objects))))
+ (let* ((*db-deserializing* t)
+ (*default-database* (or database
+ (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))
+ (sel-tables (collect-table-refs where))
+ (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
+ sel-tables)
+ :test #'tables-equal))
+ (res nil))
(dolist (ob (listify order-by))
(when (and ob (not (member ob (mapcar #'cdr fullsels)
:test #'ref-equal)))
- (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att))
- (listify ob))))))
+ (setq fullsels
+ (append fullsels (mapcar #'(lambda (att) (cons nil att))
+ (listify ob))))))
(dolist (ob (listify order-by-descending))
(when (and ob (not (member ob (mapcar #'cdr fullsels)
:test #'ref-equal)))
- (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att))
- (listify ob))))))
+ (setq fullsels
+ (append fullsels (mapcar #'(lambda (att) (cons nil att))
+ (listify ob))))))
(dolist (ob (listify distinct))
- (when (and (typep ob 'sql-ident) (not (member ob (mapcar #'cdr fullsels)
- :test #'ref-equal)))
- (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att))
- (listify ob))))))
- ;; (cmsg "Tables = ~s" tables)
- ;; (cmsg "From = ~s" from)
- (setq res (apply #'select (append (mapcar #'cdr fullsels)
- (cons :from (list (append (when from (listify from)) (listify tables)))) args)))
- (flet ((build-object (vals)
- (flet ((%build-object (vclass selects)
- (let ((class-name (class-name vclass))
- (db-vals (butlast vals (- (list-length vals)
- (list-length selects)))))
- ;; (setf vals (nthcdr (list-length selects) vals))
- (%make-fresh-object class-name (mapcar #'car selects) db-vals))))
- (let ((objects (mapcar #'%build-object sclasses sels)))
- (if (= (length sclasses) 1)
- (car objects)
- objects)))))
- (mapcar #'build-object res))))))
-
-(defun %make-fresh-object (class-name slots values)
- (let* ((*db-initializing* t)
- (obj (make-instance class-name
- :view-database *default-database*)))
- (setf obj (get-slot-values-from-view obj slots values))
- (postinitialize obj)
- obj))
-
-(defun select (&rest select-all-args)
+ (when (and (typep ob 'sql-ident)
+ (not (member ob (mapcar #'cdr fullsels)
+ :test #'ref-equal)))
+ (setq fullsels
+ (append fullsels (mapcar #'(lambda (att) (cons nil att))
+ (listify ob))))))
+ (setq res
+ (apply #'select
+ (append (mapcar #'cdr fullsels)
+ (cons :from
+ (list (append (when from (listify from))
+ (listify tables))))
+ (list :result-types nil)
+ 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
target-args))))
(multiple-value-bind (target-args qualifier-args)
(query-get-selections select-all-args)
- ;; (cmsg "Qual args = ~s" qualifier-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
- (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)))))))
+