diff --git a/freetds.scm b/freetds.scm
index 84b8282..4bab47c 100644
--- a/freetds.scm
+++ b/freetds.scm
@@ -22,7 +22,9 @@ with the FreeTDS egg. If not, see .
(module
freetds
(make-connection connection? connection-open? connection-close connection-reset!
- send-query send-query* result? result-cleanup! row-fetch result-values
+ send-query send-query* result? result-cleanup!
+ row-fetch row-fetch/alist result-values result-values/alist
+ column-name column-names
call-with-result-set
;; if we don't export varchar-string, there are compilation errors!
varchar-string
@@ -1019,6 +1021,16 @@ with the FreeTDS egg. If not, see .
'ct_bind
"failed to bind result value"))
+ (define (name-from-data-format data-format*)
+ (let* ((len (data-format-name-length data-format*))
+ (str (make-string len)))
+ (let lp ((idx 0))
+ (if (= idx len)
+ (string->symbol str)
+ (begin
+ (string-set! str idx (data-format-name data-format* idx))
+ (lp (add1 idx)))))))
+
(define (make-bound-variables connection* command*)
(let-values (((retcode column-count) (results-info-column-count! command*)))
(list-tabulate
@@ -1054,10 +1066,11 @@ with the FreeTDS egg. If not, see .
(/ (data-format-max-length data-format*)
type-size))))
(value* (make-type* length))
- (indicator* (make-CS_SMALLINT* 1)))
+ (indicator* (make-CS_SMALLINT* 1))
+ (name (name-from-data-format data-format*)))
(if (bind! connection* command* (+ column 1)
data-format* value* indicator*)
- (cons* value* indicator* translate-type* length))))))))))
+ (cons* value* indicator* translate-type* length name))))))))))
;; Currently this assumes a command can only return one result
;; (actually, it returns only the first)
@@ -1121,12 +1134,24 @@ with the FreeTDS egg. If not, see .
(location retcode))))
(values rows-read retcode))))
+ (define (column-name result idx)
+ (match-let (((value indicator translate-type* length . name)
+ (list-ref (freetds-result-bound-vars result) idx)))
+ name))
+
+ (define (column-names result)
+ (map (lambda (bound-variable)
+ (match-let (((value indicator translate-type* length . name)
+ bound-variable))
+ name))
+ (freetds-result-bound-vars result)))
+
(define (row-fetch result)
(let-values (((rows-read retcode) (fetch! result)))
(match retcode
((? success? row-fail?)
(map (lambda (bound-variable)
- (match-let (((value indicator translate-type* . length)
+ (match-let (((value indicator translate-type* length . name)
bound-variable))
(if (null-indicator? indicator)
(sql-null)
@@ -1145,6 +1170,12 @@ with the FreeTDS egg. If not, see .
(_
(freetds-error 'row-fetch "fetch! returned unknown retcode" retcode)))))
+ ;; This could be made more efficient by putting it in row-fetch's mapped lambda
+ (define (row-fetch/alist result)
+ (and-let* ((row (row-fetch result))
+ (names (column-names result)))
+ (map cons names row)))
+
(define (result-values result)
(let next ((rows (list)))
(let ((row (row-fetch result)))
@@ -1152,6 +1183,13 @@ with the FreeTDS egg. If not, see .
(reverse! rows)
(next (cons row rows))))))
+ (define (result-values/alist result)
+ (let next ((rows (list)))
+ (let ((row (row-fetch/alist result)))
+ (if (not row)
+ (reverse! rows)
+ (next (cons row rows))))))
+
(define (call-with-result-set connection query . rest-args)
;; TODO: This is not too efficient
(receive (params last)
diff --git a/tests/run.scm b/tests/run.scm
index c6772b8..de1f502 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -22,19 +22,41 @@
(define connection (make-connection server username password))
(test-group "low-level query & results interface"
- (let ((res (send-query connection "SELECT 1, 2, 3 UNION SELECT 4, 5, 6")))
+ (let ((res (send-query connection
+ (conc "SELECT 1 AS one, 2 AS two, 3 AS three"
+ " UNION "
+ "SELECT 4, 5, 6"))))
(test-assert "send-query returns result object"
(result? res))
+ (test "Column name can be obtained"
+ 'one
+ (column-name res 0))
+ (test "All column names can be obtained"
+ '(one two three)
+ (column-names res))
(test "First row-fetch returns one row"
'(1 2 3)
(row-fetch res))
- (test "Second row-fetch returns another row"
- '(4 5 6)
- (row-fetch res))
+ (test "Second row-fetch returns another row (alist)"
+ '((one . 4) (two . 5) (three . 6))
+ (row-fetch/alist res))
(test-assert "Final row-fetch returns #f"
(not (row-fetch res)))
(test-assert "Cleaning up the result gives no problems"
(result-cleanup! res)))
+ (test "result-values retrieves all values"
+ '((1 2 3) (4 5 6))
+ (result-values
+ (send-query connection (conc "SELECT 1 AS one, 2 AS two, 3 AS three"
+ " UNION "
+ "SELECT 4, 5, 6"))))
+ (test "result-values/alist retrieves all values as alist"
+ '(((one . 1) (two . 2) (three . 3))
+ ((one . 4) (two . 5) (three . 6)))
+ (result-values/alist
+ (send-query connection (conc "SELECT 1 AS one, 2 AS two, 3 AS three"
+ " UNION "
+ "SELECT 4, 5, 6"))))
;; TODO: Maybe we should always fetch the entire result so this doesn't
;; have to be a problem
(test-error "Querying before reading out the previous result gives error"