Ignore:
Location:
64-bit/src/odbc
Files:
6 edited

Legend:

Unmodified
Added
Removed

  • 64-bit/src/odbc/cffi-support.lisp

    r1 r3  
    88
    99(defun get-string-nts (ptr)
    10   (cffi:foreign-string-to-lisp ptr MOST-POSITIVE-FIXNUM  t))
     10  (cffi:foreign-string-to-lisp ptr MOST-POSITIVE-FIXNUM t))
    1111
    1212(defun put-string (ptr vector)

  • 64-bit/src/odbc/column.lisp

    r1 r8  
    7777              column
    7878            ;(setf value-ptr (cffi:foreign-alloc :long buffer-length))
    79             (setf ind-ptr (cffi:foreign-alloc :long))
     79            (setf ind-ptr (cffi:foreign-alloc 'sql-len))
    8080            (%bind-column hstmt
    8181                          pos
    … …  
    113113
    114114(defmethod get-column-value ((column string-column))
    115   (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))
     115  (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len)))
    116116    (if (= len $SQL_NULL_DATA)
    117       nil
    118       (progn
    119         (get-string (slot-value column 'value-ptr) len)))))
     117        nil
     118        (progn
     119          (get-string (slot-value column 'value-ptr) len)))))
    120120;;;-------------------
    121121;;;   unicode-string
    … …  
    147147
    148148(defmethod get-column-value ((column unicode-string-column))
    149   (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))
     149  (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len)))
    150150    ;; len is size in bytes, not characters!
    151151    (if (= len $SQL_NULL_DATA)
    152       nil
    153       (progn
    154 ;        (break)
    155         (wchar-bytes-to-string (get-byte-vector (slot-value column 'value-ptr) len))))))
     152        nil
     153        (progn
     154          ;; (break)
     155          (wchar-bytes-to-string (get-byte-vector (slot-value column 'value-ptr) len))))))
    156156
    157157
    … …  
    166166  (declare (ignore args))
    167167  (setf (slot-value column 'c-type) $SQL_C_SLONG)
    168   (setf (slot-value column 'buffer-length) 
    169           (cffi:foreign-type-size :long))
    170   (setf (slot-value column 'value-ptr) 
    171           (cffi:foreign-alloc :long)))
     168  (setf (slot-value column 'buffer-length)
     169        (cffi:foreign-type-size 'sql-integer))
     170  (setf (slot-value column 'value-ptr)
     171        (cffi:foreign-alloc 'sql-integer)))
    172172
    173173
    174174(defmethod get-column-value ((column integer-column))
    175   (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))
     175  (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len)))
    176176    (if (= len $SQL_NULL_DATA)
    177       nil
    178       (cffi:mem-ref (slot-value column 'value-ptr) :long))))
     177        nil
     178        (cffi:mem-ref (slot-value column 'value-ptr) 'sql-integer))))
    179179
    180180
    … …  
    193193
    194194(defmethod get-column-value ((column double-column))
    195   ;(%get-long (slot-value column 'ind-ptr))
    196   ;(%get-double-float (slot-value column 'value-ptr))
    197    (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))
    198      (if (= len $SQL_NULL_DATA)
    199        nil
    200        (progn
    201          (cffi:mem-ref (slot-value column 'value-ptr) :double)))))
     195  ;; (%get-long (slot-value column 'ind-ptr))
     196  ;; (%get-double-float (slot-value column 'value-ptr))
     197  (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len)))
     198    (if (= len $SQL_NULL_DATA)
     199        nil
     200        (progn
     201          (cffi:mem-ref (slot-value column 'value-ptr) :double)))))
    202202
    203203;;;------------------------
    … …  
    214214
    215215(defmethod get-column-value ((column date-column))
    216    (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))
     216  (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len)))
    217217    (if (= len $SQL_NULL_DATA)
    218       nil
    219       (funcall *universal-time-to-date-dataype*
    220                (timestamp-to-universal-time (slot-value column 'value-ptr))))))
     218        nil
     219        (funcall *universal-time-to-date-dataype*
     220                 (timestamp-to-universal-time (slot-value column 'value-ptr))))))
    221221
    222222;;;--------------------------
    … …  
    241241
    242242(defmethod get-column-value ((column binary-column))
    243   (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))
     243  (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len)))
    244244    (if (= len $SQL_NULL_DATA)
    245245      nil
    … …  
    260260
    261261(defmethod get-column-value ((column bigint-column))
    262   (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))
    263     (if (= len $SQL_NULL_DATA) 
    264       nil
    265       (parse-integer (get-string (slot-value column 'value-ptr) len)))))
     262  (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len)))
     263    (if (= len $SQL_NULL_DATA)
     264        nil
     265        (parse-integer (get-string (slot-value column 'value-ptr) len)))))
    266266
    267267;;;----------------------------
    … …  
    313313
    314314(defmethod get-column-value ((column decimal-column))
    315   (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long)))
     315  (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len)))
    316316    (if (= len $SQL_NULL_DATA)
    317       nil
    318       (let ((bytes (get-byte-vector (slot-value column 'value-ptr) len))
    319             (sum 0))
    320         (dotimes (i 16)
    321           (setf sum (+ (* 256 sum) (aref bytes (- (+ 3 16) 1 i)))))
    322         (*
    323          sum
    324          (if (zerop (aref bytes 2)) -1 1) ;sign
    325          (expt 10 (- (aref bytes 1))))))))
     317        nil
     318        (let ((bytes (get-byte-vector (slot-value column 'value-ptr) len))
     319              (sum 0))
     320          (dotimes (i 16)
     321            (setf sum (+ (* 256 sum) (aref bytes (- (+ 3 16) 1 i)))))
     322          (*
     323           sum
     324           (if (zerop (aref bytes 2)) -1 1) ;sign
     325           (expt 10 (- (aref bytes 1))))))))
    326326
    327327
    … …  
    341341  (let* ((value-ptr (cffi:foreign-alloc :char
    342342                                        :count (slot-value column 'buffer-length)))
    343          (ind-ptr (cffi:foreign-alloc :long)))
     343         (ind-ptr (cffi:foreign-alloc 'sql-len)))
    344344    (unwind-protect
    345345      (get-character-data
    … …  
    365365(defmethod get-column-value ((column uclob-column))
    366366  (let* ((value-ptr (cffi:foreign-alloc :char :count (slot-value column 'buffer-length)))
    367          (ind-ptr (cffi:foreign-alloc :long)))
     367         (ind-ptr (cffi:foreign-alloc 'sql-len)))
    368368    (unwind-protect
    369369      (get-unicode-character-data
    … …  
    389389(defmethod get-column-value ((column blob-column))
    390390  (let* ((value-ptr (cffi:foreign-alloc  :uchar :count (slot-value column 'buffer-length)))
    391          (ind-ptr (cffi:foreign-alloc :long)))
     391         (ind-ptr (cffi:foreign-alloc 'sql-len)))
    392392    (unwind-protect
    393393      (get-binary-data
    … …  
    423423                                      ind-ptr)))
    424424      (handle-error sqlret)
    425       (let ((len (cffi:mem-ref ind-ptr :long)))
    426         ;(break)
     425      (let ((len (cffi:mem-ref ind-ptr 'sql-len)))
     426        ;;(break)
    427427        (cond
    428428          ((= len $sql_null_data) nil)
    429           ;; character data has a 0 byte appended, the length does not include it
    430           ;; but it is taken into account when placing the data into the buffer
     429          ;; character data has a 0 byte appended, the length does not
     430          ;; include it but it is taken into account when placing the
     431          ;; data into the buffer
    431432          ((and (/= len $SQL_NO_TOTAL)
    432433                (<= (+ 1 len) buffer-length))
    433             ;; the data fits into the buffer, return it
    434             (get-string value-ptr len))
     434           ;; the data fits into the buffer, return it
     435           (get-string value-ptr len))
    435436         
    436437          ;; we have to fetch the data in several steps
    437438          (t
    438             (let ((sos (make-string-output-stream)))
    439               (loop
    440                 (if (and (= sqlret $SQL_SUCCESS_WITH_INFO)
    441                          (equal (sql-state nil nil hstmt)
    442                                 "01004"))
     439           (let ((sos (make-string-output-stream)))
     440             (loop
     441              (if (and (= sqlret $SQL_SUCCESS_WITH_INFO)
     442                       (equal (sql-state nil nil hstmt)
     443                              "01004"))
    443444                  ;; an 0 byte is append to a string, ignore that
    444445                 
    … …  
    446447                    (write-string str sos)
    447448                    (setf sqlret (%sql-get-data-raw hstmt
    448                                             position
    449                                             $SQL_C_CHAR
    450                                             value-ptr
    451                                             buffer-length
    452                                             ind-ptr))
     449                                                    position
     450                                                    $SQL_C_CHAR
     451                                                    value-ptr
     452                                                    buffer-length
     453                                                    ind-ptr))
    453454                    (handle-error sqlret))
    454455                  (return)))
    455               ;; fetch the last part of the data
    456           (setf len (cffi:mem-ref ind-ptr :long))
    457           (let ((str (get-string value-ptr len)))
    458             (write-string str sos))
    459           (get-output-stream-string sos))))))))
     456             ;; fetch the last part of the data
     457             (setf len (cffi:mem-ref ind-ptr 'sql-len))
     458             (let ((str (get-string value-ptr len)))
     459               (write-string str sos))
     460             (get-output-stream-string sos))))))))
    460461
    461462;;; the version for 16bit unicode
    462463
    463 (defun get-unicode-character-data (hstmt position value-ptr buffer-length ind-ptr)
     464(defun get-unicode-character-data (hstmt position value-ptr buffer-length
     465                                   ind-ptr)
    464466  ;; local error handling, we can not use the general error handling
    465467  ;; since this resets the sql-state
    … …  
    481483                                      ind-ptr)))
    482484      (handle-error sqlret)
    483       (let ((len (cffi:mem-ref ind-ptr :long)))
     485      (let ((len (cffi:mem-ref ind-ptr 'sql-len)))
    484486        (cond
    485487          ((= len $sql_null_data) nil)
    486           ;; character data has a 0 byte appended, the length does not include it
    487           ;; but it is taken into account when placing the data into the buffer
     488          ;; character data has a 0 byte appended, the length does not
     489          ;; include it but it is taken into account when placing the
     490          ;; data into the buffer
    488491          ((and (/= len $SQL_NO_TOTAL)
    489492                (<= (+ 2 len) buffer-length))
    490             ;; the data fits into the buffer, return it
    491             (%get-unicode-string value-ptr len))
     493           ;; the data fits into the buffer, return it
     494           (%get-unicode-string value-ptr len))
    492495         
    493496          ;; we have to fetch the data in several steps
    494497          (t
    495             (let ((sos (make-string-output-stream :element-type 'character)))
    496               (loop
    497                 (if (and (= sqlret $SQL_SUCCESS_WITH_INFO)
    498                          (equal (sql-state nil nil hstmt)
    499                                 "01004"))
     498           (let ((sos (make-string-output-stream :element-type 'character)))
     499             (loop
     500              (if (and (= sqlret $SQL_SUCCESS_WITH_INFO)
     501                       (equal (sql-state nil nil hstmt)
     502                              "01004"))
    500503                  ;; an 0 byte is append to a string, ignore that
    501504                 
    502                   (let ((str (%get-unicode-string value-ptr (- buffer-length 2))))
     505                  (let ((str
     506                         (%get-unicode-string value-ptr (- buffer-length 2))))
    503507                    (write-string str sos)
    504508                    (setf sqlret (%sql-get-data-raw hstmt
    505                                             position
    506                                             $SQL_C_WCHAR
    507                                             value-ptr
    508                                             buffer-length
    509                                             ind-ptr))
     509                                                    position
     510                                                    $SQL_C_WCHAR
     511                                                    value-ptr
     512                                                    buffer-length
     513                                                    ind-ptr))
    510514                    (handle-error sqlret))
    511515                  (return)))
    512               ;; fetch the last part of the data
    513           (setf len (cffi:mem-ref ind-ptr :long))
    514           (let ((str (%get-unicode-string value-ptr len)))
    515             (write-string str sos))
    516           (get-output-stream-string sos))))))))
     516             ;; fetch the last part of the data
     517             (setf len (cffi:mem-ref ind-ptr 'sql-len))
     518             (let ((str (%get-unicode-string value-ptr len)))
     519               (write-string str sos))
     520             (get-output-stream-string sos))))))))
    517521   
    518522(defun get-binary-data (hstmt position value-ptr buffer-length ind-ptr)
    … …  
    530534               (error condition)))))
    531535 
    532   (let* ((sqlret (%sql-get-data-raw hstmt
    533                                     position
    534                                     $SQL_C_BINARY
    535                                     value-ptr
    536                                     buffer-length
    537                                     ind-ptr)))
    538     (handle-error sqlret)
    539     (let ((len (cffi:mem-ref ind-ptr :long)))
    540       (if (= len $sql_null_data)
    541         nil
    542         (let ((res (make-array 0 :element-type '(unsigned-byte 8) :adjustable t))
    543               (res-len 0))
    544           (loop
    545             (if (and (= sqlret $SQL_SUCCESS_WITH_INFO)
    546                      (equal (sql-state nil nil hstmt)
    547                           "01004"))
     536    (let* ((sqlret (%sql-get-data-raw hstmt
     537                                      position
     538                                      $SQL_C_BINARY
     539                                      value-ptr
     540                                      buffer-length
     541                                      ind-ptr)))
     542      (handle-error sqlret)
     543      (let ((len (cffi:mem-ref ind-ptr 'sql-len)))
     544        (if (= len $sql_null_data)
     545            nil
     546            (let ((res (make-array 0
     547                                   :element-type '(unsigned-byte 8)
     548                                   :adjustable t))
     549                  (res-len 0))
     550              (loop
     551               (if (and (= sqlret $SQL_SUCCESS_WITH_INFO)
     552                        (equal (sql-state nil nil hstmt)
     553                               "01004"))
    548554           
    549             (let ((vec (get-byte-vector value-ptr buffer-length)))
    550               (setf res (adjust-array res (+ res-len buffer-length)))
    551               (setf (subseq res res-len (+ res-len buffer-length)) vec)
    552               (setf res-len (length res))
    553               (setf sqlret (%sql-get-data-raw hstmt
    554                                               position
    555                                               $SQL_C_BINARY
    556                                               value-ptr
    557                                               buffer-length
    558                                               ind-ptr))
    559               (handle-error sqlret))
    560             (return)))
     555                   (let ((vec (get-byte-vector value-ptr buffer-length)))
     556                     (setf res (adjust-array res (+ res-len buffer-length)))
     557                     (setf (subseq res res-len (+ res-len buffer-length)) vec)
     558                     (setf res-len (length res))
     559                     (setf sqlret (%sql-get-data-raw hstmt
     560                                                     position
     561                                                     $SQL_C_BINARY
     562                                                     value-ptr
     563                                                     buffer-length
     564                                                     ind-ptr))
     565                     (handle-error sqlret))
     566                   (return)))
    561567       
    562         (setf len (cffi:mem-ref ind-ptr :long))
    563         (let ((vec (get-byte-vector value-ptr len)))
    564           (setf res (adjust-array res (+ res-len len)))
    565           (setf (subseq res res-len (+ res-len len)) vec))
    566         res))))))
    567 
     568              (setf len (cffi:mem-ref ind-ptr 'sql-len))
     569              (let ((vec (get-byte-vector value-ptr len)))
     570                (setf res (adjust-array res (+ res-len len)))
     571                (setf (subseq res res-len (+ res-len len)) vec))
     572              res))))))

  • 64-bit/src/odbc/odbc-ff-interface.lisp

    r1 r5  
    1818(load-foreign-library :odbc)
    1919
     20(defctype string-ptr :pointer)
     21
     22
     23
     24;;;; dso-
     25
     26(defctype sql-small-int :int16)
     27(defctype sql-u-small-int :uint16)
     28(defctype sql-integer :int32)
     29(defctype sql-u-integer :uint32)
     30(defctype sql-pointer :pointer)
     31(defctype sql-len sql-integer)
     32(defctype sql-u-len sql-u-integer)
     33(defctype sql-return sql-small-int)
     34
     35(defctype *sql-small-int :pointer)
     36(defctype *sql-integer :pointer)
     37(defctype *sql-len :pointer)
     38(defctype *sql-u-len :pointer)
     39
    2040(defctype sql-handle :pointer)
    21 (defctype *sql-handle :pointer)
    22 (defctype RETCODE :short)
    23 (defctype *short :pointer)
    24 (defctype *sdword :pointer)
    25 (defctype *sword :pointer)
    26 (defctype *ulong :pointer)
    27 
    28 
    29 (defctype string-ptr :pointer)
    30 
    31 
    32 
    33 (defcfun "SQLAllocEnv" retcode (penv *sql-handle))
    34 
    35 (defcfun "SQLAllocConnect" retcode
    36   (henv sql-handle)          ; HENV        henv
    37   (*phdbc *sql-handle))    ; HDBC   FAR *phdbc
    38    
    39 (defcfun "SQLConnect" retcode
    40   (hdbc sql-handle)          ; HDBC        hdbc
    41   (*szDSN string-ptr)        ; UCHAR  FAR *szDSN
    42   (cbDSN :short)             ; SWORD       cbDSN
    43   (*szUID string-ptr)        ; UCHAR  FAR *szUID
    44   (cbUID :short)             ; SWORD       cbUID
    45   (*szAuthStr string-ptr)    ; UCHAR  FAR *szAuthStr
    46   (cbAuthStr :short)         ; SWORD       cbAuthStr
    47   )
     41(defctype sql-h-env sql-handle)
     42(defctype sql-h-dbc sql-handle)
     43(defctype sql-h-stmt sql-handle)
     44(defctype sql-h-wnd :pointer)
     45
     46(defctype *sql-h-env :pointer)
     47(defctype *sql-h-dbc :pointer)
     48(defctype *sql-h-stmt :pointer)
     49
     50(defmacro defsqlfun (name (&rest args))
     51  `(defcfun ,name sql-return ,@args))
     52
     53;;;; -dso
     54
     55
     56
     57(defsqlfun "SQLAllocEnv"
     58    ((penv *sql-h-env)))
     59
     60(defsqlfun "SQLAllocConnect"
     61    ((henv sql-h-env)                   ; HENV        henv
     62     (*phdbc *sql-h-dbc)))              ; HDBC   FAR *phdbc
     63
     64(defsqlfun "SQLDriverConnect"
     65    ((hdbc sql-h-dbc)                   ; HDBC        hdbc
     66     (hwnd sql-h-wnd)                   ; SQLHWND     hwnd
     67                                        ;(*szConnStrIn string-ptr)  ; UCHAR  FAR *szConnStrIn
     68     (*szConnStrIn string-ptr)          ; UCHAR  FAR *szConnStrIn
     69     (cbConnStrIn sql-small-int)        ; SWORD       cbConnStrIn
     70                                        ;(*szConnStrOut string-ptr) ; UCHAR  FAR *szConnStrOut
     71     (*szConnStrOut string-ptr)         ; UCHAR  FAR *szConnStrOut
     72     (cbConnStrOutMax sql-small-int)    ; SWORD       cbConnStrOutMaxw
     73     (*pcbConnStrOut *sql-small-int)    ; SWORD  FAR *pcbConnStrOut
     74     (fDriverCompletion :unsigned-short))) ; UWORD       fDriverCompletion
     75
     76(defsqlfun "SQLDisconnect"
     77    ((hdbc sql-h-dbc)))                 ; HDBC        hdbc
     78
     79(defsqlfun "SQLAllocStmt"
     80    ((hdbc sql-h-dbc)                   ; HDBC        hdbc
     81     (*phstmt *sql-h-stmt)))            ; HSTMT  FAR *phstmt
     82
     83
     84
     85(defsqlfun "SQLGetInfo"
     86    ((hdbc sql-h-dbc)                   ; HDBC        hdbc
     87     (fInfoType sql-u-small-int)        ; UWORD       fInfoType
     88     (rgbInfoValue sql-pointer)         ; PTR         rgbInfoValue
     89     (cbInfoValueMax sql-small-int)     ; SWORD       cbInfoValueMax
     90     (*pcbInfoValue *sql-small-int)))   ; SWORD  FAR *pcbInfoValue
     91
     92
     93(defsqlfun ("SQLGetInfo" SQLGetInfo-Str)
     94    ((hdbc sql-h-dbc)                   ; HDBC        hdbc
     95     (fInfoType sql-u-small-int)        ; UWORD       fInfoType
     96     (rgbInfoValue string-ptr)          ; PTR         rgbInfoValue
     97     (cbInfoValueMax sql-small-int)     ; SWORD       cbInfoValueMax
     98     (*pcbInfoValue *sql-small-int)))   ; SWORD  FAR *pcbInfoValue
     99
     100
     101(defsqlfun "SQLPrepare"
     102    ((hstmt sql-h-stmt)                 ; HSTMT       hstmt
     103     (*szSqlStr string-ptr)             ; UCHAR  FAR *szSqlStr
     104     (cbSqlStr sql-integer)))           ; SDWORD      cbSqlStr
     105
     106
     107
     108(defsqlfun "SQLExecute"
     109    ((hstmt sql-h-stmt)))               ; HSTMT       hstmt
     110
     111
     112(defsqlfun "SQLExecDirect"
     113    ((hstmt sql-h-stmt)                 ; HSTMT       hstmt
     114     (*szSqlStr string-ptr)             ; UCHAR  FAR *szSqlStr
     115     (cbSqlStr sql-integer)))           ; SDWORD      cbSqlStr
     116
     117
     118
     119(defsqlfun "SQLFreeStmt"
     120    ((hstmt sql-h-stmt)                 ; HSTMT       hstmt
     121     (fOption sql-u-small-int)))        ; UWORD       fOption
     122
     123
     124
     125(defsqlfun "SQLError"
     126    ((henv sql-h-env)                   ; HENV        henv
     127     (hdbc sql-h-dbc)                   ; HDBC        hdbc
     128     (hstmt sql-h-stmt)                 ; HSTMT       hstmt
     129                                        ;     (*szSqlState string-ptr)   ; UCHAR  FAR *szSqlState
     130     (*szSqlState string-ptr)           ; UCHAR  FAR *szSqlState
     131     (*pfNativeError *sql-integer)      ; SDWORD FAR *pfNativeError
     132                                        ;     (*szErrorMsg string-ptr)   ; UCHAR  FAR *szErrorMsg
     133     (*szErrorMsg string-ptr)           ; UCHAR  FAR *szErrorMsg
     134     (cbErrorMsgMax sql-small-int)      ; SWORD       cbErrorMsgMax
     135     (*pcbErrorMsg *sql-small-int)))    ; SWORD  FAR *pcbErrorMsg
     136
     137
     138
     139(defsqlfun "SQLNumResultCols"
     140    ((hstmt sql-h-stmt)                 ; HSTMT       hstmt
     141     (*pccol *sql-small-int)))          ; SWORD  FAR *pccol
     142
     143
     144(defsqlfun "SQLRowCount"
     145    ((hstmt sql-h-stmt)                 ; HSTMT       hstmt
     146     (*pcrow *sql-len)))                ; SDWORD FAR *pcrow
     147
     148
     149(defsqlfun "SQLDescribeCol"
     150    ((hstmt sql-h-stmt)                 ; HSTMT       hstmt
     151     (icol sql-u-small-int)             ; UWORD       icol
     152     (*szColName string-ptr)            ; UCHAR  FAR *szColName
     153     (cbColNameMax sql-small-int)       ; SWORD       cbColNameMax
     154     (*pcbColName *sql-small-int)       ; SWORD  FAR *pcbColName
     155     (*pfSqlType *sql-small-int)        ; SWORD  FAR *pfSqlType
     156     (*pcbColDef *sql-u-len)            ; UDWORD FAR *pcbColDef
     157     (*pibScale *sql-small-int)         ; SWORD  FAR *pibScale
     158     (*pfNullable *sql-small-int)))     ; SWORD  FAR *pfNullable
     159
     160
     161(defsqlfun "SQLBindCol"
     162    ((hstmt sql-h-stmt)                 ; HSTMT       hstmt
     163     (icol sql-u-small-int)             ; UWORD       icol
     164     (fCType sql-small-int)             ; SWORD       fCType
     165     (rgbValue sql-pointer)             ; PTR         rgbValue
     166     (cbValueMax sql-len)               ; SDWORD      cbValueMax
     167     (*pcbValue *sql-len)))             ; SDWORD FAR *pcbValue
     168
    48169 
    49   (defcfun "SQLDriverConnect" retcode
    50     (hdbc sql-handle)          ; HDBC        hdbc
    51     (hwnd sql-handle)          ; SQLHWND     hwnd
    52                                         ;(*szConnStrIn string-ptr)  ; UCHAR  FAR *szConnStrIn
    53     (*szConnStrIn string-ptr)  ; UCHAR  FAR *szConnStrIn
    54     (cbConnStrIn :short)       ; SWORD       cbConnStrIn
    55                                         ;(*szConnStrOut string-ptr) ; UCHAR  FAR *szConnStrOut
    56      (*szConnStrOut string-ptr) ; UCHAR  FAR *szConnStrOut
    57      (cbConnStrOutMax :short)   ; SWORD       cbConnStrOutMaxw
    58      (*pcbConnStrOut *short)      ; SWORD  FAR *pcbConnStrOut
    59      (fDriverCompletion :unsigned-short) ; UWORD       fDriverCompletion
    60      )
    61    
    62   (defcfun "SQLDisconnect" retcode
    63     (hdbc sql-handle))         ; HDBC        hdbc
    64  
    65   (defcfun "SQLAllocStmt" retcode
    66     (hdbc sql-handle)          ; HDBC        hdbc
    67     (*phstmt *sql-handle))   ; HSTMT  FAR *phstmt
    68 
    69 
    70  
    71   (defcfun "SQLGetInfo" retcode
    72     (hdbc sql-handle)          ; HDBC        hdbc
    73     (fInfoType :short)         ; UWORD       fInfoType
    74     (rgbInfoValue :pointer)        ; PTR         rgbInfoValue
    75     (cbInfoValueMax :short)    ; SWORD       cbInfoValueMax
    76     (*pcbInfoValue :pointer)       ; SWORD  FAR *pcbInfoValue
    77      )
    78 
    79   (defcfun ("SQLGetInfo" SQLGetInfo-Str) retcode
    80     (hdbc sql-handle)          ; HDBC        hdbc
    81      (fInfoType :short)         ; UWORD       fInfoType
    82      (rgbInfoValue string-ptr)        ; PTR         rgbInfoValue
    83      (cbInfoValueMax :short)    ; SWORD       cbInfoValueMax
    84      (*pcbInfoValue :pointer)       ; SWORD  FAR *pcbInfoValue
    85      )
    86 
    87 
    88   (defcfun "SQLPrepare" retcode
    89     (hstmt sql-handle)         ; HSTMT       hstmt
    90      (*szSqlStr string-ptr)     ; UCHAR  FAR *szSqlStr
    91      (cbSqlStr :long)           ; SDWORD      cbSqlStr
    92      )
    93 
    94  
    95   (defcfun "SQLExecute" retcode
    96     (hstmt sql-handle)         ; HSTMT       hstmt
    97      )
    98 
    99  
    100   (defcfun "SQLExecDirect" retcode
    101     (hstmt sql-handle)         ; HSTMT       hstmt
    102      (*szSqlStr string-ptr)     ; UCHAR  FAR *szSqlStr
    103      (cbSqlStr :long)           ; SDWORD      cbSqlStr
    104      )
    105 
    106  
    107   (defcfun "SQLFreeStmt" retcode
    108     (hstmt sql-handle)         ; HSTMT       hstmt
    109      (fOption :short))          ; UWORD       fOption
    110 
    111  
    112   (defcfun "SQLCancel" retcode
    113     (hstmt sql-handle)         ; HSTMT       hstmt
    114      )
    115 
    116  
    117   (defcfun "SQLError" retcode
    118     (henv sql-handle)          ; HENV        henv
    119      (hdbc sql-handle)          ; HDBC        hdbc
    120      (hstmt sql-handle)         ; HSTMT       hstmt
    121 ;     (*szSqlState string-ptr)   ; UCHAR  FAR *szSqlState
    122      (*szSqlState string-ptr)   ; UCHAR  FAR *szSqlState
    123      (*pfNativeError *SDWORD)      ; SDWORD FAR *pfNativeError
    124 ;     (*szErrorMsg string-ptr)   ; UCHAR  FAR *szErrorMsg
    125      (*szErrorMsg string-ptr)   ; UCHAR  FAR *szErrorMsg
    126      (cbErrorMsgMax :short)     ; SWORD       cbErrorMsgMax
    127      (*pcbErrorMsg *short))        ; SWORD  FAR *pcbErrorMsg
    128  
    129 
    130 
    131   (defcfun "SQLNumResultCols" retcode
    132     (hstmt sql-handle)         ; HSTMT       hstmt
    133      (*pccol :pointer)              ; SWORD  FAR *pccol
    134      )
    135 
    136  
    137   (defcfun "SQLRowCount" retcode
    138     (hstmt sql-handle)         ; HSTMT       hstmt
    139      (*pcrow *sdword)              ; SDWORD FAR *pcrow
    140      )
    141 
    142  
    143   (defcfun "SQLDescribeCol" retcode
    144     (hstmt sql-handle)         ; HSTMT       hstmt
    145      (icol :short)              ; UWORD       icol
    146      (*szColName string-ptr)    ; UCHAR  FAR *szColName
    147      (cbColNameMax :short)      ; SWORD       cbColNameMax
    148      (*pcbColName *short)         ; SWORD  FAR *pcbColName
    149      (*pfSqlType *short)          ; SWORD  FAR *pfSqlType
    150      (*pcbColDef *ulong)          ; UDWORD FAR *pcbColDef
    151      (*pibScale *short)           ; SWORD  FAR *pibScale
    152      (*pfNullable *short)         ; SWORD  FAR *pfNullable
    153      )
    154 
    155  
    156   (defcfun "SQLColAttributes" retcode
    157     (hstmt sql-handle)         ; HSTMT       hstmt
    158      (icol :short)              ; UWORD       icol
    159      (fDescType :short)         ; UWORD       fDescType
    160      (rgbDesc :pointer)             ; PTR         rgbDesc
    161      (cbDescMax :short)         ; SWORD       cbDescMax
    162      (*pcbDesc *sword)            ; SWORD  FAR *pcbDesc
    163      (*pfDesc *sdword)             ; SDWORD FAR *pfDesc
    164      )
    165 
    166 
    167   (defcfun "SQLColumns" retcode
    168     (hstmt sql-handle)             ; HSTMT       hstmt
    169      (*szTableQualifier string-ptr) ; UCHAR  FAR *szTableQualifier
    170      (cbTableQualifier :short)      ; SWORD       cbTableQualifier
    171      (*szTableOwner string-ptr)     ; UCHAR  FAR *szTableOwner
    172      (cbTableOwner :short)          ; SWORD       cbTableOwner
    173      (*szTableName string-ptr)      ; UCHAR  FAR *szTableName
    174      (cbTableName :short)           ; SWORD       cbTableName
    175      (*szColumnName string-ptr)     ; UCHAR  FAR *szColumnName
    176      (cbColumnName :short)          ; SWORD       cbColumnName
    177      )
    178 
    179 
    180   (defcfun "SQLBindCol" retcode
    181     (hstmt sql-handle)         ; HSTMT       hstmt
    182      (icol :short)              ; UWORD       icol
    183      (fCType :short)            ; SWORD       fCType
    184      (rgbValue :pointer)            ; PTR         rgbValue
    185      (cbValueMax :long)         ; SDWORD      cbValueMax
    186      (*pcbValue *sdword)           ; SDWORD FAR *pcbValue
    187      )
    188 
    189  
    190   (defcfun "SQLFetch" retcode
    191     (hstmt sql-handle)         ; HSTMT       hstmt
    192      )
    193 
    194    
    195   (defcfun "SQLTransact" retcode
    196     (henv sql-handle)          ; HENV        henv
    197     (hdbc sql-handle)          ; HDBC        hdbc
    198     (fType :short)             ; UWORD       fType ($SQL_COMMIT or $SQL_ROLLBACK)
    199     )
    200 
    201 
    202   ;; ODBC 2.0
    203   (defcfun "SQLDescribeParam" retcode
    204     (hstmt sql-handle)         ; HSTMT       hstmt
    205      (ipar :short)              ; UWORD       ipar
    206      (*pfSqlType *sword)          ; SWORD  FAR *pfSqlType
    207      (*pcbColDef *ulong)          ; UDWORD FAR *pcbColDef
    208      (*pibScale *sword)           ; SWORD  FAR *pibScale
    209      (*pfNullable *sword)         ; SWORD  FAR *pfNullable
    210      )
    211 
    212  
    213   ;; ODBC 2.0
    214   (defcfun "SQLBindParameter" retcode
    215     (hstmt sql-handle)         ; HSTMT       hstmt
    216      (ipar :short)              ; UWORD       ipar
    217      (fParamType :short)        ; SWORD       fParamType
    218      (fCType :short)            ; SWORD       fCType
    219      (fSqlType :short)          ; SWORD       fSqlType
    220      (cbColDef :ulong)           ; UDWORD      cbColDef
    221      (ibScale :short)           ; SWORD       ibScale
    222      (rgbValue :pointer)            ; PTR         rgbValue
    223      (cbValueMax :long)         ; SDWORD      cbValueMax
    224      (*pcbValue *sdword)           ; SDWORD FAR *pcbValue
    225      )
    226 
    227  
    228   ;; level 1
    229   (defcfun "SQLGetData" retcode
    230     (hstmt sql-handle)         ; HSTMT       hstmt
    231      (icol :short)              ; UWORD       icol
    232      (fCType :short)            ; SWORD       fCType
    233      (rgbValue :pointer)            ; PTR         rgbValue
    234      (cbValueMax :long)         ; SDWORD      cbValueMax
    235      (*pcbValue *sdword)           ; SDWORD FAR *pcbValue
    236      )
    237 
    238 
    239   (defcfun "SQLParamData" retcode
    240     (hstmt sql-handle)         ; HSTMT       hstmt
    241      (*prgbValue :pointer)          ; PTR    FAR *prgbValue
    242      )
    243 
    244  
    245   (defcfun "SQLPutData" retcode
    246     (hstmt sql-handle)         ; HSTMT       hstmt
    247      (rgbValue :pointer)            ; PTR         rgbValue
    248      (cbValue :long)            ; SDWORD      cbValue
    249      )
    250 
    251  
    252   (defcfun "SQLGetConnectOption" retcode
    253     (hdbc sql-handle)          ; HDBC        hdbc
    254      (fOption :short)           ; UWORD       fOption
    255      (pvParam :pointer)             ; PTR         pvParam
    256      )
    257 
    258  
    259   (defcfun "SQLSetConnectOption" retcode
    260     (hdbc sql-handle)          ; HDBC        hdbc
    261      (fOption :short)           ; UWORD       fOption
    262      (vParam :ulong)             ; UDWORD      vParam
    263      )
     170(defsqlfun "SQLFetch"
     171    ((hstmt sql-h-stmt)))               ; HSTMT       hstmt
     172
     173
     174(defsqlfun "SQLTransact"
     175    ((henv sql-h-env)                   ; HENV        henv
     176     (hdbc sql-h-dbc)                   ; HDBC        hdbc
     177     (fType sql-u-small-int))) ; UWORD       fType ($SQL_COMMIT or $SQL_ROLLBACK)
     178
     179
     180;; ODBC 2.0
     181(defsqlfun "SQLBindParameter"
     182    ((hstmt sql-h-stmt)                 ; HSTMT       hstmt
     183     (ipar sql-u-small-int)             ; UWORD       ipar
     184     (fParamType sql-small-int)         ; SWORD       fParamType
     185     (fCType sql-small-int)             ; SWORD       fCType
     186     (fSqlType sql-small-int)           ; SWORD       fSqlType
     187     (cbColDef sql-u-len)               ; UDWORD      cbColDef
     188     (ibScale sql-small-int)            ; SWORD       ibScale
     189     (rgbValue sql-pointer)             ; PTR         rgbValue
     190     (cbValueMax sql-len)               ; SDWORD      cbValueMax
     191     (*pcbValue *sql-len)))             ; SDWORD FAR *pcbValue
     192
     193
     194;; level 1
     195(defsqlfun "SQLGetData"
     196    ((hstmt sql-h-stmt)                 ; HSTMT       hstmt
     197     (icol sql-u-small-int)             ; UWORD       icol
     198     (fCType sql-small-int)             ; SWORD       fCType
     199     (rgbValue sql-pointer)             ; PTR         rgbValue
     200     (cbValueMax sql-len)               ; SDWORD      cbValueMax
     201     (*pcbValue *sql-len)))             ; SDWORD FAR *pcbValue
     202
     203
     204(defsqlfun "SQLParamData"
     205    ((hstmt sql-h-stmt)                 ; HSTMT       hstmt
     206     (*prgbValue sql-pointer)))         ; PTR    FAR *prgbValue
     207
     208
     209(defsqlfun "SQLPutData"
     210    ((hstmt sql-h-stmt)                 ; HSTMT       hstmt
     211     (rgbValue sql-pointer)             ; PTR         rgbValue
     212     (cbValue sql-len)))                ; SDWORD      cbValue
     213
     214
     215(defsqlfun "SQLSetConnectOption"
     216    ((hdbc sql-h-dbc)                   ; HDBC        hdbc
     217     (fOption sql-u-small-int)          ; UWORD       fOption
     218     (vParam sql-u-len)))               ; UDWORD      vParam
    264219
    265220
    … …  
    277232; driver-specific value, the value in ValuePtr may be a signed integer.
    278233
    279 (defcfun ("SQLSetConnectAttr" SQLSetConnectAttr_long) retcode
    280     (hdbc sql-handle)          ; HDBC        hdbc
    281      (fOption :short)           ; UWORD       fOption
    282      (pvParam :long)             ; UDWORD      vParam
    283      (stringlength :long)
    284      )
    285 
    286 
    287 (defcfun ("SQLSetConnectAttr" SQLSetConnectAttr_string) retcode
    288     (hdbc sql-handle)          ; HDBC        hdbc
    289      (fOption :short)           ; UWORD       fOption
    290      (pvParam string-ptr)             ; UDWORD      vParam
    291      (stringlength :long)
    292      )
    293 
    294  
    295 
    296   (defcfun "SQLSetPos" retcode
    297     (hstmt sql-handle)         ; HSTMT       hstmt
    298      (irow :short)              ; UWORD       irow
    299      (fOption :short)           ; UWORD       fOption
    300      (fLock :short)             ; UWORD       fLock
    301      )
    302 
    303 
    304   ; level 2
    305   (defcfun "SQLExtendedFetch" retcode
    306     (hstmt sql-handle)         ; HSTMT       hstmt
    307      (fFetchType :short)        ; UWORD       fFetchType
    308      (irow :long)               ; SDWORD      irow
    309      (*pcrow :pointer)              ; UDWORD FAR *pcrow
    310      (*rgfRowStatus :pointer)       ; UWORD  FAR *rgfRowStatus
    311      )
    312 
    313   (defcfun "SQLDataSources" retcode
    314     (henv sql-handle)          ; HENV        henv
    315      (fDirection :short)
    316      (*szDSN string-ptr)        ; UCHAR  FAR *szDSN
    317      (cbDSNMax :short)          ; SWORD       cbDSNMax
    318      (*pcbDSN *sword)             ; SWORD      *pcbDSN
    319      (*szDescription string-ptr) ; UCHAR     *szDescription
    320      (cbDescriptionMax :short)  ; SWORD       cbDescriptionMax
    321      (*pcbDescription *sword)     ; SWORD      *pcbDescription
    322      )
    323 
    324 
    325   (defcfun "SQLFreeEnv" retcode
    326     (henv sql-handle)          ; HSTMT       hstmt
    327     )
    328 
    329 
    330   (defcfun "SQLMoreResults" retcode
    331       (hstmt sql-handle))
     234(defsqlfun ("SQLSetConnectAttr" SQLSetConnectAttr_long)
     235    ((hdbc sql-h-dbc)                   ; HDBC        hdbc
     236     ;; TODO: The new def of fOption doesn't seem compatible with the
     237     ;; original, but matches my headers.
     238     (fOption sql-integer)              ; UWORD       fOption
     239     (pvParam sql-integer)              ; UDWORD      vParam
     240     (stringlength sql-integer)))
     241
     242
     243(defsqlfun ("SQLSetConnectAttr" SQLSetConnectAttr_string)
     244    ((hdbc sql-handle)                  ; HDBC        hdbc
     245     (fOption sql-integer)              ; UWORD       fOption
     246     (pvParam string-ptr)               ; UDWORD      vParam
     247     (stringlength sql-integer)))
     248
     249
     250;; level 2
     251(defsqlfun "SQLMoreResults"
     252    ((hstmt sql-h-stmt)))
    332253
    333254
    334255  ;;; foreign type definitions
    335256
    336   (defcstruct sql-c-time ""
    337     (hour   :short)
    338     (minute :short)
    339     (second :short))
    340  
    341   (defcstruct sql-c-date ""
    342     (year  :short)
    343     (month :short)
    344     (day   :short))
    345  
    346   (defcstruct sql-c-timestamp ""
    347     (year     :short)
    348     (month    :short)
    349     (day      :short)
    350     (hour     :short)
    351     (minute   :short)
    352     (second   :short)
    353     (fraction :long))
     257(defcstruct sql-c-time ""
     258            (hour   sql-u-small-int)
     259            (minute sql-u-small-int)
     260            (second sql-u-small-int))
     261
     262(defcstruct sql-c-date ""
     263            (year  sql-small-int)
     264            (month sql-u-small-int)
     265            (day   sql-u-small-int))
     266
     267(defcstruct sql-c-timestamp ""
     268            (year     sql-small-int)
     269            (month    sql-u-small-int)
     270            (day      sql-u-small-int)
     271            (hour     sql-u-small-int)
     272            (minute   sql-u-small-int)
     273            (second   sql-u-small-int)
     274            (fraction sql-u-integer))
    354275
    355276(defun %put-sql-c-date (adr %year %month %day)
    … …  
    358279  (setf (foreign-slot-value adr 'sql-c-date 'day) %day))
    359280
    360  
    361 (defun %put-sql-c-timestamp (adr %year %month %day %hour %minute %second %fraction)
     281
     282(defun %put-sql-c-timestamp (adr %year %month %day %hour %minute %second
     283                             %fraction)
    362284  (setf (foreign-slot-value adr 'sql-c-timestamp 'second) %second)
    363285  (setf (foreign-slot-value adr 'sql-c-timestamp  'minute) %minute)
    … …  
    366288  (setf (foreign-slot-value adr 'sql-c-timestamp  'month) %month)
    367289  (setf (foreign-slot-value adr 'sql-c-timestamp 'year) %year)
    368   (setf (foreign-slot-value adr 'sql-c-timestamp 'fraction) %fraction)
    369   )   
     290  (setf (foreign-slot-value adr 'sql-c-timestamp 'fraction) %fraction))
    370291
    371292(defun timestamp-to-universal-time (adr)
    372   (with-foreign-slots 
     293  (with-foreign-slots
    373294      ((year month day hour minute second fraction) adr sql-c-timestamp)
    374295    (values
    … …  
    379300      day
    380301      month
    381       year )
     302      year)
    382303     fraction)))
    383    
     304
    384305
    385306(defun date-to-universal-time (adr)
    386   (with-foreign-slots 
     307  (with-foreign-slots
    387308      ((year month day) adr sql-c-date)
    388309    (encode-universal-time
    389       0 0 0
    390       day
    391       month
    392       year)))
    393 
    394 
    395 (defmacro %sql-len-data-at-exec (length) 
     310     0 0 0
     311     day
     312     month
     313     year)))
     314
     315
     316(defmacro %sql-len-data-at-exec (length)
    396317  `(- $SQL_LEN_DATA_AT_EXEC_OFFSET ,length))

  • 64-bit/src/odbc/odbc-functions.lisp

    r1 r6  
    1717  `(let (,@allocs)
    1818    (unwind-protect
    19       (progn ,@body)
    20       ,@(mapcar (lambda (alloc) (list 'cffi:foreign-free (first alloc))) allocs))))
    21 
    22              
     19         (progn ,@body)
     20      ,@(mapcar (lambda (alloc) (list 'cffi:foreign-free (first alloc)))
     21                allocs))))
     22
     23
    2324
    2425
    … …  
    4445  ())
    4546
     47;; TODO: Why doesn't this use with-temporary-allocations? -dso
    4648(defun handle-error (henv hdbc hstmt)
    47    (let
    48        ((sql-state (alloc-chars 256))
    49         (error-message (alloc-chars #.$SQL_MAX_MESSAGE_LENGTH))
    50         (error-code (cffi:foreign-alloc :long))
    51         (msg-length (cffi:foreign-alloc :short)))
    52      (SQLError henv
    53                hdbc
    54                hstmt sql-state
    55                error-code error-message
    56                $SQL_MAX_MESSAGE_LENGTH msg-length)
    57      (values
    58       (get-string-nts error-message)
    59       (get-string-nts sql-state)
    60       (cffi:mem-ref msg-length :short)
    61       (cffi:mem-ref error-code :long))))
     49  (let
     50      ((sql-state (alloc-chars 256))
     51       (error-message (alloc-chars #.$SQL_MAX_MESSAGE_LENGTH))
     52       (error-code (cffi:foreign-alloc 'sql-integer))
     53       (msg-length (cffi:foreign-alloc 'sql-small-int)))
     54    (SQLError henv
     55              hdbc
     56              hstmt sql-state
     57              error-code error-message
     58              $SQL_MAX_MESSAGE_LENGTH msg-length)
     59    (values
     60     (get-string-nts error-message)
     61     (get-string-nts sql-state)
     62     (cffi:mem-ref msg-length 'sql-small-int)
     63     (cffi:mem-ref error-code 'sql-integer))))
    6264
    6365
    … …  
    6769;#+ignore
    6870(defun sql-state (henv hdbc hstmt)
    69   (with-temporary-allocations 
     71  (with-temporary-allocations
    7072      ((sql-state (cffi:foreign-alloc :char :count 256))
    7173       (error-message (cffi:foreign-alloc :char :count $SQL_MAX_MESSAGE_LENGTH))
    72        (error-code (cffi:foreign-alloc :long))
    73        (msg-length (cffi:foreign-alloc :short)))
     74       (error-code (cffi:foreign-alloc 'sql-integer))
     75       (msg-length (cffi:foreign-alloc 'sql-small-int)))
    7476    (SQLError henv hdbc hstmt sql-state error-code
    7577              error-message $SQL_MAX_MESSAGE_LENGTH msg-length)
    76     (get-string sql-state 5) ;(%cstring-to-keyword sql-state)
     78    (get-string sql-state 5)          ;(%cstring-to-keyword sql-state)
    7779    ))
    7880
    … …  
    165167
    166168(defun %new-environment-handle ()
    167   (cffi:with-foreign-object (phenv 'sql-handle)
     169  (cffi:with-foreign-object (phenv 'sql-h-env)
    168170    (with-error-handling
    169       ()
    170       (SQLAllocEnv phenv)
    171       (cffi:mem-ref phenv 'sql-handle)
    172       )))
    173 
    174 (defun %sql-free-environment (henv)
    175   (with-error-handling
    176     (:henv henv)
    177     (SQLFreeEnv henv)))
     171        ()
     172        (SQLAllocEnv phenv)
     173      (cffi:mem-ref phenv 'sql-h-env))))
    178174
    179175(defun %new-db-connection-handle (henv)
    180   (cffi:with-foreign-object (phdbc 'sql-handle) 
     176  (cffi:with-foreign-object (phdbc 'sql-h-dbc)
    181177    (with-error-handling
    182178        (:henv henv)
    183       (SQLAllocConnect henv phdbc)
    184       (cffi:mem-ref phdbc 'sql-handle))))
     179        (SQLAllocConnect henv phdbc)
     180      (cffi:mem-ref phdbc 'sql-h-dbc))))
    185181
    186182(defun %free-statement (hstmt option)
    187   (with-error-handling 
     183  (with-error-handling
    188184      (:hstmt hstmt)
    189       (SQLFreeStmt 
    190        hstmt 
     185      (SQLFreeStmt
     186       hstmt
    191187       (ecase option
    192188         (:drop $SQL_DROP)
    … …  
    217213;; functional interface
    218214
    219 (defun %sql-connect (hdbc server uid pwd)
    220   (cffi:with-foreign-string (server-ptr server)
    221     (cffi:with-foreign-string (uid-ptr uid)
    222       (cffi:with-foreign-string (pwd-ptr pwd)
    223         (with-error-handling
    224             (:hdbc hdbc)
    225       (SQLConnect hdbc server-ptr $SQL_NTS uid-ptr
    226                   $SQL_NTS pwd-ptr $SQL_NTS))))))
    227 
    228215;;
    229216(defun %sql-driver-connect (henv hdbc connection-string completion-option)
     217  (declare (string connection-string))
    230218  (let ((completion-option
    231219         (ecase completion-option
    … …  
    234222           (:prompt $SQL_DRIVER_PROMPT)
    235223           (:noprompt $SQL_DRIVER_NOPROMPT))))
    236     (cffi:with-foreign-string (connection-str-ptr  connection-string)
     224    (cffi:with-foreign-string (connection-str-ptr connection-string)
    237225      (with-temporary-allocations
    238226          ((complete-connection-str-ptr (alloc-chars 1024))
    239            (length-ptr (cffi:foreign-alloc :short)))
    240         (with-error-handling 
     227           (length-ptr (cffi:foreign-alloc 'sql-small-int)))
     228        (with-error-handling
    241229            (:henv henv :hdbc hdbc)
    242          
    243           (SQLDriverConnect hdbc
    244                             (cffi:null-pointer) ; no window
    245                             connection-str-ptr
    246                             (length connection-string)
    247                                         ;$SQL_NTS
    248                             complete-connection-str-ptr
    249                             1024
    250                             length-ptr
    251                             completion-option))
     230           
     231            (SQLDriverConnect hdbc
     232                              (cffi:null-pointer) ; no window
     233                              connection-str-ptr ; TODO: How does
     234                                                 ; encoding affect the
     235                                                 ; length?
     236                              (length connection-string) ;$SQL_NTS
     237                              complete-connection-str-ptr
     238                              1024
     239                              length-ptr
     240                              completion-option))
    252241        (get-string-nts complete-connection-str-ptr)))))
    253242
    254243(defun %disconnect (hdbc)
    255   (with-error-handling 
    256     (:hdbc hdbc)
    257     (SQLDisconnect hdbc)))
     244  (with-error-handling
     245      (:hdbc hdbc)
     246      (SQLDisconnect hdbc)))
    258247
    259248(defun %commit (henv hdbc)
    260   (with-error-handling 
    261     (:henv henv :hdbc hdbc)
    262     (SQLTransact
    263      henv hdbc $SQL_COMMIT)))
     249  (with-error-handling
     250      (:henv henv :hdbc hdbc)
     251      (SQLTransact
     252       henv hdbc $SQL_COMMIT)))
    264253
    265254(defun %rollback (henv hdbc)
    266   (with-error-handling 
    267     (:henv henv :hdbc hdbc)
    268     (SQLTransact
    269      henv hdbc $SQL_ROLLBACK)))
     255  (with-error-handling
     256      (:henv henv :hdbc hdbc)
     257      (SQLTransact
     258       henv hdbc $SQL_ROLLBACK)))
    270259
    271260; col-nr is zero-based in Lisp
    272261; col-nr = :bookmark retrieves a bookmark.
    273262(defun %bind-column (hstmt column-nr c-type data-ptr precision out-len-ptr)
    274   (with-error-handling
    275     (:hstmt hstmt)
    276     (SQLBindCol hstmt
    277                 (if (eq column-nr :bookmark) 0 (1+ column-nr))
    278                 c-type data-ptr precision out-len-ptr)))
     263  (declare ((integer 0) column-nr))
     264  (with-error-handling
     265      (:hstmt hstmt)
     266      (SQLBindCol hstmt
     267                  (if (eq column-nr :bookmark) 0 (1+ column-nr))
     268                  c-type data-ptr precision out-len-ptr)))
    279269
    280270; parameter-nr is zero-based in Lisp
    281271(defun %sql-bind-parameter (hstmt parameter-nr parameter-type c-type
    282                                       sql-type precision scale data-ptr
    283                                       max-value out-len-ptr)
    284   (with-error-handling
    285     (:hstmt hstmt)
    286     (SQLBindParameter hstmt (1+ parameter-nr)
    287                       parameter-type ;$SQL_PARAM_INPUT
    288                       c-type ;$SQL_C_CHAR
    289                       sql-type ;$SQL_VARCHAR
    290                       precision ;(1- (length str))
    291                       scale ;0
    292                       data-ptr
    293                       max-value
    294                       out-len-ptr ;#.(cffi:null-pointer)
    295                       )))
     272                            sql-type precision scale data-ptr
     273                            max-value out-len-ptr)
     274  (declare ((integer 0) parameter-nr))
     275  (with-error-handling
     276      (:hstmt hstmt)
     277      (SQLBindParameter hstmt (1+ parameter-nr)
     278                        parameter-type  ;$SQL_PARAM_INPUT
     279                        c-type          ;$SQL_C_CHAR
     280                        sql-type        ;$SQL_VARCHAR
     281                        precision       ;(1- (length str))
     282                        scale           ;0
     283                        data-ptr
     284                        max-value
     285                        out-len-ptr     ;#.(cffi:null-pointer)
     286                        )))
    296287
    297288(defun %sql-fetch (hstmt)
    … …  
    301292
    302293(defun %new-statement-handle (hdbc)
    303   (with-temporary-allocations 
    304       ((hstmt-ptr (cffi:foreign-alloc 'sql-handle)))
    305     (with-error-handling 
     294  (with-temporary-allocations
     295      ((hstmt-ptr (cffi:foreign-alloc 'sql-h-stmt)))
     296    (with-error-handling
    306297        (:hdbc hdbc)
    307       (SQLAllocStmt hdbc hstmt-ptr)
    308       (cffi:mem-ref hstmt-ptr 'sql-handle))))
     298        (SQLAllocStmt hdbc hstmt-ptr)
     299      (cffi:mem-ref hstmt-ptr 'sql-h-stmt))))
    309300
    310301(defun %sql-get-info (hdbc info-type)
    … …  
    344335      #.$SQL_TABLE_TERM
    345336      #.$SQL_USER_NAME)
    346      (with-temporary-allocations 
     337     (with-temporary-allocations
    347338         ((info-ptr (alloc-chars 1024))
    348           (info-length-ptr (cffi:foreign-alloc :short)))
    349        (with-error-handling 
    350          (:hdbc hdbc)
    351         #-pcl
     339          (info-length-ptr (cffi:foreign-alloc 'sql-small-int)))
     340       (with-error-handling
     341           (:hdbc hdbc)
     342          #-pcl
    352343         (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr)
    353         #+pcl
     344        #+pcl
    354345         (SQLGetInfo-Str hdbc info-type info-ptr 1023 info-length-ptr)
     346         ;; TODO: I believe the following assumes that the buffer was
     347         ;; big enough to include the null-terminator.
    355348         (get-string-nts info-ptr))))
    356     ;; those returning a word
     349    ;; those returning a 16-bit integer
    357350    ((#.$SQL_ACTIVE_CONNECTIONS
    358351      #.$SQL_ACTIVE_STATEMENTS
    … …  
    383376      #.$SQL_TXN_CAPABLE)
    384377     (with-temporary-allocations
    385          ((info-ptr (cffi::foreign-alloc :short))
    386           (info-length-ptr (cffi::foreign-alloc :short)))
    387        (with-error-handling
    388         (:hdbc hdbc)
    389          (SQLGetInfo hdbc
    390                      info-type
    391                      info-ptr
    392                      255
    393                      info-length-ptr)
    394          (cffi:mem-ref info-ptr :short)))
    395      )
    396     ;; those returning a long bitmask
    397     ((#.$SQL_ALTER_TABLE
     378         ((info-ptr (cffi::foreign-alloc 'sql-small-int))
     379          (info-length-ptr (cffi::foreign-alloc 'sql-small-int)))
     380       (with-error-handling
     381           (:hdbc hdbc)
     382           (SQLGetInfo hdbc
     383                       info-type
     384                       info-ptr
     385                       0
     386                       info-length-ptr)
     387         (cffi:mem-ref info-ptr 'sql-small-int))))
     388    ;; those returning a 32-bit bitmask
     389    ((#.$SQL_ALTER_TABLE
    398390      #.$SQL_BOOKMARK_PERSISTENCE
    399391      #.$SQL_CONVERT_BIGINT
    … …  
    440432      #.$SQL_TXN_ISOLATION_OPTION
    441433      #.$SQL_UNION)
    442       (with-temporary-allocations
    443           ((info-ptr (cffi:foreign-alloc :unsigned-long))
    444            (info-length-ptr (cffi:foreign-alloc :short)))
    445        (with-error-handling
    446          (:hdbc hdbc)
    447          (SQLGetInfo hdbc
    448                      info-type
    449                      info-ptr
    450                      255
    451                      info-length-ptr)
    452          (cffi:mem-ref info-ptr :unsigned-long)))
    453      )
    454     ;; those returning a long integer
     434     (with-temporary-allocations
     435         ;; TODO: It'd be nice to have this as a sql-* type.  However,
     436         ;; while the X/Open spec is usually quiet about data sizes,
     437         ;; it specifically says a 32-bit bitmask for these; so if
     438         ;; SQL-INTEGER changes to 64-bit, these may or may not change
     439         ;; as well. -dso
     440         ((info-ptr (cffi:foreign-alloc :uint32))
     441          (info-length-ptr (cffi:foreign-alloc 'sql-small-int)))
     442       (with-error-handling
     443           (:hdbc hdbc)
     444           (SQLGetInfo hdbc
     445                       info-type
     446                       info-ptr
     447                       0
     448                       info-length-ptr)
     449         (cffi:mem-ref info-ptr :uint32))))
     450    ;; those returning an integer
    455451    ((#.$SQL_DEFAULT_TXN_ISOLATION
    456452      #.$SQL_DRIVER_HDBC
    … …  
    462458      #.$SQL_MAX_BINARY_LITERAL_LEN
    463459      #.$SQL_MAX_CHAR_LITERAL_LEN
    464       #.$SQL_ACTIVE_ENVIRONMENTS
    465       )
    466      (with-temporary-allocations
    467          ((info-ptr (cffi:foreign-alloc :long))
    468           (info-length-ptr (cffi:foreign-alloc :short)))
    469        (with-error-handling
    470          (:hdbc hdbc)
    471          (SQLGetInfo hdbc info-type info-ptr 255 info-length-ptr)
    472          (cffi:mem-ref info-ptr :unsigned-long))))))
     460      #.$SQL_ACTIVE_ENVIRONMENTS)
     461     (with-temporary-allocations
     462         ((info-ptr (cffi:foreign-alloc 'sql-integer))
     463          (info-length-ptr (cffi:foreign-alloc 'sql-small-int)))
     464       (with-error-handling
     465           (:hdbc hdbc)
     466           (SQLGetInfo hdbc info-type info-ptr 0 info-length-ptr)
     467         (cffi:mem-ref info-ptr 'sql-integer))))))
    473468
    474469(defun %sql-exec-direct (sql hstmt henv hdbc)
     470  (declare (string sql))
    475471  (cffi:with-foreign-string (sql-ptr sql)
    476472    (with-error-handling
    477473        (:hstmt hstmt :henv henv :hdbc hdbc)
    478       (SQLExecDirect hstmt sql-ptr $SQL_NTS))))
    479 
    480 (defun %sql-cancel (hstmt)
    481   (with-error-handling
    482     (:hstmt hstmt)
    483     (SQLCancel hstmt)))
     474        (SQLExecDirect hstmt sql-ptr $SQL_NTS))))
    484475
    485476(defun %sql-execute (hstmt)
    486477  (with-error-handling
    487     (:hstmt hstmt)
    488     (SQLExecute hstmt)))
     478      (:hstmt hstmt)
     479      (SQLExecute hstmt)))
    489480
    490481(defun result-columns-count (hstmt)
    491482  (with-temporary-allocations
    492       ((columns-nr-ptr (cffi:foreign-alloc :short)))
     483      ((columns-nr-ptr (cffi:foreign-alloc 'sql-small-int)))
    493484    (with-error-handling (:hstmt hstmt)
    494                          (SQLNumResultCols hstmt columns-nr-ptr)
    495       (cffi:mem-ref columns-nr-ptr :short))))
     485        (SQLNumResultCols hstmt columns-nr-ptr)
     486      (cffi:mem-ref columns-nr-ptr 'sql-small-int))))
    496487
    497488(defun result-rows-count (hstmt)
    498489  (with-temporary-allocations
    499       ((row-count-ptr (cffi:foreign-alloc :long)))
     490      ((row-count-ptr (cffi:foreign-alloc 'sql-len)))
    500491    (with-error-handling (:hstmt hstmt)
    501                          (SQLRowCount hstmt row-count-ptr)
    502       (cffi:mem-ref row-count-ptr :long))))
     492        (SQLRowCount hstmt row-count-ptr)
     493      (cffi:mem-ref row-count-ptr 'sql-len))))
    503494
    504495
    … …  
    508499;; Column counting is 1-based
    509500(defun %describe-column (hstmt column-nr)
    510   (with-temporary-allocations ((column-name-ptr (alloc-chars 256))
    511                                (column-name-length-ptr (cffi:foreign-alloc :short))
    512                                (column-sql-type-ptr (cffi:foreign-alloc :short))
    513                                (column-precision-ptr (cffi:foreign-alloc :unsigned-long))
    514                                (column-scale-ptr (cffi:foreign-alloc :short))
    515                                (column-nullable-p-ptr (cffi:foreign-alloc :short)))
     501  (declare ((integer 1) column-nr))
     502  (with-temporary-allocations
     503      ((column-name-ptr (alloc-chars 256))
     504       (column-name-length-ptr (cffi:foreign-alloc 'sql-small-int))
     505       (column-sql-type-ptr (cffi:foreign-alloc 'sql-small-int))
     506       (column-precision-ptr (cffi:foreign-alloc 'sql-u-len))
     507       (column-scale-ptr (cffi:foreign-alloc 'sql-small-int))
     508       (column-nullable-p-ptr (cffi:foreign-alloc 'sql-small-int)))
    516509    (with-error-handling (:hstmt hstmt)
    517                          (SQLDescribeCol hstmt column-nr column-name-ptr 256
    518                                          column-name-length-ptr
    519                                          column-sql-type-ptr
    520                                          column-precision-ptr
    521                                          column-scale-ptr
    522                                          column-nullable-p-ptr)
     510        (SQLDescribeCol hstmt column-nr column-name-ptr 256
     511                        column-name-length-ptr
     512                        column-sql-type-ptr
     513                        column-precision-ptr
     514                        column-scale-ptr
     515                        column-nullable-p-ptr)
    523516      (values
    524517       (get-string-nts column-name-ptr)
    525        (cffi:mem-ref column-sql-type-ptr :short)
    526        (cffi:mem-ref column-precision-ptr :unsigned-long)
    527        (cffi:mem-ref column-scale-ptr :short)
    528        (cffi:mem-ref column-nullable-p-ptr :short)))))
    529 
    530 ;; parameter counting is 1-based
    531 (defun %describe-parameter (hstmt parameter-nr)
    532   (with-temporary-allocations ((column-sql-type-ptr (cffi:foreign-alloc :short))
    533                                (column-precision-ptr (cffi:foreign-alloc :long))
    534                                (column-scale-ptr (cffi:foreign-alloc :short))
    535                                (column-nullable-p-ptr (cffi:foreign-alloc :short)))
    536     (with-error-handling
    537       (:hstmt hstmt)
    538       (SQLDescribeParam hstmt parameter-nr
    539                         column-sql-type-ptr
    540                         column-precision-ptr
    541                         column-scale-ptr
    542                         column-nullable-p-ptr)
    543       (values
    544        (cffi:mem-ref column-sql-type-ptr :short)
    545        (cffi:mem-ref column-precision-ptr :unsigned-long)
    546        (cffi:mem-ref column-scale-ptr :short)
    547        (cffi:mem-ref column-nullable-p-ptr :short)))))
    548 
    549 (defun %column-attributes (hstmt column-nr descriptor-type)
    550   (with-temporary-allocations
    551       ((descriptor-info-ptr (alloc-chars  256))
    552        (descriptor-length-ptr (cffi:foreign-alloc :short))
    553        (numeric-descriptor-ptr (cffi:foreign-alloc :long)))
    554     (with-error-handling
    555       (:hstmt hstmt)
    556       (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr 256
    557                         descriptor-length-ptr
    558                         numeric-descriptor-ptr)
    559       (values
    560        (get-string-nts descriptor-info-ptr)
    561        (cffi:mem-ref numeric-descriptor-ptr :long)))))
     518       (cffi:mem-ref column-sql-type-ptr 'sql-small-int)
     519       (cffi:mem-ref column-precision-ptr 'sql-u-len)
     520       (cffi:mem-ref column-scale-ptr 'sql-small-int)
     521       (cffi:mem-ref column-nullable-p-ptr 'sql-small-int)))))
    562522
    563523
    … …  
    590550    (fetch-all-rows hstmt)))
    591551
    592 (defun %sql-data-sources (henv &key (direction :first))
    593   (with-temporary-allocations
    594       ((name-ptr (alloc-chars (1+ $SQL_MAX_DSN_LENGTH)))
    595        (name-length-ptr (cffi:foreign-alloc :short))
    596        (description-ptr (alloc-chars 1024))
    597        (description-length-ptr (cffi:foreign-alloc :short)))
    598     (let ((res (with-error-handling
    599                    (:henv henv)
    600                  (SQLDataSources henv
    601                                  (ecase direction
    602                                    (:first $SQL_FETCH_FIRST)
    603                                    (:next $SQL_FETCH_NEXT))
    604                                  name-ptr
    605                                  (1+ $SQL_MAX_DSN_LENGTH)
    606                                  name-length-ptr
    607                                  description-ptr
    608                                  1024
    609                                  description-length-ptr))))
    610       (unless (= res $SQL_NO_DATA_FOUND)
    611         (values (get-string-nts name-ptr)
    612                 (get-string-nts description-ptr))))))
    613 
    614552
    615553(defun %sql-prepare (hstmt sql)
     554  (declare (string sql))
    616555  (cffi:with-foreign-string (sql-ptr sql)
    617556    (with-error-handling (:hstmt hstmt)
    618       (SQLPrepare hstmt sql-ptr $SQL_NTS))))
    619 
    620 ;; depending on option, we return a long int or a string; string not implemented
    621 (defun get-connection-option (hdbc option)
    622   (with-temporary-allocations
    623       ((param-ptr (cffi:foreign-alloc  :long))) ;#+ignore #.(1+ $SQL_MAX_OPTION_STRING_LENGTH)))
    624     (with-error-handling (:hdbc hdbc)
    625       (SQLGetConnectOption hdbc option param-ptr)
    626       (cffi:mem-ref param-ptr :long))))
     557        (SQLPrepare hstmt sql-ptr $SQL_NTS))))
    627558
    628559(defun set-connection-option (hdbc option param)
    629560  (with-error-handling (:hdbc hdbc)
    630     (SQLSetConnectOption hdbc option param)))
     561      (SQLSetConnectOption hdbc option param)))
    631562
    632563(defun disable-autocommit (hdbc)
    … …  
    637568
    638569
    639 ***
     570;;;***
    640571;;; rav, 11.6.2005
    641572;;; added tracing support
    … …  
    643574(defun set-connection-attr-integer (hdbc option val)
    644575  (with-error-handling (:hdbc hdbc)
    645     (SQLSetConnectAttr_long hdbc option val 0)))
     576      (SQLSetConnectAttr_long hdbc option val 0)))
    646577
    647578(defun set-connection-attr-string (hdbc option val)
    648   (with-error-handling (:hdbc hdbc)
    649     (cffi:with-foreign-string (ptr val)
    650       (SQLSetConnectAttr_string hdbc option ptr (length val)))))
     579  (with-error-handling  (:hdbc hdbc)
     580      (cffi:with-foreign-string (ptr val)
     581        ;; TODO: Null-terminator with length?
     582        (SQLSetConnectAttr_string hdbc option ptr (length val)))))
    651583
    652584(defun %start-connection-trace (hdbc filename)
    … …  
    656588(defun %stop-connection-trace (hdbc)
    657589  (set-connection-attr-integer hdbc $SQL_ATTR_TRACE     $SQL_OPT_TRACE_OFF))
    658  
    659 
    660 (defun get-connection-attr-integer (hdbc attr)
    661   (with-temporary-allocations
    662       ((ptr (cffi:foreign-alloc :long))
    663        (lenptr (cffi:foreign-alloc :long)))
    664     (with-error-handling (:hdbc hdbc)
    665       (SQLGetConnectAttr hdbc attr ptr 0 lenptr))
    666     (cffi:mem-ref ptr :long)))
    667 
    668 (defun get-connection-attr-string (hdbc attr)
    669   (with-temporary-allocations
    670       ((ptr (alloc-chars 256))
    671        (lenptr (cffi:foreign-alloc :long)))
    672     (with-error-handling (:hdbc hdbc)
    673       (SQLGetConnectAttr hdbc attr ptr 256 lenptr))
    674     (get-string  ptr (cffi:mem-ref lenptr :long))))
    675 
    676 ;;; small test for the get-connection-attr
    677 (defun %get-current-catalog (hdbc)
    678   (get-connection-attr-string hdbc $SQL_ATTR_CURRENT_CATALOG))
    679 
    680 (defun %set-current-catalog (hdbc catalog)
    681   (set-connection-attr-string hdbc $SQL_ATTR_CURRENT_CATALOG catalog))
    682 
    683 
    684 
    685 (defun %connection-ok-p (hdbc)
    686   (with-error-handling (:hdbc hdbc)
    687     (ecase (get-connection-attr-integer hdbc $SQL_ATTR_CONNECTION_DEAD)
    688       (#.$sql_cd_true nil)
    689       (#.$sql_cd_false t))))
    690590
    691591;;;
    692 
    693 
    694 (defun %sql-set-pos (hstmt row option lock)
    695   (with-error-handling
    696     (:hstmt hstmt)
    697     (SQLSetPos hstmt row option lock)))
    698 
    699 (defun %sql-extended-fetch (hstmt fetch-type row)
    700   (with-temporary-allocations
    701       ((row-count-ptr (cffi:foreign-alloc :unsigned-long))
    702        (row-status-ptr (cffi:foreign-alloc :short)))
    703     (with-error-handling (:hstmt hstmt)
    704       (SQLExtendedFetch hstmt fetch-type row row-count-ptr
    705                         row-status-ptr)
    706       (values (cffi:mem-ref row-count-ptr :unsigned-long)
    707               (cffi:mem-ref row-status-ptr :short)))))
    708592
    709593; column-nr is zero-based
    710594(defun %sql-get-data (hstmt column-nr c-type data-ptr precision out-len-ptr)
    711   (with-error-handling
    712     (:hstmt hstmt :print-info nil)
    713     (SQLGetData hstmt (if (eq column-nr :bookmark) 0 (1+ column-nr))
    714                 c-type data-ptr precision out-len-ptr)))
     595  (declare ((integer 0) column-nr))
     596  (with-error-handling
     597      (:hstmt hstmt :print-info nil)
     598      (SQLGetData hstmt (if (eq column-nr :bookmark) 0 (1+ column-nr))
     599                  c-type data-ptr precision out-len-ptr)))
    715600
    716601(defun %sql-get-data-raw (hstmt position c-type data-ptr buffer-length ind-ptr)
     602  (declare ((integer 0) position))
    717603  (SQLGetData hstmt (1+ position)
    718604              c-type data-ptr buffer-length ind-ptr))
    … …  
    727613  (with-error-handling
    728614      (:hstmt hstmt :print-info t) ;; nil
    729     (SQLPutData hstmt data-ptr size)))
     615      (SQLPutData hstmt data-ptr size)))
    730616
    731617

  • 64-bit/src/odbc/odbc-main.lisp

    r1 r4  
    455455                (send-parameter-data param hstmt)))))))))
    456456
    457 ;; this functions works only, since we store at
    458 ;; value-ptr the position of the parameter
    459 (defun sql-param-data-position (hstmt) 
    460   (with-temporary-allocations
     457;; this functions works only, since we store at value-ptr the position
     458;; of the parameter
     459;; dso--
     460(defun sql-param-data-position (hstmt)
     461  (with-temporary-allocations
    461462      ((ptr (cffi:foreign-alloc :pointer)))
    462     (let ((res (with-error-handling (:hstmt hstmt) (%sql-param-data hstmt ptr))))
    463       (values res (if (= res $SQL_NEED_DATA)
    464                     (cffi:mem-ref (cffi:mem-ref ptr :pointer) :long  ))))))
     463    (let ((res (with-error-handling (:hstmt hstmt)
     464                   (%sql-param-data hstmt ptr))))
     465      (values res (if (= res $SQL_NEED_DATA)
     466                      (cffi:mem-ref (cffi:mem-ref ptr :pointer) :int32))))))
     467                                        ; TODO: The :int32 above
     468                                        ; should probably be changed!
    465469
    466470(defmethod exec-prepared-query ((query prepared-statement) &rest parameters)

  • 64-bit/src/odbc/parameter.lisp

    r1 r7  
    5555
    5656(defun bind-parameter (hstmt pos param)
    57   (setf (slot-value param 'ind-ptr) 
    58           (cffi:foreign-alloc :long))
    59   (%sql-bind-parameter 
     57  (setf (slot-value param 'ind-ptr)
     58        (cffi:foreign-alloc 'sql-len))
     59  (%sql-bind-parameter
    6060   hstmt
    6161   pos
    … …  
    110110  (cond
    111111    ((null value)
    112       (setf  (cffi:mem-ref (slot-value param 'ind-ptr) :long)
    113               $SQL_NULL_DATA)
    114       (put-string (slot-value param 'value-ptr) ""))
    115     (t
    116       (cffi:lisp-string-to-foreign value (slot-value param 'value-ptr) (1+ (length value)))
    117       (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
    118               (length  value)))))
     112     (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
     113           $SQL_NULL_DATA)
     114     (put-string (slot-value param 'value-ptr) ""))
     115    (t
     116     (cffi:lisp-string-to-foreign value
     117                                  (slot-value param 'value-ptr)
     118                                  (1+ (length value)))
     119     (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
     120           (length value)))))
    119121
    120122(defmethod get-parameter-value ((param string-parameter))
    121   (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) :long)))
     123  (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)))
    122124    (if (= len $SQL_NULL_DATA)
    123       nil
    124       (progn
    125         (get-string (slot-value param 'value-ptr) len)))))
     125        nil
     126        (progn
     127          (get-string (slot-value param 'value-ptr) len)))))
    126128
    127129;;------------------------
    … …  
    132134
    133135(defmethod initialize-parameter ((param unicode-string-parameter) args)
    134   (let ((length-of-buffer (* 2 (or (car args) *default-string-parameter-size*))))
     136  (let ((length-of-buffer
     137         (* 2 (or (car args) *default-string-parameter-size*))))
    135138    (with-slots (value-type parameter-type buffer-length
    136139                            column-size value-ptr
    … …  
    145148  (cond
    146149    ((null value)
    147       (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
    148               $SQL_NULL_DATA)
    149       ;; not necessary
    150       (%put-unicode-string (slot-value param 'value-ptr) ""))
    151     (t 
    152       (%put-unicode-string (slot-value param 'value-ptr) value)
    153       (setf  (cffi:mem-ref (slot-value param 'ind-ptr) :long)
    154               (* 2 (length value))))))
     150     (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
     151           $SQL_NULL_DATA)
     152     ;; not necessary
     153     (%put-unicode-string (slot-value param 'value-ptr) ""))
     154    (t
     155     (%put-unicode-string (slot-value param 'value-ptr) value)
     156     (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
     157           (* 2 (length value))))))
    155158
    156159(defmethod get-parameter-value ((param unicode-string-parameter))
    157   (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) :long)))
     160  (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)))
    158161    (if (= len $SQL_NULL_DATA)
    159       nil
    160       (progn
    161         (%get-unicode-string (slot-value param 'value-ptr) len)))))
     162        nil
     163        (progn
     164          (%get-unicode-string (slot-value param 'value-ptr) len)))))
    162165
    163166;;----------------------
    … …  
    174177    (setf value-type $SQL_C_LONG)
    175178    (setf parameter-type $SQL_INTEGER)
    176     (setf buffer-length 4)
    177     (setf value-ptr (cffi:foreign-alloc :long))))
     179    (setf buffer-length (cffi:foreign-type-size 'sql-integer))
     180    (setf value-ptr (cffi:foreign-alloc 'sql-integer))))
    178181
    179182(defmethod set-parameter-value ((param integer-parameter) value)
    180   (cond 
     183  (cond
    181184    ((null value)
    182       (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
    183               $SQL_NULL_DATA))
    184     (t (setf (cffi:mem-ref (slot-value param 'value-ptr) :long)
    185                value)
    186       (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) 0))))
     185     (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
     186           $SQL_NULL_DATA))
     187    (t (setf (cffi:mem-ref (slot-value param 'value-ptr) 'sql-integer)
     188             value)
     189       (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) 0))))
    187190
    188191(defmethod get-parameter-value ((param integer-parameter))
    189   (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) :long)))
     192  (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)))
    190193    (if (= len $SQL_NULL_DATA)
    191       nil
    192       (progn
    193         (cffi:mem-ref (slot-value param 'value-ptr) :long)))))
     194        nil
     195        (progn
     196          (cffi:mem-ref (slot-value param 'value-ptr) 'sql-integer)))))
    194197
    195198
    … …  
    203206(defmethod initialize-parameter ((param double-parameter) args)
    204207  (assert (not args))
    205    (with-slots (value-type parameter-type buffer-length value-ptr
    206                            ind-ptr) param
    207      (setf value-type $SQL_C_DOUBLE)
    208      (setf parameter-type $SQL_DOUBLE)
    209      (setf buffer-length 8)
    210      (setf value-ptr (cffi:foreign-alloc :double ))))
     208  (with-slots (value-type parameter-type buffer-length value-ptr
     209                          ind-ptr) param
     210    (setf value-type $SQL_C_DOUBLE)
     211    (setf parameter-type $SQL_DOUBLE)
     212    (setf buffer-length (cffi:foreign-type-size :double))
     213    (setf value-ptr (cffi:foreign-alloc :double))))
    211214
    212215(defmethod set-parameter-value ((param double-parameter) value)
    213    (cond 
    214      ((null value)
    215        (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
    216                $SQL_NULL_DATA))
    217      (t
    218        (setf (cffi:mem-ref (slot-value param 'value-ptr) :double)
    219                (coerce value 'double-float))
    220        (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) 8))))
     216  (cond
     217    ((null value)
     218     (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
     219           $SQL_NULL_DATA))
     220    (t
     221     (setf (cffi:mem-ref (slot-value param 'value-ptr) :double)
     222           (coerce value 'double-float))
     223     (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
     224           (cffi:foreign-type-size :double)))))
    221225
    222226(defmethod get-parameter-value ((param double-parameter))
    223     (if (= (cffi:mem-ref (slot-value param 'ind-ptr) :long) $SQL_NULL_DATA)
     227  (if (= (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) $SQL_NULL_DATA)
    224228      nil
    225229      (cffi:mem-ref (slot-value param 'value-ptr) :double)))
    … …  
    242246     (setf value-ptr (cffi:foreign-alloc :uchar :count 24))))
    243247
    244 
    245248(defmethod set-parameter-value ((param date-parameter) value)
    246249  (if (null value)
    247     (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
     250      (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
    248251            $SQL_NULL_DATA)
    249     (progn
    250       ;; fixme warum 1?
    251       (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) 1)
    252       (multiple-value-bind (sec min hour day month year)
    253           (decode-universal-time 
    254            (funcall *date-datatype-to-universal-time* value))
    255         (%put-sql-c-timestamp (slot-value param 'value-ptr) year month day hour min sec 0)))))
     252      (progn
     253        ;; fixme warum 1?
     254        (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) 1)
     255        (multiple-value-bind (sec min hour day month year)
     256            (decode-universal-time
     257             (funcall *date-datatype-to-universal-time* value))
     258          (%put-sql-c-timestamp (slot-value param 'value-ptr) year month day hour min sec 0)))))
    256259
    257260(defmethod get-parameter-value ((param date-parameter))
    258   (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) :long)))
    259     (if (= len $SQL_NULL_DATA) 
    260       nil
    261       (funcall *universal-time-to-date-dataype*
    262                 (timestamp-to-universal-time (slot-value param 'value-ptr))))))
     261  (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)))
     262    (if (= len $SQL_NULL_DATA)
     263        nil
     264        (funcall *universal-time-to-date-dataype*
     265                 (timestamp-to-universal-time (slot-value param 'value-ptr))))))
    263266
    264267
    … …  
    280283
    281284(defmethod set-parameter-value ((param binary-parameter) value)
    282 (if (null value)
    283   (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
    284           $SQL_NULL_DATA)
    285     (if (< (slot-value param 'buffer-length) (length value))
    286       (progn
    287         (error "buffer is to small")
    288         ; we could increase the buffer size with another bind parameter
    289         ; or set data_at_execution =1
    290         )
    291       (progn
    292         ;(break)
    293         (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
    294                 (length value))
    295         (put-byte-vector (slot-value param 'value-ptr) value)))))
     285  (if (null value)
     286      (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
     287            $SQL_NULL_DATA)
     288      (if (< (slot-value param 'buffer-length) (length value))
     289          (progn
     290            (error "buffer is to small")
     291            ;; we could increase the buffer size with another bind
     292            ;; parameter or set data_at_execution =1
     293            )
     294          (progn
     295            ;; (break)
     296            (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
     297                  (length value))
     298            (put-byte-vector (slot-value param 'value-ptr) value)))))
    296299
    297300
    298301(defmethod get-parameter-value ((param binary-parameter))
    299   (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) :long)))
     302  (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)))
    300303    (if (= len $SQL_NULL_DATA)
    301       nil
    302       (get-byte-vector (slot-value param 'value-ptr) len))))
     304        nil
     305        (get-byte-vector (slot-value param 'value-ptr) len))))
    303306
    304307
    … …  
    323326    ;; the value-ptr will be needed to find the parameter, 
    324327    ;; we store the position there
    325     (setf buffer-length 4)
    326     (setf value-ptr (cffi:foreign-alloc :long))))
     328    (setf buffer-length (cffi:foreign-type-size 'sql-pointer))
     329    (setf value-ptr (cffi:foreign-alloc 'sql-pointer))))
    327330
    328331(defmethod set-parameter-value ((param clob-parameter) value)
    329332  (if (null value)
    330     (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
     333      (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
    331334            $SQL_NULL_DATA)
    332     (progn
    333       (setf (slot-value param 'temp-val) value)
    334       (setf (cffi:mem-ref (slot-value param 'value-ptr) :long)
    335                                 (slot-value param 'position))
    336       (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
     335      (progn
     336        (setf (slot-value param 'temp-val) value)
     337        (setf (cffi:mem-ref (slot-value param 'value-ptr) 'sql-pointer)
     338              (slot-value param 'position))
     339        (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
    337340              (%sql-len-data-at-exec (length value))))))
    338341
    … …  
    373376    ;; the value-ptr will be needed to find the parameter, 
    374377    ;; we store the position there
    375     (setf buffer-length 4)
    376     (setf value-ptr (cffi:foreign-alloc :long))))
     378    (setf buffer-length (cffi:foreign-type-size 'sql-pointer))
     379    (setf value-ptr (cffi:foreign-alloc 'sql-pointer))))
    377380
    378381(defmethod set-parameter-value ((param uclob-parameter) value)
    379382  (if (null value)
    380     (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
     383    (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
    381384            $SQL_NULL_DATA)
    382385    (progn
    383386      (setf (slot-value param 'temp-val) value)
    384       (setf (cffi:mem-ref (slot-value param 'value-ptr) :long)
     387      (setf (cffi:mem-ref (slot-value param 'value-ptr) 'sql-pointer)
    385388              (slot-value param 'position))
    386       (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
     389      (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
    387390                 (%sql-len-data-at-exec (* 2 (length value)))))))
    388391
    … …  
    422425    ;; the value-ptr will be needed to find the parameter,
    423426    ;; we store the position there
    424     (setf buffer-length 4)
    425     (setf value-ptr (cffi:foreign-alloc :long))))
     427    (setf buffer-length (cffi:foreign-type-size 'sql-pointer))
     428    (setf value-ptr (cffi:foreign-alloc 'sql-pointer))))
    426429
    427430(defmethod set-parameter-value ((param blob-parameter) value)
    428431  (if (null value)
    429     (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
     432    (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
    430433            $SQL_NULL_DATA)
    431434    (progn
    432435      (setf (slot-value param 'temp-val) value)
    433       (setf (cffi:mem-ref (slot-value param 'value-ptr) :long)
     436      (setf (cffi:mem-ref (slot-value param 'value-ptr) 'sql-pointer)
    434437              (slot-value param 'position))
    435       (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)
     438      (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len)
    436439              (%sql-len-data-at-exec (length value))))))
    437440
Note: See TracChangeset for help on using the changeset viewer.