- (let (#+ignore(no-data nil))
- (with-slots (column-count column-data-ptrs column-c-types column-sql-types
- column-out-len-ptrs column-precisions hstmt)
- query
- (values
- (cond (flatp
- (when (> column-count 1)
- (error "If more than one column is to be fetched, flatp has to be nil."))
- (let ((data-ptr (aref column-data-ptrs 0))
- (c-type (aref column-c-types 0))
- (sql-type (aref column-sql-types 0))
- (out-len-ptr (aref column-out-len-ptrs 0))
- (precision (aref column-precisions 0)))
- (loop for i from 0
- until (or (and count (= i count))
- ;;(setf no-data ;; not used???
- (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND))
- collect
- (cond ((< 0 precision +max-precision+)
- (read-data data-ptr c-type sql-type out-len-ptr nil))
- ((zerop (get-cast-long out-len-ptr))
- nil)
- (t
- (read-data-in-chunks hstmt 0 data-ptr c-type sql-type
- out-len-ptr nil)))
- #+ignore
- (if (< 0 precision +max-precision+) ;(and precision (< precision +max-precision+))
- (read-data data-ptr c-type sql-type out-len-ptr nil)
- (read-data-in-chunks hstmt 0 data-ptr c-type sql-type
- out-len-ptr nil)))))
- (t
- (loop for i from 0
- until (or (and count (= i count))
- (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND))
- collect
- (loop for data-ptr across column-data-ptrs
- for c-type across column-c-types
- for sql-type across column-sql-types
- for out-len-ptr across column-out-len-ptrs
- for precision across column-precisions
- for j from 0 ; column count is zero based in lisp
- collect
- (cond ((< 0 precision +max-precision+)
- (read-data data-ptr c-type sql-type out-len-ptr nil))
- ((zerop (get-cast-long out-len-ptr))
- nil)
- (t
- (read-data-in-chunks hstmt j data-ptr c-type sql-type
- out-len-ptr nil)))))))
- query)))))
-
-#+lispworks
-(defmacro without-interrupts (&body body)
- `(mp:without-preemption ,@body))
-
-#+allegro
-(defmacro without-interrupts (&body body)
- `(mp:without-scheduling ,@body))
-
-#+cormanlisp
-(defmacro without-interrupts (&body body)
- `(progn ,@body))
-
-#+pcl
-(defmacro without-interrupts (&body body)
- `(pcl::without-interrupts ,@body))
-
-(defmethod db-query ((database odbc-db) query-expression &optional flatp)
- (let ((free-query
- ;; make it thread safe
- (get-free-query database)))
- ;;(format tb::*local-output* "~%new query: ~s" free-query)
+ (with-slots (column-count column-data-ptrs column-c-types column-sql-types
+ column-out-len-ptrs column-precisions hstmt computed-result-types)
+ query
+ (labels
+ ((create-column-fetcher (result-type data-ptr c-type sql-type out-len-ptr precision column-nr)
+ (lambda ()
+ (cond ((< 0 precision (query-width query))
+ (read-data data-ptr c-type sql-type out-len-ptr result-type))
+ ((zerop (get-cast-long out-len-ptr))
+ nil)
+ (t
+ (read-data-in-chunks hstmt column-nr data-ptr c-type sql-type
+ out-len-ptr result-type))))))
+ (let ((fetchers (make-array column-count :fill-pointer 0 :element-type 'function)))
+ ;;; Map across the columns, creating a set of fetch functions
+ (loop for result-type across computed-result-types
+ for data-ptr across column-data-ptrs
+ for c-type across column-c-types
+ for sql-type across column-sql-types
+ for out-len-ptr across column-out-len-ptrs
+ for precision across column-precisions
+ for column-nr from 0 ; column count is zero based in lisp
+ do
+ (vector-push (create-column-fetcher result-type data-ptr c-type sql-type
+ out-len-ptr precision column-nr)
+ fetchers))
+ ;; keep fetching rows until we meet the count parameter,
+ ;; or the %sql-fetch says we're done.
+ (loop for i from 0
+ until (or (and count (= i count))
+ (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND))
+ ;;collect the results of the fetch functions to make a row.
+ collect (map 'list #'funcall fetchers) into rows
+ finally (return (values rows query i))
+ ))))))
+
+(defun db-query (database query-expression &key result-types width)
+ (let ((free-query (get-free-query database)))