X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fsql.lisp;h=e1492a5c7c7296cdf5c48a0ea6d77ba589b40dfb;hp=28be8ef8cbb26343b9bea0bd085e32f5c2263484;hb=bada52b7a8fd2cc484dee33cccd64ca09a52ec3d;hpb=8c09e4e3c39558d8bb727d273c580606386862de

diff --git a/sql/sql.lisp b/sql/sql.lisp
index 28be8ef..e1492a5 100644
--- a/sql/sql.lisp
+++ b/sql/sql.lisp
@@ -2,13 +2,12 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Name:          sql.cl
-;;;; Purpose:       High-level SQL interface
-;;;; Programmers:   Kevin M. Rosenberg based on
-;;;;                 Original code by Pierre R. Mai 
-;;;; Date Started:  Feb 2002
+;;;; Name:         sql.cl
+;;;; Purpose:      High-level SQL interface
+;;;; Authors:      Kevin M. Rosenberg based on code by Pierre R. Mai 
+;;;; Date Started: Feb 2002
 ;;;;
-;;;; $Id: sql.lisp,v 1.4 2002/11/14 18:52:47 kevin Exp $
+;;;; $Id$
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -18,16 +17,10 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :clsql-sys)
+(eval-when (:compile-toplevel)
+  (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))))
 
-;;; Modified by KMR 
-;;; - to use CMUCL-COMPAT library 
-;;; - fix format strings in error messages 
-;;; - use field types
-
-
-;;; Simple implementation of SQL along the lines of Harlequin's Common SQL
+(in-package #:clsql-sys)
 
 
 ;;; Database handling
@@ -261,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))))))