Automated commit for debian release 6.7.2-1

[clsql.git] / sql / fdml.lisp

diff --git a/sql/fdml.lisp b/sql/fdml.lisp
index 7c8ae7b2c20237ae22ad9b53be17394a2f961d86..5e248ced0547c0eb66895d820493023b4f032f7b 100644 (file)
--- a/sql/fdml.lisp
+++ b/sql/fdml.lisp
@@ -1,9 +1,7 @@
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;;
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;;

-;;;; $Id$
-;;;;
-;;;; The CLSQL Functional Data Manipulation Language (FDML). 
+;;;; The CLSQL Functional Data Manipulation Language (FDML).

 ;;;;
 ;;;; This file is part of CLSQL.
 ;;;;
 ;;;;
 ;;;; This file is part of CLSQL.
 ;;;;


@@ -13,7 +11,34 @@
 ;;;; *************************************************************************
 
 (in-package #:clsql-sys)
 ;;;; *************************************************************************
 
 (in-package #:clsql-sys)

-  
+
+;; some helpers to make dealing with attribute-value-pairs a bit more structured
+(defclass attribute-value-pair ()
+  ((attribute :accessor attribute :initarg :attribute :initform nil)
+   (db-value :accessor db-value :initarg :db-value :initform nil))
+  (:documentation "Represents an attribute-sql-expression and its value, used
+   to pass to insert/update. Was previously a two list"))
+
+(defun make-attribute-value-pair (slot-def value database)
+  (check-slot-type slot-def value)
+  (make-instance
+   'attribute-value-pair
+   :attribute (sql-expression :attribute (database-identifier slot-def database))
+   :db-value (db-value-from-slot slot-def value database)))
+
+(defun to-attributes-and-values (av-pairs)
+  (etypecase (first av-pairs)
+    (list
+     (loop for (a v) in av-pairs
+           collect a into attributes
+           collect v into db-values
+           finally (return (values attributes db-values))))
+    (attribute-value-pair
+     (loop for pair in av-pairs
+           collecting (attribute pair) into attributes
+           collecting (db-value pair) into db-values
+           finally (return (values attributes db-values))))))
+

 ;;; Basic operations on databases
 
 (defmethod database-query-result-set ((expr %sql-expression) database
 ;;; Basic operations on databases
 
 (defmethod database-query-result-set ((expr %sql-expression) database


@@ -36,15 +61,15 @@
 (defmethod query ((query-expression string) &key (database *default-database*)
                   (result-types :auto) (flatp nil) (field-names t))
   (record-sql-command query-expression database)
 (defmethod query ((query-expression string) &key (database *default-database*)
                   (result-types :auto) (flatp nil) (field-names t))
   (record-sql-command query-expression database)

-  (multiple-value-bind (rows names) 
+  (multiple-value-bind (rows names)

       (database-query query-expression database result-types field-names)
     (let ((result (if (and flatp (= 1 (length (car rows))))
                       (mapcar #'car rows)
                     rows)))
       (record-sql-result result database)
       (if field-names
       (database-query query-expression database result-types field-names)
     (let ((result (if (and flatp (= 1 (length (car rows))))
                       (mapcar #'car rows)
                     rows)))
       (record-sql-result result database)
       (if field-names

-         (values result names)
-       result))))
+          (values result names)
+        result))))

 
 (defmethod query ((expr %sql-expression) &key (database *default-database*)
                   (result-types :auto) (flatp nil) (field-names t))
 
 (defmethod query ((expr %sql-expression) &key (database *default-database*)
                   (result-types :auto) (flatp nil) (field-names t))


@@ -52,37 +77,19 @@
          :result-types result-types :field-names field-names))
 
 (defmethod query ((expr sql-object-query) &key (database *default-database*)
          :result-types result-types :field-names field-names))
 
 (defmethod query ((expr sql-object-query) &key (database *default-database*)

-                 (result-types :auto) (flatp nil) (field-names t))
+                  (result-types :auto) (flatp nil) (field-names t))

   (declare (ignore result-types field-names))
   (apply #'select (append (slot-value expr 'objects)
   (declare (ignore result-types field-names))
   (apply #'select (append (slot-value expr 'objects)

-                         (slot-value expr 'exp) 
-                         (when (slot-value expr 'refresh) 
-                           (list :refresh (sql-output expr database)))
-                         (when (or flatp (slot-value expr 'flatp) )
-                           (list :flatp t))
-                         (list :database database))))
-
-(defun truncate-database (&key (database *default-database*))
-  (unless (typep database 'database)
-    (signal-no-database-error database))
-  (unless (is-database-open database)
-    (database-reconnect database))
-  (when (eq :oracle (database-type database))
-    (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database)))
-  (when (db-type-has-views? (database-underlying-type database))
-    (dolist (view (list-views :database database))
-      (drop-view view :database database)))
-  (dolist (table (list-tables :database database))
-    (drop-table table :database database))
-  (dolist (index (list-indexes :database database))
-    (drop-index index :database database))
-  (dolist (seq (list-sequences :database database))
-    (drop-sequence seq :database database))
-  (when (eq :oracle (database-type database))
-    (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database))))
+                          (slot-value expr 'exp)
+                          (when (slot-value expr 'refresh)
+                            (list :refresh (sql-output expr database)))
+                          (when (or flatp (slot-value expr 'flatp) )
+                            (list :flatp t))
+                          (list :database database))))
+

 
 (defun print-query (query-exp &key titles (formats t) (sizes t) (stream t)
 
 (defun print-query (query-exp &key titles (formats t) (sizes t) (stream t)

-                             (database *default-database*))
+                              (database *default-database*))

   "Prints a tabular report of the results returned by the SQL
 query QUERY-EXP, which may be a symbolic SQL expression or a
 string, in DATABASE which defaults to *DEFAULT-DATABASE*. The
   "Prints a tabular report of the results returned by the SQL
 query QUERY-EXP, which may be a symbolic SQL expression or a
 string, in DATABASE which defaults to *DEFAULT-DATABASE*. The


@@ -98,8 +105,8 @@ selected by QUERY-EXP. The default value of FORMATS is t meaning
 that ~A is used to format all columns or ~VA if column sizes are
 used."
   (flet ((compute-sizes (data)
 that ~A is used to format all columns or ~VA if column sizes are
 used."
   (flet ((compute-sizes (data)

-           (mapcar #'(lambda (x) 
-                       (apply #'max (mapcar #'(lambda (y) 
+           (mapcar #'(lambda (x)
+                       (apply #'max (mapcar #'(lambda (y)

                                                 (if (null y) 3 (length y)))
                                             x)))
                    (apply #'mapcar (cons #'list data))))
                                                 (if (null y) 3 (length y)))
                                             x)))
                    (apply #'mapcar (cons #'list data))))


@@ -110,9 +117,9 @@ used."
     (let* ((query-exp (etypecase query-exp
                         (string query-exp)
                         (sql-query (sql-output query-exp database))))
     (let* ((query-exp (etypecase query-exp
                         (string query-exp)
                         (sql-query (sql-output query-exp database))))

-           (data (query query-exp :database database :result-types nil 
+           (data (query query-exp :database database :result-types nil

                         :field-names nil))
                         :field-names nil))

-           (sizes (if (or (null sizes) (listp sizes)) sizes 
+           (sizes (if (or (null sizes) (listp sizes)) sizes

                       (compute-sizes (if titles (cons titles data) data))))
            (formats (if (or (null formats) (not (listp formats)))
                         (make-list (length (car data)) :initial-element
                       (compute-sizes (if titles (cons titles data) data))))
            (formats (if (or (null formats) (not (listp formats)))
                         (make-list (length (car data)) :initial-element


@@ -123,218 +130,107 @@ used."
       (dolist (d data (values)) (format-record d control-string sizes)))))
 
 (defun insert-records (&key (into nil)
       (dolist (d data (values)) (format-record d control-string sizes)))))
 
 (defun insert-records (&key (into nil)

-                           (attributes nil)
-                           (values nil)
-                           (av-pairs nil)
-                           (query nil)
-                           (database *default-database*))
+                            (attributes nil)
+                            (values nil)
+                            (av-pairs nil)
+                            (query nil)
+                            (database *default-database*))

   "Inserts records into the table specified by INTO in DATABASE
 which defaults to *DEFAULT-DATABASE*. There are five ways of
   "Inserts records into the table specified by INTO in DATABASE
 which defaults to *DEFAULT-DATABASE*. There are five ways of

-specifying the values inserted into each row. In the first VALUES
-contains a list of values to insert and ATTRIBUTES, AV-PAIRS and
-QUERY are nil. This can be used when values are supplied for all
-attributes in INTO. In the second, ATTRIBUTES is a list of column
-names, VALUES is a corresponding list of values and AV-PAIRS and
-QUERY are nil. In the third, ATTRIBUTES, VALUES and QUERY are nil
-and AV-PAIRS is an alist of (attribute value) pairs. In the
-fourth, VALUES, AV-PAIRS and ATTRIBUTES are nil and QUERY is a
-symbolic SQL query expression in which the selected columns also
-exist in INTO. In the fifth method, VALUES and AV-PAIRS are nil
-and ATTRIBUTES is a list of column names and QUERY is a symbolic
-SQL query expression which returns values for the specified
-columns."
+specifying the values inserted into each row.
+
+In the first VALUES contains a list of values to insert and ATTRIBUTES,
+AV-PAIRS and QUERY are nil. This can be used when values are supplied for all
+attributes in INTO.
+
+In the second, ATTRIBUTES is a list of column names, VALUES is a corresponding
+list of values and AV-PAIRS and QUERY are nil.
+
+In the third, ATTRIBUTES, VALUES and QUERY are nil and AV-PAIRS is a list
+of (attribute value) pairs, or attribute-value-pair objects.
+
+In the fourth, VALUES, AV-PAIRS and ATTRIBUTES are nil and QUERY is a symbolic
+SQL query expression in which the selected columns also exist in INTO.
+
+In the fifth method, VALUES and AV-PAIRS are nil and ATTRIBUTES is a list of
+column names and QUERY is a symbolic SQL query expression which returns values
+for the specified columns."

   (let ((stmt (make-sql-insert :into into :attrs attributes
   (let ((stmt (make-sql-insert :into into :attrs attributes

-                              :vals values :av-pairs av-pairs
-                              :subquery query)))
+                               :vals values :av-pairs av-pairs
+                               :subquery query)))

     (execute-command stmt :database database)))
 
 (defun make-sql-insert (&key (into nil)
     (execute-command stmt :database database)))
 
 (defun make-sql-insert (&key (into nil)

-                           (attrs nil)
-                           (vals nil)
-                           (av-pairs nil)
-                           (subquery nil))
+                        (attrs nil)
+                        (vals nil)
+                        (av-pairs nil)
+                        (subquery nil))

   (unless into
   (unless into

-      (error 'sql-user-error :message ":into keyword not supplied"))
-  (let ((insert (make-instance 'sql-insert :into into)))
-    (with-slots (attributes values query)
-      insert
+    (error 'sql-user-error :message ":into keyword not supplied"))
+  (let ((insert (make-instance 'sql-insert :into (database-identifier into nil))))
+    (with-slots (attributes values query) insert
+

       (cond ((and vals (not attrs) (not query) (not av-pairs))
       (cond ((and vals (not attrs) (not query) (not av-pairs))

-            (setf values vals))
-           ((and vals attrs (not subquery) (not av-pairs))
-            (setf attributes attrs)
-            (setf values vals))
-           ((and av-pairs (not vals) (not attrs) (not subquery))
-            (setf attributes (mapcar #'car av-pairs))
-            (setf values (mapcar #'cadr av-pairs)))
-           ((and subquery (not vals) (not attrs) (not av-pairs))
-            (setf query subquery))
-           ((and subquery attrs (not vals) (not av-pairs))
-            (setf attributes attrs)
-            (setf query subquery))
-           (t
-            (error 'sql-user-error
-                    :message "bad or ambiguous keyword combination.")))
+             (setf values vals))
+
+            ((and vals attrs (not subquery) (not av-pairs))
+             (setf attributes attrs)
+             (setf values vals))
+
+            ((and av-pairs (not vals) (not attrs) (not subquery))
+             (multiple-value-setq (attributes values)
+               (to-attributes-and-values av-pairs)))
+
+            ((and subquery (not vals) (not attrs) (not av-pairs))
+             (setf query subquery))
+
+            ((and subquery attrs (not vals) (not av-pairs))
+             (setf attributes attrs)
+             (setf query subquery))
+
+            (t (error 'sql-user-error
+                      :message "bad or ambiguous keyword combination.")))

       insert)))
       insert)))

-    
+

 (defun delete-records (&key (from nil)
                             (where nil)
                             (database *default-database*))
   "Deletes records satisfying the SQL expression WHERE from the
 table specified by FROM in DATABASE specifies a database which
 defaults to *DEFAULT-DATABASE*."
 (defun delete-records (&key (from nil)
                             (where nil)
                             (database *default-database*))
   "Deletes records satisfying the SQL expression WHERE from the
 table specified by FROM in DATABASE specifies a database which
 defaults to *DEFAULT-DATABASE*."

-  (let ((stmt (make-instance 'sql-delete :from from :where where)))
+  (let ((stmt (make-instance 'sql-delete :from (database-identifier from database) :where where)))

     (execute-command stmt :database database)))
 
 (defun update-records (table &key (attributes nil)
     (execute-command stmt :database database)))
 
 (defun update-records (table &key (attributes nil)

-                           (values nil)
-                           (av-pairs nil)
-                           (where nil)
-                           (database *default-database*))
+                            (values nil)
+                            (av-pairs nil)
+                            (where nil)
+                            (database *default-database*))

   "Updates the attribute values of existing records satsifying
 the SQL expression WHERE in the table specified by TABLE in
 DATABASE which defaults to *DEFAULT-DATABASE*. There are three
 ways of specifying the values to update for each row. In the
 first, VALUES contains a list of values to use in the update and
   "Updates the attribute values of existing records satsifying
 the SQL expression WHERE in the table specified by TABLE in
 DATABASE which defaults to *DEFAULT-DATABASE*. There are three
 ways of specifying the values to update for each row. In the
 first, VALUES contains a list of values to use in the update and

-ATTRIBUTES, AV-PAIRS and QUERY are nil. This can be used when
-values are supplied for all attributes in TABLE. In the second,
-ATTRIBUTES is a list of column names, VALUES is a corresponding
-list of values and AV-PAIRS and QUERY are nil. In the third,
-ATTRIBUTES, VALUES and QUERY are nil and AV-PAIRS is an alist
-of (attribute value) pairs."
+ATTRIBUTES and AV-PAIRS are nil. This can be used when values are
+supplied for all attributes in TABLE. In the second, ATTRIBUTES
+is a list of column names, VALUES is a corresponding list of
+values and AV-PAIRS is nil. In the third, ATTRIBUTES and VALUES
+are nil and AV-PAIRS is an alist of (attribute value) pairs."

   (when av-pairs
   (when av-pairs

-    (setf attributes (mapcar #'car av-pairs)
-          values (mapcar #'cadr av-pairs)))
-  (let ((stmt (make-instance 'sql-update :table table
-                            :attributes attributes
-                            :values values
-                            :where where)))
+    (multiple-value-setq (attributes values)
+      (to-attributes-and-values av-pairs)))
+  (let ((stmt (make-instance 'sql-update :table (database-identifier table database)
+                             :attributes attributes
+                             :values values
+                             :where where)))

     (execute-command stmt :database database)))
 
 
     (execute-command stmt :database database)))
 
 

-;; iteration 
-
-;; output-sql
-
-(defmethod database-output-sql ((str string) database)
-  (declare (ignore database)
-           (optimize (speed 3) (safety 1) #+cmu (extensions:inhibit-warnings 3))
-           (type (simple-array * (*)) str))
-  (let ((len (length str)))
-    (declare (type fixnum len))
-    (cond ((= len 0)
-           +empty-string+)
-          ((and (null (position #\' str))
-                (null (position #\\ str)))
-           (concatenate 'string "'" str "'"))
-          (t
-           (let ((buf (make-string (+ (* len 2) 2) :initial-element #\')))
-             (do* ((i 0 (incf i))
-                   (j 1 (incf j)))
-                  ((= i len) (subseq buf 0 (1+ j)))
-               (declare (type integer i j))
-               (let ((char (aref str i)))
-                 (cond ((eql char #\')
-                        (setf (aref buf j) #\\)
-                        (incf j)
-                        (setf (aref buf j) #\'))
-                       ((eql char #\\)
-                        (setf (aref buf j) #\\)
-                        (incf j)
-                        (setf (aref buf j) #\\))
-                       (t
-                        (setf (aref buf j) char))))))))))
-
-(let ((keyword-package (symbol-package :foo)))
-  (defmethod database-output-sql ((sym symbol) database)
-    (convert-to-db-default-case
-     (if (equal (symbol-package sym) keyword-package)
-        (concatenate 'string "'" (string sym) "'")
-        (symbol-name sym))
-     database)))
-
-(defmethod database-output-sql ((tee (eql t)) database)
-  (declare (ignore database))
-  "'Y'")
-
-(defmethod database-output-sql ((num number) database)
-  (declare (ignore database))
-  (princ-to-string num))
-
-(defmethod database-output-sql ((arg list) database)
-  (if (null arg)
-      "NULL"
-      (format nil "(~{~A~^,~})" (mapcar #'(lambda (val)
-                                            (sql-output val database))
-                                        arg))))
-
-(defmethod database-output-sql ((arg vector) database)
-  (format nil "~{~A~^,~}" (map 'list #'(lambda (val)
-                                        (sql-output val database))
-                              arg)))
-
-(defmethod database-output-sql ((self wall-time) database)
-  (declare (ignore database))
-  (db-timestring self))
-
-(defmethod database-output-sql ((self duration) database)
-  (declare (ignore database))
-  (format nil "'~a'" (duration-timestring self)))
-
-(defmethod database-output-sql (thing database)
-  (if (or (null thing)
-         (eq 'null thing))
-      "NULL"
-    (error 'sql-user-error
-           :message
-          (format nil
-                  "No type conversion to SQL for ~A is defined for DB ~A."
-                  (type-of thing) (type-of database)))))
-
-
-(defmethod output-sql-hash-key ((arg vector) database)
-  (list 'vector (map 'list (lambda (arg)
-                             (or (output-sql-hash-key arg database)
-                                 (return-from output-sql-hash-key nil)))
-                     arg)))
-
-(defmethod output-sql (expr database)
-  (write-string (database-output-sql expr database) *sql-stream*)
-  (values))
-
-(defmethod output-sql ((expr list) database)
-  (if (null expr)
-      (write-string +null-string+ *sql-stream*)
-      (progn
-        (write-char #\( *sql-stream*)
-        (do ((item expr (cdr item)))
-            ((null (cdr item))
-             (output-sql (car item) database))
-          (output-sql (car item) database)
-          (write-char #\, *sql-stream*))
-        (write-char #\) *sql-stream*)))
-  t)
-
-(defmethod describe-table ((table sql-create-table)
-                          &key (database *default-database*))
-  (database-describe-table
-   database
-   (convert-to-db-default-case 
-    (symbol-name (slot-value table 'name)) database)))
-
-#+nil
-(defmethod add-storage-class ((self database) (class symbol) &key (sequence t))
-  (let ((tablename (view-table (find-class class))))
-    (unless (tablep tablename)
-      (create-view-from-class class)
-      (when sequence
-        (create-sequence-from-class class)))))
- 

 ;;; Iteration
 
 ;;; Iteration
 

-

 (defmacro do-query (((&rest args) query-expression
 (defmacro do-query (((&rest args) query-expression

-                    &key (database '*default-database*) (result-types :auto))
-                   &body body)
+                     &key (database '*default-database*) (result-types :auto))
+                    &body body)

   "Repeatedly executes BODY within a binding of ARGS on the
 fields of each row selected by the SQL query QUERY-EXPRESSION,
 which may be a string or a symbolic SQL expression, in DATABASE
   "Repeatedly executes BODY within a binding of ARGS on the
 fields of each row selected by the SQL query QUERY-EXPRESSION,
 which may be a string or a symbolic SQL expression, in DATABASE


@@ -345,36 +241,40 @@ QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned
 as strings whereas the default value of :auto means that the lisp
 types are automatically computed for each field."
   (let ((result-set (gensym "RESULT-SET-"))
 as strings whereas the default value of :auto means that the lisp
 types are automatically computed for each field."
   (let ((result-set (gensym "RESULT-SET-"))

-       (qe (gensym "QUERY-EXPRESSION-"))
-       (columns (gensym "COLUMNS-"))
-       (row (gensym "ROW-"))
-       (db (gensym "DB-")))
-    `(let ((,qe ,query-expression))
+        (qe (gensym "QUERY-EXPRESSION-"))
+        (columns (gensym "COLUMNS-"))
+        (row (gensym "ROW-"))
+        (db (gensym "DB-"))
+        (last-form-eval (gensym "LFE-")))
+    `(let ((,qe ,query-expression)
+           (,db ,database))

       (typecase ,qe
       (typecase ,qe

-       (sql-object-query
-         (dolist (,row (query ,qe))
-           (destructuring-bind ,args 
+        (sql-object-query
+         (dolist (,row (query ,qe :database ,db))
+           (destructuring-bind ,args

                ,row
              ,@body)))
                ,row
              ,@body)))

-       (t
-        ;; Functional query 
-        (let ((,db ,database))
-          (multiple-value-bind (,result-set ,columns)
-              (database-query-result-set ,qe ,db
-                                         :full-set nil 
-                                         :result-types ,result-types)
-            (when ,result-set
-              (unwind-protect
-                   (do ((,row (make-list ,columns)))
-                       ((not (database-store-next-row ,result-set ,db ,row))
-                        nil)
-                     (destructuring-bind ,args ,row
-                       ,@body))
-                (database-dump-result-set ,result-set ,db))))))))))
+        (t
+         ;; Functional query
+         (multiple-value-bind (,result-set ,columns)
+             (database-query-result-set ,qe ,db
+                                        :full-set nil
+                                          :result-types ,result-types)
+           (when ,result-set
+             (unwind-protect
+                  (do ((,row (make-list ,columns))
+                       (,last-form-eval nil))
+                      ((not (database-store-next-row ,result-set ,db ,row))
+                       ,last-form-eval)
+                    (destructuring-bind ,args ,row
+                      (setq ,last-form-eval
+                            (progn
+                              ,@body))))
+               (database-dump-result-set ,result-set ,db)))))))))

 
 (defun map-query (output-type-spec function query-expression
 
 (defun map-query (output-type-spec function query-expression

-                 &key (database *default-database*)
-                 (result-types :auto))
+                  &key (database *default-database*)
+                  (result-types :auto))

   "Map the function FUNCTION over the attribute values of each
 row selected by the SQL query QUERY-EXPRESSION, which may be a
 string or a symbolic SQL expression, in DATABASE which defaults
   "Map the function FUNCTION over the attribute values of each
 row selected by the SQL query QUERY-EXPRESSION, which may be a
 string or a symbolic SQL expression, in DATABASE which defaults


@@ -388,35 +288,35 @@ computed for each field."
   (typecase query-expression
     (sql-object-query
      (map output-type-spec #'(lambda (x) (apply function x))
   (typecase query-expression
     (sql-object-query
      (map output-type-spec #'(lambda (x) (apply function x))

-         (query query-expression)))
+          (query query-expression)))

     (t
     (t

-     ;; Functional query 
+     ;; Functional query

      (macrolet ((type-specifier-atom (type)
      (macrolet ((type-specifier-atom (type)

-                 `(if (atom ,type) ,type (car ,type))))
+                  `(if (atom ,type) ,type (car ,type))))

        (case (type-specifier-atom output-type-spec)
        (case (type-specifier-atom output-type-spec)

-        ((nil) 
-         (map-query-for-effect function query-expression database 
-                               result-types))
-        (list 
-         (map-query-to-list function query-expression database result-types))
-        ((simple-vector simple-string vector string array simple-array
-                        bit-vector simple-bit-vector base-string
-                        simple-base-string)
-         (map-query-to-simple output-type-spec function query-expression 
-                              database result-types))
-        (t
-         (funcall #'map-query 
-                  (cmucl-compat:result-type-or-lose output-type-spec t)
-                  function query-expression :database database 
-                  :result-types result-types)))))))
-  
+         ((nil)
+          (map-query-for-effect function query-expression database
+                                result-types))
+         (list
+          (map-query-to-list function query-expression database result-types))
+         ((simple-vector simple-string vector string array simple-array
+                         bit-vector simple-bit-vector base-string
+                         simple-base-string)
+          (map-query-to-simple output-type-spec function query-expression
+                               database result-types))
+         (t
+          (funcall #'map-query
+                   (cmucl-compat:result-type-or-lose output-type-spec t)
+                   function query-expression :database database
+                   :result-types result-types)))))))
+

 (defun map-query-for-effect (function query-expression database result-types)
   (multiple-value-bind (result-set columns)
       (database-query-result-set query-expression database :full-set nil
 (defun map-query-for-effect (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)
-    (let ((flatp (and (= columns 1) 
-                     (typep query-expression 'sql-query)
-                     (slot-value query-expression 'flatp))))
+                                 :result-types result-types)
+    (let ((flatp (and (= columns 1)
+                      (typep query-expression 'sql-query)
+                      (slot-value query-expression 'flatp))))

       (when result-set
         (unwind-protect
              (do ((row (make-list columns)))
       (when result-set
         (unwind-protect
              (do ((row (make-list columns)))


@@ -426,14 +326,14 @@ computed for each field."
                    (apply function row)
                    (funcall function row)))
           (database-dump-result-set result-set database))))))
                    (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
 (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)
-    (let ((flatp (and (= columns 1) 
-                     (typep query-expression 'sql-query)
-                     (slot-value query-expression 'flatp))))
+                                 :result-types result-types)
+    (let ((flatp (and (= columns 1)
+                      (typep query-expression 'sql-query)
+                      (slot-value query-expression 'flatp))))

       (when result-set
         (unwind-protect
              (let ((result (list nil)))
       (when result-set
         (unwind-protect
              (let ((result (list nil)))


@@ -441,8 +341,8 @@ computed for each field."
                     (current-cons result (cdr current-cons)))
                    ((not (database-store-next-row result-set database row))
                     (cdr result))
                     (current-cons result (cdr current-cons)))
                    ((not (database-store-next-row result-set database row))
                     (cdr result))

-                 (rplacd current-cons 
-                         (list (if flatp 
+                 (rplacd current-cons
+                         (list (if flatp

                                    (apply function row)
                                    (funcall function (copy-list row)))))))
           (database-dump-result-set result-set database))))))
                                    (apply function row)
                                    (funcall function (copy-list row)))))))
           (database-dump-result-set result-set database))))))


@@ -450,10 +350,10 @@ computed for each field."
 (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
 (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)
-    (let ((flatp (and (= columns 1) 
-                     (typep query-expression 'sql-query)
-                     (slot-value query-expression 'flatp))))
+                                 :result-types result-types)
+    (let ((flatp (and (= columns 1)
+                      (typep query-expression 'sql-query)
+                      (slot-value query-expression 'flatp))))

       (when result-set
         (unwind-protect
              (if rows
       (when result-set
         (unwind-protect
              (if rows


@@ -466,7 +366,7 @@ computed for each field."
                       result)
                    (declare (fixnum index))
                    (setf (aref result index)
                       result)
                    (declare (fixnum index))
                    (setf (aref result index)

-                         (if flatp 
+                         (if flatp

                              (apply function row)
                              (funcall function (copy-list row)))))
                  ;; Database can't report row count in advance, so we have
                              (apply function row)
                              (funcall function (copy-list row)))))
                  ;; Database can't report row count in advance, so we have


@@ -483,41 +383,42 @@ computed for each field."
                      (setq allocated-length (* allocated-length 2)
                            result (adjust-array result allocated-length)))
                    (setf (aref result index)
                      (setq allocated-length (* allocated-length 2)
                            result (adjust-array result allocated-length)))
                    (setf (aref result index)

-                         (if flatp 
+                         (if flatp

                              (apply function row)
                              (funcall function (copy-list row))))))
           (database-dump-result-set result-set database))))))
 
 ;;; Row processing macro from CLSQL
 
                              (apply function row)
                              (funcall function (copy-list 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)
+(defmacro for-each-row (((&rest fields) &key from order-by where distinct limit)
+                        &body body)

   (let ((d (gensym "DISTINCT-"))
   (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-")))
+        (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)
     `(let ((,frm ,from)

-          (,w ,where)
-          (,d ,distinct)
-          (,l ,limit)
-          (,o ,order-by))
+           (,w ,where)
+           (,d ,distinct)
+           (,l ,limit)
+           (,o ,order-by))

       (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l)))
       (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l)))

-       (loop for tuple in (query ,q)
-             collect (destructuring-bind ,bind-fields tuple
-                  ,@body))))))
+        (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
 
 (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))
+   (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}"
+           (if distinct "distinct " "") (field-names fields)
+           (from-names from))

    (if where (format nil " where ~{~A~^ ~}"
    (if where (format nil " where ~{~A~^ ~}"

-                    (where-strings where)) "")
+                     (where-strings where)) "")

    (if order-by (format nil " order by ~{~A~^, ~}"
    (if order-by (format nil " order by ~{~A~^, ~}"

-                       (order-by-strings order-by)))
+                        (order-by-strings order-by)))

    (if limit (format nil " limit ~D" limit) "")))
 
 (defun lisp->sql-name (field)
    (if limit (format nil " limit ~D" limit) "")))
 
 (defun lisp->sql-name (field)


@@ -530,32 +431,32 @@ computed for each field."
 (defun field-names (field-forms)
   "Return a list of field name strings from a fields form"
   (loop for field-form in field-forms
 (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)))))
+        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)
 
 (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)))
+        collect (lisp->sql-name table)))

 
 
 (defun where-strings (where)
   (loop for w in (if (atom (car where)) (list where) where)
 
 
 (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))))
+        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
 
 (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))))))
+        collect
+        (if (atom o)
+            (lisp->sql-name o)
+            (format nil "~A ~A" (lisp->sql-name (car o))
+                    (lisp->sql-name (cadr o))))))

 
 
 ;;; Large objects support
 
 
 ;;; Large objects support


@@ -588,14 +489,15 @@ A type can be
   :int
   :double
   :null
   :int
   :double
   :null

+  (:blob n)

   (:string n)
 "
   (unless (db-type-has-prepared-stmt? (database-type database))
   (:string n)
 "
   (unless (db-type-has-prepared-stmt? (database-type database))

-    (error 'sql-user-error 
-          :message
-          (format nil
-                  "Database backend type ~:@(~A~) does not support prepared statements."
-                  (database-type database))))
+    (error 'sql-user-error
+           :message
+           (format nil
+                   "Database backend type ~:@(~A~) does not support prepared statements."
+                   (database-type database))))

 
   (database-prepare sql-stmt types database result-types field-names))
 
 
   (database-prepare sql-stmt types database result-types field-names))