r9364: Various fixes from CommonSQL Tutorial.

[clsql.git] / sql / sql.lisp

diff --git a/sql/sql.lisp b/sql/sql.lisp
index 0a733aa81035c787e3a12d2c51bf0eb010b4f5a2..6bc454724621bf4adbbc76ddfdbae63caff5b9a3 100644 (file)
--- a/sql/sql.lisp
+++ b/sql/sql.lisp
@@ -361,62 +361,85 @@ MAP."
   (multiple-value-bind (result-set columns)
       (database-query-result-set query-expression database :full-set nil
                                 :result-types result-types)
-    (when result-set
-      (unwind-protect
-          (do ((row (make-list columns)))
-              ((not (database-store-next-row result-set database row))
-               nil)
-            (apply function row))
-       (database-dump-result-set result-set database)))))
+    (let ((flatp (and (= columns 1) 
+                      (typecase query-expression 
+                        (string t) 
+                        (sql-query 
+                         (slot-value query-expression 'flatp))))))
+      (when result-set
+        (unwind-protect
+             (do ((row (make-list columns)))
+                 ((not (database-store-next-row result-set database row))
+                  nil)
+               (if flatp
+                   (apply function row)
+                   (funcall function row)))
+          (database-dump-result-set result-set database))))))
                     
 (defun map-query-to-list (function query-expression database result-types)
   (multiple-value-bind (result-set columns)
       (database-query-result-set query-expression database :full-set nil
                                 :result-types result-types)
-    (when result-set
-      (unwind-protect
-          (let ((result (list nil)))
-            (do ((row (make-list columns))
-                 (current-cons result (cdr current-cons)))
-                ((not (database-store-next-row result-set database row))
-                 (cdr result))
-              (rplacd current-cons (list (apply function row)))))
-       (database-dump-result-set result-set database)))))
-
+    (let ((flatp (and (= columns 1) 
+                      (typecase query-expression 
+                        (string t) 
+                        (sql-query 
+                         (slot-value query-expression 'flatp))))))
+      (when result-set
+        (unwind-protect
+             (let ((result (list nil)))
+               (do ((row (make-list columns))
+                    (current-cons result (cdr current-cons)))
+                   ((not (database-store-next-row result-set database row))
+                    (cdr result))
+                 (rplacd current-cons 
+                         (list (if flatp 
+                                   (apply function row)
+                                   (funcall function (copy-list row)))))))
+          (database-dump-result-set result-set database))))))
 
 (defun map-query-to-simple (output-type-spec function query-expression database result-types)
   (multiple-value-bind (result-set columns rows)
       (database-query-result-set query-expression database :full-set t
                                 :result-types result-types)
-    (when result-set
-      (unwind-protect
-          (if rows
-              ;; We know the row count in advance, so we allocate once
-              (do ((result
-                    (cmucl-compat:make-sequence-of-type output-type-spec rows))
-                   (row (make-list columns))
-                   (index 0 (1+ index)))
-                  ((not (database-store-next-row result-set database row))
-                   result)
-                (declare (fixnum index))
-                (setf (aref result index)
-                      (apply function row)))
-              ;; Database can't report row count in advance, so we have
-              ;; to grow and shrink our vector dynamically
-              (do ((result
-                    (cmucl-compat:make-sequence-of-type output-type-spec 100))
-                   (allocated-length 100)
-                   (row (make-list columns))
-                   (index 0 (1+ index)))
-                  ((not (database-store-next-row result-set database row))
-                   (cmucl-compat:shrink-vector result index))
-                (declare (fixnum allocated-length index))
-                (when (>= index allocated-length)
-                  (setq allocated-length (* allocated-length 2)
-                        result (adjust-array result allocated-length)))
-                (setf (aref result index)
-                      (apply function row))))
-       (database-dump-result-set result-set database)))))
+    (let ((flatp (and (= columns 1) 
+                      (typecase query-expression 
+                        (string t) 
+                        (sql-query
+                         (slot-value query-expression 'flatp))))))
+      (when result-set
+        (unwind-protect
+             (if rows
+                 ;; We know the row count in advance, so we allocate once
+                 (do ((result
+                       (cmucl-compat:make-sequence-of-type output-type-spec rows))
+                      (row (make-list columns))
+                      (index 0 (1+ index)))
+                     ((not (database-store-next-row result-set database row))
+                      result)
+                   (declare (fixnum index))
+                   (setf (aref result index)
+                         (if flatp 
+                             (apply function row)
+                             (funcall function (copy-list row)))))
+                 ;; Database can't report row count in advance, so we have
+                 ;; to grow and shrink our vector dynamically
+                 (do ((result
+                       (cmucl-compat:make-sequence-of-type output-type-spec 100))
+                      (allocated-length 100)
+                      (row (make-list columns))
+                      (index 0 (1+ index)))
+                     ((not (database-store-next-row result-set database row))
+                      (cmucl-compat:shrink-vector result index))
+                   (declare (fixnum allocated-length index))
+                   (when (>= index allocated-length)
+                     (setq allocated-length (* allocated-length 2)
+                           result (adjust-array result allocated-length)))
+                   (setf (aref result index)
+                         (if flatp 
+                             (apply function row)
+                             (funcall function (copy-list row))))))
+          (database-dump-result-set result-set database))))))
 
 ;;; Row processing macro from CLSQL