X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;ds=sidebyside;f=base%2Floop-extension.lisp;h=1746832147e8e3e28f0e827e49107ca1eb79e9f6;hb=09f07ac9d914a83f9426609f3264f4e66b5a6d97;hp=f8129b53cf527d5438ccf20bdb4e1245a38d8bd9;hpb=9bbed78051e80e6ab76ae47834136035602bbbf1;p=clsql.git diff --git a/base/loop-extension.lisp b/base/loop-extension.lisp index f8129b5..1746832 100644 --- a/base/loop-extension.lisp +++ b/base/loop-extension.lisp @@ -2,22 +2,16 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: loop-extension.lisp -;;;; Purpose: Extensions to the Loop macro for CMUCL -;;;; Programmer: Pierre R. Mai +;;;; Name: loop-extension.lisp +;;;; Purpose: Extensions to the Loop macro for CLSQL ;;;; -;;;; Copyright (c) 1999-2001 Pierre R. Mai +;;;; Copyright (c) 2001-2004 Kevin Rosenberg and (c) 1999-2001 Pierre R. Mai ;;;; ;;;; $Id$ -;;;; -;;;; The functions in this file were orignally distributed in the -;;;; MaiSQL package in the file sql/sql.cl ;;;; ************************************************************************* (in-package #:cl-user) -;;;; MIT-LOOP extension - #+(or allegro sbcl) (eval-when (:compile-toplevel :load-toplevel :execute) (defpackage #:ansi-loop @@ -55,7 +49,44 @@ (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 + ((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-base: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-)) @@ -71,7 +102,7 @@ (,result-set-var nil) (,step-var nil)) ((multiple-value-bind (%rs %cols) - (clsql-base:database-query-result-set ,query-var ,db-var) + (clsql-base:database-query-result-set ,query-var ,db-var :result-types :auto) (setq ,result-set-var %rs ,step-var (make-list %cols)))) () () @@ -80,30 +111,7 @@ (not ,result-set-var) () (not (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var)) - (,variable ,step-var)))) - (t - (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-))) - (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)) - ((multiple-value-bind (%rs %cols) - (clsql-base:database-query-result-set ,query-var ,db-var) - (setq ,result-set-var %rs ,variable (make-list %cols)))) - () - () - (not (clsql-base:database-store-next-row ,result-set-var ,db-var ,variable)) - () - (not ,result-set-var) - () - (not (clsql-base:database-store-next-row ,result-set-var ,db-var ,variable)) - ())))))) + (,variable ,step-var))))))) #+(or cmu scl sbcl openmcl allegro) (ansi-loop::add-loop-path '(record records tuple tuples) @@ -147,7 +155,47 @@ (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 + ((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-base: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-")) @@ -162,7 +210,7 @@ (,result-set-var nil) (,step-var nil)) `((multiple-value-bind (%rs %cols) - (clsql-base:database-query-result-set ,query-var ,db-var) + (clsql-base:database-query-result-set ,query-var ,db-var :result-types :auto) (setq ,result-set-var %rs ,step-var (make-list %cols)))) () () @@ -177,32 +225,5 @@ t)) `(,iter-var ,step-var) () - ()))) - (t - (let ((query-var (gensym "LOOP-RECORD-")) - (db-var (gensym "LOOP-RECORD-DATABASE-")) - (result-set-var (gensym "LOOP-RECORD-RESULT-SET-"))) - (values - t - nil - `((,iter-var nil ,iter-var-data-type) (,query-var ,in-phrase) - (,db-var ,(first from-phrase)) - (,result-set-var nil)) - `((multiple-value-bind (%rs %cols) - (clsql-base:database-query-result-set ,query-var ,db-var) - (setq ,result-set-var %rs ,iter-var (make-list %cols)))) - () - () - `((unless (clsql-base:database-store-next-row ,result-set-var ,db-var ,iter-var) - (when ,result-set-var - (clsql-base:database-dump-result-set ,result-set-var ,db-var)) - t)) - () - `((unless (clsql-base:database-store-next-row ,result-set-var ,db-var ,iter-var) - (when ,result-set-var - (clsql-base:database-dump-result-set ,result-set-var ,db-var)) - t)) - () - () ()))))))