From b3c7fcd23a62240f0f1deb0c4f895cbd981ef5f4 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Wed, 23 Jul 2003 19:33:38 +0000
Subject: [PATCH] r5378: *** empty log message ***

---
 ChangeLog        |  3 ++
 debian/changelog |  6 ++++
 sql/package.lisp |  3 +-
 sql/sql.lisp     | 74 +++++++++++++++++++++++++++++++++++++++++++++++-
 4 files changed, 84 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 394682e..04dde1c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,6 @@
+23 Jul 2003 Kevin Rosenberg (kevin@rosenberg.net)
+	* Add for-each-row macro
+
 12 Dec 2002 Kevin Rosenberg (kevin@rosenberg.net)
 	* uffi/clsql-uffi.lisp: return NIL for numeric fields that are NULL
 	
diff --git a/debian/changelog b/debian/changelog
index 04c48da..7b2cc7c 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-sql (1.7.2-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Wed, 23 Jul 2003 12:59:46 -0600
+
 cl-sql (1.7.1-1) unstable; urgency=low
 
   * New upstream
diff --git a/sql/package.lisp b/sql/package.lisp
index 0b83468..5ee3037 100644
--- a/sql/package.lisp
+++ b/sql/package.lisp
@@ -8,7 +8,7 @@
 ;;;;                Original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: package.lisp,v 1.4 2003/05/07 02:45:08 kevin Exp $
+;;;; $Id: package.lisp,v 1.5 2003/07/23 19:33:38 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -86,6 +86,7 @@
      #:execute-command
      #:map-query
      #:do-query
+     #:for-each-row
      
      ;; functional.cl
      #:insert-records
diff --git a/sql/sql.lisp b/sql/sql.lisp
index 125de20..515ed83 100644
--- a/sql/sql.lisp
+++ b/sql/sql.lisp
@@ -7,7 +7,7 @@
 ;;;; Authors:      Kevin M. Rosenberg based on code by Pierre R. Mai 
 ;;;; Date Started: Feb 2002
 ;;;;
-;;;; $Id: sql.lisp,v 1.5 2003/05/06 02:27:08 kevin Exp $
+;;;; $Id: sql.lisp,v 1.6 2003/07/23 19:33:38 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -254,3 +254,75 @@ specified in output-type-spec and returned like in MAP."
 (defun delete-large-object (object-id &key (database *default-database*))
   "Deletes the large object in the database"
   (database-delete-large-object object-id database))
+
+
+;;; Row processing macro
+
+
+
+(defun lisp->sql-name (field)
+  (typecase field
+    (string field)
+    (symbol (string-upcase (symbol-name field)))
+    (cons (cadr field))
+    (t (format nil "~A" field))))
+
+(defun field-names (field-forms)
+  "Return a list of field name strings from a fields form"
+  (loop for field-form in field-forms
+	collect
+	(lisp->sql-name
+	 (if (cadr field-form)
+	     (cadr field-form)
+	     (car field-form)))))
+
+(defun from-names (from)
+  "Return a list of field name strings from a fields form"
+  (loop for table in (if (atom from) (list from) from)
+	collect (lisp->sql-name table)))
+
+
+(defun where-strings (where)
+  (loop for w in (if (atom (car where)) (list where) where)
+	collect
+	(if (consp w)
+	    (format nil "~A ~A ~A" (second w) (first w) (third w))
+	    (format nil "~A" w))))
+
+(defun order-by-strings (order-by)
+  (loop for o in order-by
+	collect
+	(if (atom o)
+	    (lisp->sql-name o)
+	    (format nil "~A ~A" (lisp->sql-name (car o))
+		    (lisp->sql-name (cadr o))))))
+
+(defun query-string (fields from where distinct order-by limit)
+  (concatenate
+   'string
+   (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}" 
+	   (if distinct "distinct " "") (field-names fields)
+	   (from-names from))
+   (if where (format nil " where ~{~A~^ ~}"
+		     (where-strings where)) "")
+   (if order-by (format nil " order by ~{~A~^, ~}"
+			(order-by-strings order-by)))
+   (if limit (format nil " limit ~D" limit) "")))
+
+(defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body)
+  (let ((d (gensym "DISTINCT-"))
+	(bind-fields (loop for f in fields collect (car f)))
+	(w (gensym "WHERE-"))
+	(o (gensym "ORDER-BY-"))
+	(frm (gensym "FROM-"))
+	(l (gensym "LIMIT-"))
+	(q (gensym "QUERY-")))
+    `(let ((,frm ,from)
+	   (,w ,where)
+	   (,d ,distinct)
+	   (,l ,limit)
+	   (,o ,order-by))
+      (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l)))
+	(loop for tuple in (query ,q)
+	      collect (destructuring-bind ,bind-fields tuple
+		   ,@body))))))
-- 
2.34.1