fix ODBC numeric/decimal param precision and scale

closes PR 14171

But wasn't able to get numeric/decimal working on "SQL Server" driver,
only "SQL Server Native Client" driver.

pkgs/db-pkgs/db-doc/db/scribblings/notes.scrbl

@@ -257,5 +257,10 @@ Maybe Oracle bug? See:
 
 @subsection{SQL Server ODBC Driver}
 
-Basic SQL Server support has been verified on Windows (32-bit only),
+Basic SQL Server support has been verified on Windows,
 but the automated test suite has not yet been adapted and run.
+
+The ``SQL Server'' driver refuses to accept @tt{NUMERIC} or
+@tt{DECIMAL} parameters, producing the error ``Invalid precision value
+(SQLSTATE: HY104).'' If possible, use the ``Native SQL Server''
+driver instead.

pkgs/db-pkgs/db-lib/db/private/odbc/connection.rkt

@@ -101,20 +101,21 @@
                   (load-param fsym db stmt i param param-typeid))])
           (handle-status fsym (SQLExecute stmt) stmt)
           (strong-void param-bufs))
-        (let* ([result-dvecs (send pst get-result-dvecs)]
+        (define result-dvecs (send pst get-result-dvecs))
-               [rows
+        (set-result-descriptors stmt result-dvecs)
-                (and (not cursor?)
+        (define rows
-                     (pair? result-dvecs)
+          (and (not cursor?)
-                     (fetch* fsym stmt (map field-dvec->typeid result-dvecs) #f +inf.0))])
+               (pair? result-dvecs)
-          (unless cursor? (send pst after-exec #f))
+               (fetch* fsym stmt (map field-dvec->typeid result-dvecs) #f +inf.0)))
-          (cond [(and (pair? result-dvecs) (not cursor?))
+        (unless cursor? (send pst after-exec #f))
-                 (rows-result (map field-dvec->field-info result-dvecs) rows)]
+        (cond [(and (pair? result-dvecs) (not cursor?))
-                [(and (pair? result-dvecs) cursor?)
+               (rows-result (map field-dvec->field-info result-dvecs) rows)]
-                 (cursor-result (map field-dvec->field-info result-dvecs)
+              [(and (pair? result-dvecs) cursor?)
-                                pst
+               (cursor-result (map field-dvec->field-info result-dvecs)
-                                (list (map field-dvec->typeid result-dvecs)
+                              pst
-                                      (box #f)))]
+                              (list (map field-dvec->typeid result-dvecs)
-                [else (simple-result '())]))))
+                                    (box #f)))]
+              [else (simple-result '())])))
 
     (define/public (fetch/cursor fsym cursor fetch-size)
       (let ([pst (cursor-result-pst cursor)]
@@ -133,11 +134,11 @@
     (define/private (load-param fsym db stmt i param typeid)
       ;; NOTE: param buffers must not move between bind and execute
       ;; So use buffer utils from ffi.rkt (copy-buffer, etc)
-      (define (bind ctype sqltype buf)
+      (define (bind ctype sqltype buf [prec 0] [scale 0])
         (let* ([lenbuf
                 (int->buffer (if buf (bytes-length buf) SQL_NULL_DATA))]
                [status
-                (SQLBindParameter stmt i SQL_PARAM_INPUT ctype sqltype 0 0 buf lenbuf)])
+                (SQLBindParameter stmt i SQL_PARAM_INPUT ctype sqltype prec scale buf lenbuf)])
           (handle-status fsym status stmt)
           (if buf (cons buf lenbuf) lenbuf)))
       ;; If the typeid is UNKNOWN, then choose appropriate type based on data,
@@ -160,22 +161,29 @@
              (bind SQL_C_BINARY (if unknown-type? SQL_BINARY typeid)
                    (copy-buffer param))]
             [(pair? param) ;; Represents numeric/decimal decomposed as scaled integer
-             (bind SQL_C_NUMERIC typeid
+             (let* ([ma (car param)]
-                   (copy-buffer
+                    [ex (cdr param)]
-                    (let ([ma (car param)]
+                    ;; ODBC docs claim max precision is 15 ...
-                          [ex (cdr param)])
+                    [prec-byte (if (zero? ma) 1 (+ 1 (order-of-magnitude (abs ma))))]
-                      (apply bytes-append
+                    [sign-byte (if (negative? ma) 0 1)] ;; FIXME: negative is 2 in ODBC 3.5 ???
-                             ;; ODBC docs claim max precision is 15 ...
+                    [digits-bytess
-                             (bytes (if (zero? ma) 1 (+ 1 (order-of-magnitude (abs ma))))
+                     ;; 16 bytes of unsigned little-endian data (4 chunks of 4 bytes)
-                                    ex
+                     (let loop ([i 0] [ma (abs ma)])
-                                    (if (negative? ma) 0 1))
+                       (if (< i 4)
-                             ;; 16 bytes of unsigned little-endian data (4 chunks of 4 bytes)
+                           (let-values ([(q r) (quotient/remainder ma (expt 2 32))])
-                             (let loop ([i 0] [ma (abs ma)])
+                             (cons (integer->integer-bytes r 4 #f #f)
-                               (if (< i 4)
+                                   (loop (add1 i) q)))
-                                   (let-values ([(q r) (quotient/remainder ma (expt 2 32))])
+                           null))]
-                                     (cons (integer->integer-bytes r 4 #f #f)
+                    [numeric-bytes
-                                           (loop (add1 i) q)))
+                     (apply bytes-append (bytes prec-byte ex sign-byte) digits-bytess)]
-                                   null))))))]
+                    [numeric-buffer (copy-buffer numeric-bytes)])
+               ;; Example: http://support.microsoft.com/kb/181254
+               ;; and: http://msdn.microsoft.com/en-us/library/ms712567%28v=vs.85%29.aspx
+               ;; Call bind first.
+               (bind SQL_C_NUMERIC typeid numeric-buffer prec-byte ex)
+               ;; Then set descriptor attributes.
+               (set-numeric-descriptors (SQLGetStmtAttr/HDesc stmt SQL_ATTR_APP_PARAM_DESC)
+                                        i prec-byte ex numeric-buffer))]
             [(real? param)
              (cond [(or (= typeid SQL_NUMERIC) (= typeid SQL_DECIMAL))
                     (bind SQL_C_CHAR typeid
@@ -239,6 +247,24 @@
                                    '("given" value) param
                                    "typeid" typeid)]))
 
+    (define/private (set-result-descriptors stmt dvecs)
+      (for ([i (in-naturals 1)]
+            [dvec (in-list dvecs)])
+        (define typeid (field-dvec->typeid dvec))
+        (cond [(or (= typeid SQL_DECIMAL)
+                   (= typeid SQL_NUMERIC))
+               (define hdesc (SQLGetStmtAttr/HDesc stmt SQL_ATTR_APP_ROW_DESC))
+               (define size (field-dvec->size dvec))
+               (define digits (field-dvec->digits dvec))
+               (set-numeric-descriptors hdesc i size digits #f)]
+              [else (void)])))
+
+    (define/private (set-numeric-descriptors hdesc i prec ex buf)
+      (SQLSetDescField/Int hdesc i SQL_DESC_TYPE SQL_C_NUMERIC)
+      (SQLSetDescField/Int hdesc i SQL_DESC_PRECISION prec)
+      (SQLSetDescField/Int hdesc i SQL_DESC_SCALE ex)
+      (when buf (SQLSetDescField/Ptr hdesc i SQL_DESC_DATA_PTR buf (bytes-length buf))))
+
     (define/private (fetch* fsym stmt result-typeids end-box limit)
       ;; scratchbuf: create a single buffer here to try to reduce garbage
       ;; Don't make too big; otherwise bad for queries with only small data.
@@ -381,7 +407,7 @@
              (get-string)]
             [(or (= typeid SQL_DECIMAL)
                  (= typeid SQL_NUMERIC))
-             (let ([fields (get-int-list '(1 1 1 4 4 4 4) SQL_C_NUMERIC)])
+             (let ([fields (get-int-list '(1 1 1 4 4 4 4) SQL_ARD_TYPE)])
                (cond [(list? fields)
                       (let* ([precision (first fields)]
                              [scale (second fields)]

pkgs/db-pkgs/db-lib/db/private/odbc/dbsystem.rkt

@@ -7,6 +7,8 @@
 (provide dbsystem
          field-dvec->field-info
          field-dvec->typeid
+         field-dvec->size
+         field-dvec->digits
          supported-typeid?
          classify-odbc-sql)
 
@@ -44,6 +46,10 @@
 
 (define (field-dvec->typeid dvec)
   (vector-ref dvec 1))
+(define (field-dvec->size dvec)
+  (vector-ref dvec 2))
+(define (field-dvec->digits dvec)
+  (vector-ref dvec 3))
 
 ;; ----
 

pkgs/db-pkgs/db-lib/db/private/odbc/ffi-constants.rkt

@@ -129,6 +129,7 @@
 (define SQL_C_DOUBLE              SQL_DOUBLE)
 (define SQL_C_NUMERIC             SQL_NUMERIC)
 (define SQL_C_DEFAULT             99)
+(define SQL_ARD_TYPE              -99)
 
 (define SQL_C_DATE                SQL_DATE)
 (define SQL_C_TIME                SQL_TIME)
@@ -196,3 +197,10 @@
 (define SQL_TXN_SERIALIZABLE     #x8)
 
 (define SQL_DBMS_NAME 17)
+
+(define SQL_ATTR_APP_PARAM_DESC 10011)
+(define SQL_ATTR_APP_ROW_DESC 10010)
+(define SQL_DESC_TYPE 1002)
+(define SQL_DESC_PRECISION 1005)
+(define SQL_DESC_SCALE 1006)
+(define SQL_DESC_DATA_PTR 1010)

pkgs/db-pkgs/db-lib/db/private/odbc/ffi.rkt

@@ -10,6 +10,7 @@
 (define-cpointer-type _sqlhenv)
 (define-cpointer-type _sqlhdbc)
 (define-cpointer-type _sqlhstmt)
+(define-cpointer-type _sqlhdesc)
 
 (define _sqllen _long)
 (define _sqlulen _ulong)
@@ -316,7 +317,7 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
         (handle : _sqlhstmt)
         (column : _sqlusmallint)
         (column-buf : _bytes)
-        ((bytes-length column-buf) : _sqlsmallint)
+        (_sqlsmallint = (if column-buf (bytes-length column-buf) 0))
         (column-len : (_ptr o _sqlsmallint))
         (data-type : (_ptr o _sqlsmallint))
         (size : (_ptr o _sqlulen))
@@ -325,6 +326,7 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
         -> (status : _sqlreturn)
         -> (values status
                    (and (ok-status? status)
+                        column-buf
                         (bytes->string/utf-8 column-buf #f 0 column-len))
                    data-type size digits nullable)))
 
@@ -343,6 +345,37 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx
         -> (status : _sqlreturn)
         -> (values status len-or-ind)))
 
+(define-odbc SQLGetStmtAttr/HDesc
+  (_fun (handle attr) ::
+        (handle : _sqlhstmt)
+        (attr :   _sqlinteger)
+        (valptr : (_ptr o _sqlhdesc))
+        (buflen : _sqlinteger = 0)
+        (strlen : _pointer = #f)
+        -> (status : _sqlreturn)
+        -> (and (ok-status? status) valptr))
+  #:c-id SQLGetStmtAttr)
+
+(define-odbc SQLSetDescField/Int
+  (_fun (handle recno fieldid intval) ::
+        (handle  : _sqlhdesc)
+        (recno   : _sqlsmallint)
+        (fieldid : _sqlsmallint)
+        (intval  : _intptr)  ;; declared SQLPOINTER; cast
+        (buflen : _sqlinteger = 0)
+        -> (status : _sqlreturn))
+  #:c-id SQLSetDescField)
+
+(define-odbc SQLSetDescField/Ptr
+  (_fun (handle recno fieldid ptrval buflen) ::
+        (handle  : _sqlhdesc)
+        (recno   : _sqlsmallint)
+        (fieldid : _sqlsmallint)
+        (ptrval  : _pointer)  ;; declared SQLPOINTER; cast
+        (buflen : _sqlinteger)
+        -> (status : _sqlreturn))
+  #:c-id SQLSetDescField)
+
 (define-odbc SQLFreeStmt
   (_fun (handle : _sqlhstmt)
         (option : _sqlusmallint)