r9336: 12 May 2004 Kevin Rosenberg (kevin@rosenberg.net)

[clsql.git] / sql / sql.lisp

diff --git a/sql/sql.lisp b/sql/sql.lisp
index 0397bd031ca01984702a667bd031bba537fd824c..ae4da839514b7b8b32b0a32ee9f696308b41aa85 100644 (file)
--- a/sql/sql.lisp
+++ b/sql/sql.lisp
@@ -12,7 +12,7 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
-(in-package #:clsql)
+(in-package #:clsql-sys)
   
 ;;; Basic operations on databases
 
@@ -45,7 +45,7 @@
 
 (defun truncate-database (&key (database *default-database*))
   (unless (typep database 'database)
-    (clsql-base::signal-no-database-error database))
+    (signal-no-database-error database))
   (unless (is-database-open database)
     (database-reconnect database))
   (when (db-type-has-views? (database-underlying-type database))
@@ -413,3 +413,75 @@ MAP."
                 (setf (aref result index)
                       (apply function row))))
        (database-dump-result-set result-set database)))))
+
+;;; Row processing macro from CLSQL
+
+(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))))))
+
+(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) "")))
+
+(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))))))
+
+
+