From 279b34c9e8e28545c8f2a0959acb01d90138eeda Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 5 May 2004 23:03:02 +0000 Subject: [PATCH] r9252: Implement new SQL-QUERY-OBJECT class and change behavior of [select 'class] --- ChangeLog | 14 ++- base/basic-sql.lisp | 127 --------------------------- base/package.lisp | 2 - classic/package.lisp | 2 - clsql-base.asd | 1 - clsql.asd | 1 + sql/classes.lisp | 26 +++++- {base => sql}/loop-extension.lisp | 43 ++++----- sql/package.lisp | 8 +- sql/sql.lisp | 141 ++++++++++++++++++++++++++++++ 10 files changed, 207 insertions(+), 158 deletions(-) rename {base => sql}/loop-extension.lisp (82%) diff --git a/ChangeLog b/ChangeLog index 982bb0d..a9cf642 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +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 @@ -6,8 +16,8 @@ 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 diff --git a/base/basic-sql.lisp b/base/basic-sql.lisp index 2f25fd4..258832d 100644 --- a/base/basic-sql.lisp +++ b/base/basic-sql.lisp @@ -60,133 +60,6 @@ pair.")) (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*)) diff --git a/base/package.lisp b/base/package.lisp index 241d034..1650d3e 100644 --- a/base/package.lisp +++ b/base/package.lisp @@ -270,8 +270,6 @@ #:write-large-object #:read-large-object #:delete-large-object - #:do-query - #:map-query #:describe-table ;; Transactions diff --git a/classic/package.lisp b/classic/package.lisp index adf2672..004dd47 100644 --- a/classic/package.lisp +++ b/classic/package.lisp @@ -99,8 +99,6 @@ #:write-large-object #:read-large-object #:delete-large-object - #:do-query - #:map-query ;; Transactions #:with-transaction diff --git a/clsql-base.asd b/clsql-base.asd index 7484c4c..7e94f6e 100644 --- a/clsql-base.asd +++ b/clsql-base.asd @@ -41,7 +41,6 @@ (: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")) diff --git a/clsql.asd b/clsql.asd index 2842c94..3ee350c 100644 --- a/clsql.asd +++ b/clsql.asd @@ -41,6 +41,7 @@ a functional and an object oriented interface." :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)) diff --git a/sql/classes.lisp b/sql/classes.lisp index 1be0e0b..9e2338c 100644 --- a/sql/classes.lisp +++ b/sql/classes.lisp @@ -426,6 +426,20 @@ :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) @@ -459,7 +473,10 @@ uninclusive, and the args from that keyword to the end." (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) @@ -542,6 +559,13 @@ uninclusive, and the args from that keyword to the end." (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) diff --git a/base/loop-extension.lisp b/sql/loop-extension.lisp similarity index 82% rename from base/loop-extension.lisp rename to sql/loop-extension.lisp index 4fc421b..d0f816f 100644 --- a/base/loop-extension.lisp +++ b/sql/loop-extension.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: loop-extension.lisp +;;;; 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 @@ -48,14 +48,15 @@ (unless in-phrase (ansi-loop::loop-error "Missing OF or IN iteration path.")) (unless from-phrase - (setq from-phrase '(clsql-base:*default-database*))) + (setq from-phrase '(clsql:*default-database*))) (unless (consp variable) (setq variable (list variable))) (cond - ;; Object query resulting in a list of returned object instances + ;; 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))))) @@ -64,7 +65,7 @@ '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)) + (,result-var (clsql:query ,(first in-phrase))) (,step-var nil)) () () @@ -93,7 +94,7 @@ '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)) + (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)) @@ -101,15 +102,15 @@ (,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) + (clsql: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)) + (not (clsql: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)) + (not (clsql:database-store-next-row ,result-set-var ,db-var ,step-var)) (,variable ,step-var))))))) #+(or cmu scl sbcl openmcl allegro) @@ -153,16 +154,18 @@ (unless in-phrase (error "Missing OF or IN iteration path.")) (unless from-phrase - (setq from-phrase '(clsql-base:*default-database*))) + (setq from-phrase '(clsql:*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)))) + ;; 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-"))) @@ -170,8 +173,8 @@ t nil `(,@(mapcar (lambda (v) `(,v nil)) iter-var) - (,result-var ,in-phrase) - (,step-var nil)) + (,result-var (clsql:query ,in-phrase)) + (,step-var nil)) () () () @@ -207,18 +210,18 @@ (,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) + (clsql: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) + `((unless (clsql: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)) + (clsql: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) + `((unless (clsql: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)) + (clsql:database-dump-result-set ,result-set-var ,db-var)) t)) `(,iter-var ,step-var) () diff --git a/sql/package.lisp b/sql/package.lisp index 98bfd2d..ba3f972 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -201,8 +201,6 @@ #:write-large-object #:read-large-object #:delete-large-object - #:do-query - #:map-query #:describe-table #:create-large-object #:write-large-object @@ -289,7 +287,7 @@ #: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 ;;==================================================== @@ -391,6 +389,7 @@ #:sql-and-qualifier #:sql-escape #:sql-query + #:sql-object-query #:sql-any #:sql-all #:sql-not @@ -426,6 +425,9 @@ #:sql-view-class #:sql_slot-value + #:do-query + #:map-query + . #1# )) diff --git a/sql/sql.lisp b/sql/sql.lisp index 273b849..0397bd0 100644 --- a/sql/sql.lisp +++ b/sql/sql.lisp @@ -32,6 +32,17 @@ (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)) @@ -272,3 +283,133 @@ condition is true." (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))))) -- 2.34.1