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"