X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fsql.lisp;h=0a733aa81035c787e3a12d2c51bf0eb010b4f5a2;hb=21ffe5f820036726c6353a16dfb478fb41aa700c;hp=0397bd031ca01984702a667bd031bba537fd824c;hpb=279b34c9e8e28545c8f2a0959acb01d90138eeda;p=clsql.git

diff --git a/sql/sql.lisp b/sql/sql.lisp
index 0397bd0..0a733aa 100644
--- 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
 
@@ -33,8 +33,8 @@
          :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))
+		  (result-types :auto) (flatp nil) (field-names t))
+  (declare (ignore result-types field-names))
   (apply #'select (append (slot-value expr 'objects)
 			  (slot-value expr 'exp) 
 			  (when (slot-value expr 'refresh) 
@@ -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))
@@ -71,7 +71,10 @@ default value of T, which specifies that minimum sizes are
 computed. The output stream is given by STREAM, which has a default
 value of T. This specifies that *STANDARD-OUTPUT* is used."
   (flet ((compute-sizes (data)
-           (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
+           (mapcar #'(lambda (x) 
+                       (apply #'max (mapcar #'(lambda (y) 
+                                                (if (null y) 3 (length y)))
+                                            x)))
                    (apply #'mapcar (cons #'list data))))
          (format-record (record control sizes)
            (format stream "~&~?" control
@@ -80,7 +83,8 @@ value of T. This specifies that *STANDARD-OUTPUT* is used."
     (let* ((query-exp (etypecase query-exp
                         (string query-exp)
                         (sql-query (sql-output query-exp database))))
-           (data (query query-exp :database database))
+           (data (query query-exp :database database :result-types nil 
+                        :field-names nil))
            (sizes (if (or (null sizes) (listp sizes)) sizes 
                       (compute-sizes (if titles (cons titles data) data))))
            (formats (if (or (null formats) (not (listp formats)))
@@ -413,3 +417,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))))))
+
+
+