+4 May 2004 Kevin Rosenberg (kevin@rosenberg.net)
+ * sql/classes.lisp: Add SQL-OBJECT-QUERY type. Have [select 'class]
+ now return a sql-object-query type rather than directly performing a query.
+ This improves CommonSQL conformance.
+ * sql/sql.lisp: Add new QUERY method for SQL-OBJECT-QUERY. Move
+ from basic/basic-sql.lisp the DO-QUERY and MAP-QUERY since they now
+ depend on sql-object-query-type.
+ * sql/loop-extensions.lisp: Move from base package
+ * classic/package.lisp: remove references to map-query and do-query
+
4 May 2004 Kevin Rosenberg (kevin@rosenberg.net)
* TODO: New section on optimizations, especially optimizing JOINs.
* sql/objects.lisp: Have :target-slot return of list of lists rather
statement and just requiring one SQL query. Add :retrieval :deferrred
to target-slot joins. Add placeholder for update-objects-join.
* sql/classes.lisp: Add :inner-join and :on slots to sql-query class
- and process them for query output-sql.
-
+ and process them for query output-sql.
+
4 May 2004 Kevin Rosenberg (kevin@rosenberg.net)
* Version 2.10.11
* base/basic-sql.lisp: Avoid multiple evaluation
(record-sql-action res :result database))
(values))
-(defmacro do-query (((&rest args) query-expression
- &key (database '*default-database*) (result-types :auto))
- &body body)
- "Repeatedly executes BODY within a binding of ARGS on the
-attributes of each record resulting from QUERY-EXPRESSION. The
-return value is determined by the result of executing BODY. The
-default value of DATABASE is *DEFAULT-DATABASE*."
- (let ((result-set (gensym "RESULT-SET-"))
- (qe (gensym "QUERY-EXPRESSION-"))
- (columns (gensym "COLUMNS-"))
- (row (gensym "ROW-"))
- (db (gensym "DB-")))
- `(let ((,qe ,query-expression))
- (typecase ,qe
- (list
- ;; Object query
- (dolist (,row ,qe)
- (destructuring-bind ,args
- ,row
- ,@body)))
- (t
- ;; Functional query
- (let ((,db ,database))
- (multiple-value-bind (,result-set ,columns)
- (database-query-result-set ,qe ,db
- :full-set nil
- :result-types ,result-types)
- (when ,result-set
- (unwind-protect
- (do ((,row (make-list ,columns)))
- ((not (database-store-next-row ,result-set ,db ,row))
- nil)
- (destructuring-bind ,args ,row
- ,@body))
- (database-dump-result-set ,result-set ,db))))))))))
-
-(defun map-query (output-type-spec function query-expression
- &key (database *default-database*)
- (result-types :auto))
- "Map the function over all tuples that are returned by the
-query in QUERY-EXPRESSION. The results of the function are
-collected as specified in OUTPUT-TYPE-SPEC and returned like in
-MAP."
- (if (listp query-expression)
- ;; Object query
- (map output-type-spec #'(lambda (x) (apply function x)) query-expression)
- ;; Functional query
- (macrolet ((type-specifier-atom (type)
- `(if (atom ,type) ,type (car ,type))))
- (case (type-specifier-atom output-type-spec)
- ((nil)
- (map-query-for-effect function query-expression database
- result-types))
- (list
- (map-query-to-list function query-expression database result-types))
- ((simple-vector simple-string vector string array simple-array
- bit-vector simple-bit-vector base-string
- simple-base-string)
- (map-query-to-simple output-type-spec function query-expression
- database result-types))
- (t
- (funcall #'map-query
- (cmucl-compat:result-type-or-lose output-type-spec t)
- function query-expression :database database
- :result-types result-types))))))
-
-(defun map-query-for-effect (function query-expression database result-types)
- (multiple-value-bind (result-set columns)
- (database-query-result-set query-expression database :full-set nil
- :result-types result-types)
- (when result-set
- (unwind-protect
- (do ((row (make-list columns)))
- ((not (database-store-next-row result-set database row))
- nil)
- (apply function row))
- (database-dump-result-set result-set database)))))
-
-(defun map-query-to-list (function query-expression database result-types)
- (multiple-value-bind (result-set columns)
- (database-query-result-set query-expression database :full-set nil
- :result-types result-types)
- (when result-set
- (unwind-protect
- (let ((result (list nil)))
- (do ((row (make-list columns))
- (current-cons result (cdr current-cons)))
- ((not (database-store-next-row result-set database row))
- (cdr result))
- (rplacd current-cons (list (apply function row)))))
- (database-dump-result-set result-set database)))))
-
-
-(defun map-query-to-simple (output-type-spec function query-expression database result-types)
- (multiple-value-bind (result-set columns rows)
- (database-query-result-set query-expression database :full-set t
- :result-types result-types)
- (when result-set
- (unwind-protect
- (if rows
- ;; We know the row count in advance, so we allocate once
- (do ((result
- (cmucl-compat:make-sequence-of-type output-type-spec rows))
- (row (make-list columns))
- (index 0 (1+ index)))
- ((not (database-store-next-row result-set database row))
- result)
- (declare (fixnum index))
- (setf (aref result index)
- (apply function row)))
- ;; Database can't report row count in advance, so we have
- ;; to grow and shrink our vector dynamically
- (do ((result
- (cmucl-compat:make-sequence-of-type output-type-spec 100))
- (allocated-length 100)
- (row (make-list columns))
- (index 0 (1+ index)))
- ((not (database-store-next-row result-set database row))
- (cmucl-compat:shrink-vector result index))
- (declare (fixnum allocated-length index))
- (when (>= index allocated-length)
- (setq allocated-length (* allocated-length 2)
- result (adjust-array result allocated-length)))
- (setf (aref result index)
- (apply function row))))
- (database-dump-result-set result-set database)))))
-
;;; Large objects support
(defun create-large-object (&key (database *default-database*))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: loop-extension.lisp
-;;;; Purpose: Extensions to the Loop macro for CLSQL
-;;;;
-;;;; Copyright (c) 2001-2004 Kevin Rosenberg and (c) 1999-2001 Pierre R. Mai
-;;;;
-;;;; $Id$
-;;;; *************************************************************************
-
-(in-package #:cl-user)
-
-#+(or allegro sbcl)
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defpackage #:ansi-loop
- (:import-from #+sbcl #:sb-loop #+allegro #:excl
- #:loop-error
- #:*loop-epilogue*
- #:*loop-ansi-universe*
- #:add-loop-path)))
-
-#+(or allegro sbcl)
-(defun ansi-loop::loop-gentemp (&optional (pref 'loopva-))
- (gensym (string pref)))
-
-#+(or cmu scl sbcl openmcl allegro)
-(defun loop-record-iteration-path (variable data-type prep-phrases)
- (let ((in-phrase nil)
- (from-phrase nil))
- (loop for (prep . rest) in prep-phrases
- do
- (case prep
- ((:in :of)
- (when in-phrase
- (ansi-loop::loop-error
- "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
- (setq in-phrase rest))
- ((:from)
- (when from-phrase
- (ansi-loop::loop-error
- "Duplicate FROM iteration path: ~S." (cons prep rest)))
- (setq from-phrase rest))
- (t
- (ansi-loop::loop-error
- "Unknown preposition: ~S." prep))))
- (unless in-phrase
- (ansi-loop::loop-error "Missing OF or IN iteration path."))
- (unless from-phrase
- (setq from-phrase '(clsql-base:*default-database*)))
-
- (unless (consp variable)
- (setq variable (list variable)))
-
- (cond
- ;; Object query resulting in a list of returned object instances
- ((and (consp (first in-phrase))
- (consp (second (first in-phrase)))
- (eq 'quote (first (second (first in-phrase))))
- (symbolp (second (second (first in-phrase)))))
-
- (let ((result-var (ansi-loop::loop-gentemp
- 'loop-record-result-))
- (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
- `(((,variable nil ,@(and data-type (list data-type)))
- (,result-var ,(first in-phrase))
- (,step-var nil))
- ()
- ()
- ()
- (if (null ,result-var)
- t
- (progn
- (setq ,step-var (first ,result-var))
- (setq ,result-var (rest ,result-var))
- nil))
- (,variable ,step-var)
- (null ,result-var)
- ()
- (if (null ,result-var)
- t
- (progn
- (setq ,step-var (first ,result-var))
- (setq ,result-var (rest ,result-var))
- nil))
- (,variable ,step-var))))
-
- ((consp variable)
- (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
- (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
- (result-set-var (ansi-loop::loop-gentemp
- 'loop-record-result-set-))
- (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
- (push `(when ,result-set-var
- (clsql-base:database-dump-result-set ,result-set-var ,db-var))
- ansi-loop::*loop-epilogue*)
- `(((,variable nil ,@(and data-type (list data-type)))
- (,query-var ,(first in-phrase))
- (,db-var ,(first from-phrase))
- (,result-set-var nil)
- (,step-var nil))
- ((multiple-value-bind (%rs %cols)
- (clsql-base:database-query-result-set ,query-var ,db-var :result-types :auto)
- (setq ,result-set-var %rs ,step-var (make-list %cols))))
- ()
- ()
- (not (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var))
- (,variable ,step-var)
- (not ,result-set-var)
- ()
- (not (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var))
- (,variable ,step-var)))))))
-
-#+(or cmu scl sbcl openmcl allegro)
-(ansi-loop::add-loop-path '(record records tuple tuples)
- 'loop-record-iteration-path
- ansi-loop::*loop-ansi-universe*
- :preposition-groups '((:of :in) (:from))
- :inclusive-permitted nil)
-
-#+lispworks
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (in-package loop))
-
-#+lispworks
-(cl-user::define-loop-method (record records tuple tuples) clsql-loop-method
- (in of from))
-
-#+lispworks
-(defun clsql-loop-method (method-name iter-var iter-var-data-type
- prep-phrases inclusive? allowed-preps
- method-specific-data)
- (declare (ignore method-name inclusive? allowed-preps method-specific-data))
- (let ((in-phrase nil)
- (from-phrase nil))
- (loop for (prep . rest) in prep-phrases
- do
- (cond
- ((or (eq prep 'in) (eq prep 'of))
- (when in-phrase
- (error
- "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
- (setq in-phrase rest))
- ((eq prep 'from)
- (when from-phrase
- (error
- "Duplicate FROM iteration path: ~S." (cons prep rest)))
- (setq from-phrase rest))
- (t
- (error
- "Unknown preposition: ~S." prep))))
- (unless in-phrase
- (error "Missing OF or IN iteration path."))
- (unless from-phrase
- (setq from-phrase '(clsql-base:*default-database*)))
-
- (unless (consp iter-var)
- (setq iter-var (list iter-var)))
-
- (cond
- ;; Object query resulting in a list of returned object instances
- ((and (string-equal "select" (symbol-name (car in-phrase)))
- (eq 'quote (first (second in-phrase)))
- (symbolp (second (second in-phrase))))
-
- (let ((result-var (gensym "LOOP-RECORD-RESULT-"))
- (step-var (gensym "LOOP-RECORD-STEP-")))
- (values
- t
- nil
- `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
- (,result-var ,in-phrase)
- (,step-var nil))
- ()
- ()
- ()
- `((if (null ,result-var)
- t
- (progn
- (setq ,step-var (first ,result-var))
- (setq ,result-var (rest ,result-var))
- nil)))
- `(,iter-var ,step-var)
- `((if (null ,result-var)
- t
- (progn
- (setq ,step-var (first ,result-var))
- (setq ,result-var (rest ,result-var))
- nil)))
- `(,iter-var ,step-var)
- ()
- ()
- )))
-
- ((consp iter-var)
- (let ((query-var (gensym "LOOP-RECORD-"))
- (db-var (gensym "LOOP-RECORD-DATABASE-"))
- (result-set-var (gensym "LOOP-RECORD-RESULT-SET-"))
- (step-var (gensym "LOOP-RECORD-STEP-")))
- (values
- t
- nil
- `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
- (,query-var ,in-phrase)
- (,db-var ,(first from-phrase))
- (,result-set-var nil)
- (,step-var nil))
- `((multiple-value-bind (%rs %cols)
- (clsql-base:database-query-result-set ,query-var ,db-var :result-types :auto)
- (setq ,result-set-var %rs ,step-var (make-list %cols))))
- ()
- ()
- `((unless (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var)
- (when ,result-set-var
- (clsql-base:database-dump-result-set ,result-set-var ,db-var))
- t))
- `(,iter-var ,step-var)
- `((unless (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var)
- (when ,result-set-var
- (clsql-base:database-dump-result-set ,result-set-var ,db-var))
- t))
- `(,iter-var ,step-var)
- ()
- ()))))))
-
#:write-large-object
#:read-large-object
#:delete-large-object
- #:do-query
- #:map-query
#:describe-table
;; Transactions
#:write-large-object
#:read-large-object
#:delete-large-object
- #:do-query
- #:map-query
;; Transactions
#:with-transaction
(:file "conditions" :depends-on ("classes"))
(:file "db-interface" :depends-on ("conditions"))
(:file "initialize" :depends-on ("db-interface" "utils"))
- (:file "loop-extension" :depends-on ("db-interface"))
(:file "time" :depends-on ("package"))
(:file "database" :depends-on ("initialize"))
(:file "recording" :depends-on ("time" "database"))
:pathname ""
:components ((:file "generics")
(:file "classes" :depends-on ("generics"))
+ (:file "loop-extension" :depends-on ("classes"))
(:file "operations" :depends-on ("classes"))
(:file "syntax" :depends-on ("operations")))
:depends-on (:package))
:initform nil))
(:documentation "An SQL SELECT query."))
+(defclass sql-object-query (%sql-expression)
+ ((objects
+ :initarg :objects
+ :initform nil)
+ (flatp
+ :initarg :flatp
+ :initform nil)
+ (exp
+ :initarg :exp
+ :initform nil)
+ (refresh
+ :initarg :refresh
+ :initform nil)))
+
(defmethod collect-table-refs ((sql sql-query))
(remove-duplicates (collect-table-refs (slot-value sql 'where))
:test (lambda (tab1 tab2)
(multiple-value-bind (selections arglist)
(query-get-selections args)
(if (select-objects selections)
- (apply #'select args)
+ (destructuring-bind (&key flatp refresh &allow-other-keys) arglist
+ (make-instance 'sql-object-query :objects selections
+ :flatp flatp :refresh refresh
+ :exp arglist))
(destructuring-bind (&key all flatp set-operation distinct from where
group-by having order-by order-by-descending
offset limit inner-join on &allow-other-keys)
(write-string ")" *sql-stream*)))
t)
+(defmethod output-sql ((query sql-object-query) database)
+ (with-slots (objects)
+ query
+ (when objects
+ (format *sql-stream* "(~{~A~^ ~})" objects))))
+
+
;; INSERT
(defclass sql-insert (%sql-expression)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: loop-extension.lisp
+;;;; Purpose: Extensions to the Loop macro for CLSQL
+;;;;
+;;;; Copyright (c) 2001-2004 Kevin Rosenberg and (c) 1999-2001 Pierre R. Mai
+;;;;
+;;;; $Id$
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+
+#+(or allegro sbcl)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defpackage #:ansi-loop
+ (:import-from #+sbcl #:sb-loop #+allegro #:excl
+ #:loop-error
+ #:*loop-epilogue*
+ #:*loop-ansi-universe*
+ #:add-loop-path)))
+
+#+(or allegro sbcl)
+(defun ansi-loop::loop-gentemp (&optional (pref 'loopva-))
+ (gensym (string pref)))
+
+#+(or cmu scl sbcl openmcl allegro)
+(defun loop-record-iteration-path (variable data-type prep-phrases)
+ (let ((in-phrase nil)
+ (from-phrase nil))
+ (loop for (prep . rest) in prep-phrases
+ do
+ (case prep
+ ((:in :of)
+ (when in-phrase
+ (ansi-loop::loop-error
+ "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
+ (setq in-phrase rest))
+ ((:from)
+ (when from-phrase
+ (ansi-loop::loop-error
+ "Duplicate FROM iteration path: ~S." (cons prep rest)))
+ (setq from-phrase rest))
+ (t
+ (ansi-loop::loop-error
+ "Unknown preposition: ~S." prep))))
+ (unless in-phrase
+ (ansi-loop::loop-error "Missing OF or IN iteration path."))
+ (unless from-phrase
+ (setq from-phrase '(clsql:*default-database*)))
+
+ (unless (consp variable)
+ (setq variable (list variable)))
+
+ (cond
+ ;; object query
+ ((and (consp (first in-phrase))
+ (string-equal "sql-query" (symbol-name (caar in-phrase)))
+ (consp (second (first in-phrase)))
+ (eq 'quote (first (second (first in-phrase))))
+ (symbolp (second (second (first in-phrase)))))
+
+ (let ((result-var (ansi-loop::loop-gentemp
+ 'loop-record-result-))
+ (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
+ `(((,variable nil ,@(and data-type (list data-type)))
+ (,result-var (clsql:query ,(first in-phrase)))
+ (,step-var nil))
+ ()
+ ()
+ ()
+ (if (null ,result-var)
+ t
+ (progn
+ (setq ,step-var (first ,result-var))
+ (setq ,result-var (rest ,result-var))
+ nil))
+ (,variable ,step-var)
+ (null ,result-var)
+ ()
+ (if (null ,result-var)
+ t
+ (progn
+ (setq ,step-var (first ,result-var))
+ (setq ,result-var (rest ,result-var))
+ nil))
+ (,variable ,step-var))))
+
+ ((consp variable)
+ (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
+ (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
+ (result-set-var (ansi-loop::loop-gentemp
+ 'loop-record-result-set-))
+ (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
+ (push `(when ,result-set-var
+ (clsql:database-dump-result-set ,result-set-var ,db-var))
+ ansi-loop::*loop-epilogue*)
+ `(((,variable nil ,@(and data-type (list data-type)))
+ (,query-var ,(first in-phrase))
+ (,db-var ,(first from-phrase))
+ (,result-set-var nil)
+ (,step-var nil))
+ ((multiple-value-bind (%rs %cols)
+ (clsql:database-query-result-set ,query-var ,db-var :result-types :auto)
+ (setq ,result-set-var %rs ,step-var (make-list %cols))))
+ ()
+ ()
+ (not (clsql:database-store-next-row ,result-set-var ,db-var ,step-var))
+ (,variable ,step-var)
+ (not ,result-set-var)
+ ()
+ (not (clsql:database-store-next-row ,result-set-var ,db-var ,step-var))
+ (,variable ,step-var)))))))
+
+#+(or cmu scl sbcl openmcl allegro)
+(ansi-loop::add-loop-path '(record records tuple tuples)
+ 'loop-record-iteration-path
+ ansi-loop::*loop-ansi-universe*
+ :preposition-groups '((:of :in) (:from))
+ :inclusive-permitted nil)
+
+#+lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (in-package loop))
+
+#+lispworks
+(cl-user::define-loop-method (record records tuple tuples) clsql-loop-method
+ (in of from))
+
+#+lispworks
+(defun clsql-loop-method (method-name iter-var iter-var-data-type
+ prep-phrases inclusive? allowed-preps
+ method-specific-data)
+ (declare (ignore method-name inclusive? allowed-preps method-specific-data))
+ (let ((in-phrase nil)
+ (from-phrase nil))
+ (loop for (prep . rest) in prep-phrases
+ do
+ (cond
+ ((or (eq prep 'in) (eq prep 'of))
+ (when in-phrase
+ (error
+ "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
+ (setq in-phrase rest))
+ ((eq prep 'from)
+ (when from-phrase
+ (error
+ "Duplicate FROM iteration path: ~S." (cons prep rest)))
+ (setq from-phrase rest))
+ (t
+ (error
+ "Unknown preposition: ~S." prep))))
+ (unless in-phrase
+ (error "Missing OF or IN iteration path."))
+ (unless from-phrase
+ (setq from-phrase '(clsql:*default-database*)))
+
+ (unless (consp iter-var)
+ (setq iter-var (list iter-var)))
+
+ (cond
+ ;; object query
+ ((and (consp in-phrase)
+ (string-equal "sql-query" (symbol-name (car in-phrase)))
+ (consp (second in-phrase))
+ (eq 'quote (first (second in-phrase)))
+ (symbolp (second (second in-phrase))))
+
+ (let ((result-var (gensym "LOOP-RECORD-RESULT-"))
+ (step-var (gensym "LOOP-RECORD-STEP-")))
+ (values
+ t
+ nil
+ `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
+ (,result-var (clsql:query ,in-phrase))
+ (,step-var nil))
+ ()
+ ()
+ ()
+ `((if (null ,result-var)
+ t
+ (progn
+ (setq ,step-var (first ,result-var))
+ (setq ,result-var (rest ,result-var))
+ nil)))
+ `(,iter-var ,step-var)
+ `((if (null ,result-var)
+ t
+ (progn
+ (setq ,step-var (first ,result-var))
+ (setq ,result-var (rest ,result-var))
+ nil)))
+ `(,iter-var ,step-var)
+ ()
+ ()
+ )))
+
+ ((consp iter-var)
+ (let ((query-var (gensym "LOOP-RECORD-"))
+ (db-var (gensym "LOOP-RECORD-DATABASE-"))
+ (result-set-var (gensym "LOOP-RECORD-RESULT-SET-"))
+ (step-var (gensym "LOOP-RECORD-STEP-")))
+ (values
+ t
+ nil
+ `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
+ (,query-var ,in-phrase)
+ (,db-var ,(first from-phrase))
+ (,result-set-var nil)
+ (,step-var nil))
+ `((multiple-value-bind (%rs %cols)
+ (clsql:database-query-result-set ,query-var ,db-var :result-types :auto)
+ (setq ,result-set-var %rs ,step-var (make-list %cols))))
+ ()
+ ()
+ `((unless (clsql:database-store-next-row ,result-set-var ,db-var ,step-var)
+ (when ,result-set-var
+ (clsql:database-dump-result-set ,result-set-var ,db-var))
+ t))
+ `(,iter-var ,step-var)
+ `((unless (clsql:database-store-next-row ,result-set-var ,db-var ,step-var)
+ (when ,result-set-var
+ (clsql:database-dump-result-set ,result-set-var ,db-var))
+ t))
+ `(,iter-var ,step-var)
+ ()
+ ()))))))
+
#:write-large-object
#:read-large-object
#:delete-large-object
- #:do-query
- #:map-query
#:describe-table
#:create-large-object
#:write-large-object
#:database-underlying-type
.
- ;; Shared exports for re-export by CLSQL.
+ ;; Shared exports for re-export by CLSQL-USER.
;; I = Implemented, D = Documented
;; name file ID
;;====================================================
#:sql-and-qualifier
#:sql-escape
#:sql-query
+ #:sql-object-query
#:sql-any
#:sql-all
#:sql-not
#:sql-view-class
#:sql_slot-value
+ #:do-query
+ #:map-query
+
.
#1#
))
(query (sql-output expr database) :database database :flatp flatp
:result-types result-types :field-names field-names))
+(defmethod query ((expr sql-object-query) &key (database *default-database*)
+ (result-types :auto) (flatp nil))
+ (declare (ignore result-types))
+ (apply #'select (append (slot-value expr 'objects)
+ (slot-value expr 'exp)
+ (when (slot-value expr 'refresh)
+ (list :refresh (sql-output expr database)))
+ (when (or flatp (slot-value expr 'flatp) )
+ (list :flatp t))
+ (list :database database))))
+
(defun truncate-database (&key (database *default-database*))
(unless (typep database 'database)
(clsql-base::signal-no-database-error database))
(when sequence
(create-sequence-from-class class)))))
+;;; Iteration
+
+
+(defmacro do-query (((&rest args) query-expression
+ &key (database '*default-database*) (result-types :auto))
+ &body body)
+ "Repeatedly executes BODY within a binding of ARGS on the
+attributes of each record resulting from QUERY-EXPRESSION. The
+return value is determined by the result of executing BODY. The
+default value of DATABASE is *DEFAULT-DATABASE*."
+ (let ((result-set (gensym "RESULT-SET-"))
+ (qe (gensym "QUERY-EXPRESSION-"))
+ (columns (gensym "COLUMNS-"))
+ (row (gensym "ROW-"))
+ (db (gensym "DB-")))
+ `(let ((,qe ,query-expression))
+ (typecase ,qe
+ (sql-object-query
+ (dolist (,row (query ,qe))
+ (destructuring-bind ,args
+ ,row
+ ,@body)))
+ (t
+ ;; Functional query
+ (let ((,db ,database))
+ (multiple-value-bind (,result-set ,columns)
+ (database-query-result-set ,qe ,db
+ :full-set nil
+ :result-types ,result-types)
+ (when ,result-set
+ (unwind-protect
+ (do ((,row (make-list ,columns)))
+ ((not (database-store-next-row ,result-set ,db ,row))
+ nil)
+ (destructuring-bind ,args ,row
+ ,@body))
+ (database-dump-result-set ,result-set ,db))))))))))
+
+(defun map-query (output-type-spec function query-expression
+ &key (database *default-database*)
+ (result-types :auto))
+ "Map the function over all tuples that are returned by the
+query in QUERY-EXPRESSION. The results of the function are
+collected as specified in OUTPUT-TYPE-SPEC and returned like in
+MAP."
+ (typecase query-expression
+ (sql-object-query
+ (map output-type-spec #'(lambda (x) (apply function x))
+ (query query-expression)))
+ (t
+ ;; Functional query
+ (macrolet ((type-specifier-atom (type)
+ `(if (atom ,type) ,type (car ,type))))
+ (case (type-specifier-atom output-type-spec)
+ ((nil)
+ (map-query-for-effect function query-expression database
+ result-types))
+ (list
+ (map-query-to-list function query-expression database result-types))
+ ((simple-vector simple-string vector string array simple-array
+ bit-vector simple-bit-vector base-string
+ simple-base-string)
+ (map-query-to-simple output-type-spec function query-expression
+ database result-types))
+ (t
+ (funcall #'map-query
+ (cmucl-compat:result-type-or-lose output-type-spec t)
+ function query-expression :database database
+ :result-types result-types)))))))
+
+(defun map-query-for-effect (function query-expression database result-types)
+ (multiple-value-bind (result-set columns)
+ (database-query-result-set query-expression database :full-set nil
+ :result-types result-types)
+ (when result-set
+ (unwind-protect
+ (do ((row (make-list columns)))
+ ((not (database-store-next-row result-set database row))
+ nil)
+ (apply function row))
+ (database-dump-result-set result-set database)))))
+
+(defun map-query-to-list (function query-expression database result-types)
+ (multiple-value-bind (result-set columns)
+ (database-query-result-set query-expression database :full-set nil
+ :result-types result-types)
+ (when result-set
+ (unwind-protect
+ (let ((result (list nil)))
+ (do ((row (make-list columns))
+ (current-cons result (cdr current-cons)))
+ ((not (database-store-next-row result-set database row))
+ (cdr result))
+ (rplacd current-cons (list (apply function row)))))
+ (database-dump-result-set result-set database)))))
+
+
+(defun map-query-to-simple (output-type-spec function query-expression database result-types)
+ (multiple-value-bind (result-set columns rows)
+ (database-query-result-set query-expression database :full-set t
+ :result-types result-types)
+ (when result-set
+ (unwind-protect
+ (if rows
+ ;; We know the row count in advance, so we allocate once
+ (do ((result
+ (cmucl-compat:make-sequence-of-type output-type-spec rows))
+ (row (make-list columns))
+ (index 0 (1+ index)))
+ ((not (database-store-next-row result-set database row))
+ result)
+ (declare (fixnum index))
+ (setf (aref result index)
+ (apply function row)))
+ ;; Database can't report row count in advance, so we have
+ ;; to grow and shrink our vector dynamically
+ (do ((result
+ (cmucl-compat:make-sequence-of-type output-type-spec 100))
+ (allocated-length 100)
+ (row (make-list columns))
+ (index 0 (1+ index)))
+ ((not (database-store-next-row result-set database row))
+ (cmucl-compat:shrink-vector result index))
+ (declare (fixnum allocated-length index))
+ (when (>= index allocated-length)
+ (setq allocated-length (* allocated-length 2)
+ result (adjust-array result allocated-length)))
+ (setf (aref result index)
+ (apply function row))))
+ (database-dump-result-set result-set database)))))
projects / clsql.git / commitdiff