Changes in 64-bit [64-bit,2:64-bit,8]
- Location:
- 64-bit/src/odbc
- Files:
-
- 6 edited
Legend:
- Unmodified
- Added
- Removed
-
64-bit/src/odbc/cffi-support.lisp
r1 r3 8 8 9 9 (defun get-string-nts (ptr) 10 (cffi:foreign-string-to-lisp ptr MOST-POSITIVE-FIXNUM 10 (cffi:foreign-string-to-lisp ptr MOST-POSITIVE-FIXNUM t)) 11 11 12 12 (defun put-string (ptr vector) -
64-bit/src/odbc/column.lisp
r1 r8 77 77 column 78 78 ;(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)) 80 80 (%bind-column hstmt 81 81 pos … … 113 113 114 114 (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))) 116 116 (if (= len $SQL_NULL_DATA) 117 nil118 (progn119 (get-string (slot-value column 'value-ptr) len)))))117 nil 118 (progn 119 (get-string (slot-value column 'value-ptr) len))))) 120 120 ;;;------------------- 121 121 ;;; unicode-string … … 147 147 148 148 (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))) 150 150 ;; len is size in bytes, not characters! 151 151 (if (= len $SQL_NULL_DATA) 152 nil153 (progn154 ;(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)))))) 156 156 157 157 … … 166 166 (declare (ignore args)) 167 167 (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))) 172 172 173 173 174 174 (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))) 176 176 (if (= len $SQL_NULL_DATA) 177 nil178 (cffi:mem-ref (slot-value column 'value-ptr) :long))))177 nil 178 (cffi:mem-ref (slot-value column 'value-ptr) 'sql-integer)))) 179 179 180 180 … … 193 193 194 194 (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 199 nil200 (progn201 (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))))) 202 202 203 203 ;;;------------------------ … … 214 214 215 215 (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))) 217 217 (if (= len $SQL_NULL_DATA) 218 nil219 (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)))))) 221 221 222 222 ;;;-------------------------- … … 241 241 242 242 (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))) 244 244 (if (= len $SQL_NULL_DATA) 245 245 nil … … 260 260 261 261 (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 nil265 (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))))) 266 266 267 267 ;;;---------------------------- … … 313 313 314 314 (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))) 316 316 (if (= len $SQL_NULL_DATA) 317 nil318 (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 sum324 (if (zerop (aref bytes 2)) -1 1) ;sign325 (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)))))))) 326 326 327 327 … … 341 341 (let* ((value-ptr (cffi:foreign-alloc :char 342 342 :count (slot-value column 'buffer-length))) 343 (ind-ptr (cffi:foreign-alloc :long)))343 (ind-ptr (cffi:foreign-alloc 'sql-len))) 344 344 (unwind-protect 345 345 (get-character-data … … 365 365 (defmethod get-column-value ((column uclob-column)) 366 366 (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))) 368 368 (unwind-protect 369 369 (get-unicode-character-data … … 389 389 (defmethod get-column-value ((column blob-column)) 390 390 (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))) 392 392 (unwind-protect 393 393 (get-binary-data … … 423 423 ind-ptr))) 424 424 (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) 427 427 (cond 428 428 ((= 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 431 432 ((and (/= len $SQL_NO_TOTAL) 432 433 (<= (+ 1 len) buffer-length)) 433 434 434 ;; the data fits into the buffer, return it 435 (get-string value-ptr len)) 435 436 436 437 ;; we have to fetch the data in several steps 437 438 (t 438 439 440 441 442 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")) 443 444 ;; an 0 byte is append to a string, ignore that 444 445 … … 446 447 (write-string str sos) 447 448 (setf sqlret (%sql-get-data-raw hstmt 448 position449 $SQL_C_CHAR450 value-ptr451 buffer-length452 ind-ptr))449 position 450 $SQL_C_CHAR 451 value-ptr 452 buffer-length 453 ind-ptr)) 453 454 (handle-error sqlret)) 454 455 (return))) 455 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)))))))) 460 461 461 462 ;;; the version for 16bit unicode 462 463 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) 464 466 ;; local error handling, we can not use the general error handling 465 467 ;; since this resets the sql-state … … 481 483 ind-ptr))) 482 484 (handle-error sqlret) 483 (let ((len (cffi:mem-ref ind-ptr :long)))485 (let ((len (cffi:mem-ref ind-ptr 'sql-len))) 484 486 (cond 485 487 ((= 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 488 491 ((and (/= len $SQL_NO_TOTAL) 489 492 (<= (+ 2 len) buffer-length)) 490 491 493 ;; the data fits into the buffer, return it 494 (%get-unicode-string value-ptr len)) 492 495 493 496 ;; we have to fetch the data in several steps 494 497 (t 495 496 497 498 499 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")) 500 503 ;; an 0 byte is append to a string, ignore that 501 504 502 (let ((str (%get-unicode-string value-ptr (- buffer-length 2)))) 505 (let ((str 506 (%get-unicode-string value-ptr (- buffer-length 2)))) 503 507 (write-string str sos) 504 508 (setf sqlret (%sql-get-data-raw hstmt 505 position506 $SQL_C_WCHAR507 value-ptr508 buffer-length509 ind-ptr))509 position 510 $SQL_C_WCHAR 511 value-ptr 512 buffer-length 513 ind-ptr)) 510 514 (handle-error sqlret)) 511 515 (return))) 512 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)))))))) 517 521 518 522 (defun get-binary-data (hstmt position value-ptr buffer-length ind-ptr) … … 530 534 (error condition))))) 531 535 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")) 548 554 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 hstmt554 position555 $SQL_C_BINARY556 value-ptr557 buffer-length558 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))) 561 567 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 18 18 (load-foreign-library :odbc) 19 19 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 20 40 (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 48 169 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 264 219 265 220 … … 277 232 ; driver-specific value, the value in ValuePtr may be a signed integer. 278 233 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))) 332 253 333 254 334 255 ;;; foreign type definitions 335 256 336 337 (hour :short)338 (minute :short)339 (second :short))340 341 342 (year :short)343 (month :short)344 (day :short))345 346 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)) 354 275 355 276 (defun %put-sql-c-date (adr %year %month %day) … … 358 279 (setf (foreign-slot-value adr 'sql-c-date 'day) %day)) 359 280 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) 362 284 (setf (foreign-slot-value adr 'sql-c-timestamp 'second) %second) 363 285 (setf (foreign-slot-value adr 'sql-c-timestamp 'minute) %minute) … … 366 288 (setf (foreign-slot-value adr 'sql-c-timestamp 'month) %month) 367 289 (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)) 370 291 371 292 (defun timestamp-to-universal-time (adr) 372 (with-foreign-slots 293 (with-foreign-slots 373 294 ((year month day hour minute second fraction) adr sql-c-timestamp) 374 295 (values … … 379 300 day 380 301 month 381 year 302 year) 382 303 fraction))) 383 304 384 305 385 306 (defun date-to-universal-time (adr) 386 (with-foreign-slots 307 (with-foreign-slots 387 308 ((year month day) adr sql-c-date) 388 309 (encode-universal-time 389 390 391 392 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) 396 317 `(- $SQL_LEN_DATA_AT_EXEC_OFFSET ,length)) -
64-bit/src/odbc/odbc-functions.lisp
r1 r6 17 17 `(let (,@allocs) 18 18 (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 23 24 24 25 … … 44 45 ()) 45 46 47 ;; TODO: Why doesn't this use with-temporary-allocations? -dso 46 48 (defun handle-error (henv hdbc hstmt) 47 48 49 50 (error-code (cffi:foreign-alloc :long))51 (msg-length (cffi:foreign-alloc :short)))52 (SQLError henv53 hdbc54 55 56 57 58 59 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)))) 62 64 63 65 … … 67 69 ;#+ignore 68 70 (defun sql-state (henv hdbc hstmt) 69 (with-temporary-allocations 71 (with-temporary-allocations 70 72 ((sql-state (cffi:foreign-alloc :char :count 256)) 71 73 (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))) 74 76 (SQLError henv hdbc hstmt sql-state error-code 75 77 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) 77 79 )) 78 80 … … 165 167 166 168 (defun %new-environment-handle () 167 (cffi:with-foreign-object (phenv 'sql-h andle)169 (cffi:with-foreign-object (phenv 'sql-h-env) 168 170 (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)))) 178 174 179 175 (defun %new-db-connection-handle (henv) 180 (cffi:with-foreign-object (phdbc 'sql-h andle)176 (cffi:with-foreign-object (phdbc 'sql-h-dbc) 181 177 (with-error-handling 182 178 (:henv henv) 183 (SQLAllocConnect henv phdbc)184 (cffi:mem-ref phdbc 'sql-h andle))))179 (SQLAllocConnect henv phdbc) 180 (cffi:mem-ref phdbc 'sql-h-dbc)))) 185 181 186 182 (defun %free-statement (hstmt option) 187 (with-error-handling 183 (with-error-handling 188 184 (:hstmt hstmt) 189 (SQLFreeStmt 190 hstmt 185 (SQLFreeStmt 186 hstmt 191 187 (ecase option 192 188 (:drop $SQL_DROP) … … 217 213 ;; functional interface 218 214 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-handling224 (:hdbc hdbc)225 (SQLConnect hdbc server-ptr $SQL_NTS uid-ptr226 $SQL_NTS pwd-ptr $SQL_NTS))))))227 228 215 ;; 229 216 (defun %sql-driver-connect (henv hdbc connection-string completion-option) 217 (declare (string connection-string)) 230 218 (let ((completion-option 231 219 (ecase completion-option … … 234 222 (:prompt $SQL_DRIVER_PROMPT) 235 223 (:noprompt $SQL_DRIVER_NOPROMPT)))) 236 (cffi:with-foreign-string (connection-str-ptr 224 (cffi:with-foreign-string (connection-str-ptr connection-string) 237 225 (with-temporary-allocations 238 226 ((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 241 229 (: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)) 252 241 (get-string-nts complete-connection-str-ptr))))) 253 242 254 243 (defun %disconnect (hdbc) 255 (with-error-handling 256 (:hdbc hdbc)257 (SQLDisconnect hdbc)))244 (with-error-handling 245 (:hdbc hdbc) 246 (SQLDisconnect hdbc))) 258 247 259 248 (defun %commit (henv hdbc) 260 (with-error-handling 261 (:henv henv :hdbc hdbc)262 (SQLTransact263 henv hdbc $SQL_COMMIT)))249 (with-error-handling 250 (:henv henv :hdbc hdbc) 251 (SQLTransact 252 henv hdbc $SQL_COMMIT))) 264 253 265 254 (defun %rollback (henv hdbc) 266 (with-error-handling 267 (:henv henv :hdbc hdbc)268 (SQLTransact269 henv hdbc $SQL_ROLLBACK)))255 (with-error-handling 256 (:henv henv :hdbc hdbc) 257 (SQLTransact 258 henv hdbc $SQL_ROLLBACK))) 270 259 271 260 ; col-nr is zero-based in Lisp 272 261 ; col-nr = :bookmark retrieves a bookmark. 273 262 (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))) 279 269 280 270 ; parameter-nr is zero-based in Lisp 281 271 (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 ))) 296 287 297 288 (defun %sql-fetch (hstmt) … … 301 292 302 293 (defun %new-statement-handle (hdbc) 303 (with-temporary-allocations 304 ((hstmt-ptr (cffi:foreign-alloc 'sql-h andle)))305 (with-error-handling 294 (with-temporary-allocations 295 ((hstmt-ptr (cffi:foreign-alloc 'sql-h-stmt))) 296 (with-error-handling 306 297 (:hdbc hdbc) 307 (SQLAllocStmt hdbc hstmt-ptr)308 (cffi:mem-ref hstmt-ptr 'sql-h andle))))298 (SQLAllocStmt hdbc hstmt-ptr) 299 (cffi:mem-ref hstmt-ptr 'sql-h-stmt)))) 309 300 310 301 (defun %sql-get-info (hdbc info-type) … … 344 335 #.$SQL_TABLE_TERM 345 336 #.$SQL_USER_NAME) 346 (with-temporary-allocations 337 (with-temporary-allocations 347 338 ((info-ptr (alloc-chars 1024)) 348 (info-length-ptr (cffi:foreign-alloc :short)))349 (with-error-handling 350 (:hdbc hdbc)351 339 (info-length-ptr (cffi:foreign-alloc 'sql-small-int))) 340 (with-error-handling 341 (:hdbc hdbc) 342 #-pcl 352 343 (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr) 353 344 #+pcl 354 345 (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. 355 348 (get-string-nts info-ptr)))) 356 ;; those returning a word349 ;; those returning a 16-bit integer 357 350 ((#.$SQL_ACTIVE_CONNECTIONS 358 351 #.$SQL_ACTIVE_STATEMENTS … … 383 376 #.$SQL_TXN_CAPABLE) 384 377 (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 398 390 #.$SQL_BOOKMARK_PERSISTENCE 399 391 #.$SQL_CONVERT_BIGINT … … 440 432 #.$SQL_TXN_ISOLATION_OPTION 441 433 #.$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 455 451 ((#.$SQL_DEFAULT_TXN_ISOLATION 456 452 #.$SQL_DRIVER_HDBC … … 462 458 #.$SQL_MAX_BINARY_LITERAL_LEN 463 459 #.$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)))))) 473 468 474 469 (defun %sql-exec-direct (sql hstmt henv hdbc) 470 (declare (string sql)) 475 471 (cffi:with-foreign-string (sql-ptr sql) 476 472 (with-error-handling 477 473 (: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)))) 484 475 485 476 (defun %sql-execute (hstmt) 486 477 (with-error-handling 487 (:hstmt hstmt)488 (SQLExecute hstmt)))478 (:hstmt hstmt) 479 (SQLExecute hstmt))) 489 480 490 481 (defun result-columns-count (hstmt) 491 482 (with-temporary-allocations 492 ((columns-nr-ptr (cffi:foreign-alloc :short)))483 ((columns-nr-ptr (cffi:foreign-alloc 'sql-small-int))) 493 484 (with-error-handling (:hstmt hstmt) 494 495 (cffi:mem-ref columns-nr-ptr :short))))485 (SQLNumResultCols hstmt columns-nr-ptr) 486 (cffi:mem-ref columns-nr-ptr 'sql-small-int)))) 496 487 497 488 (defun result-rows-count (hstmt) 498 489 (with-temporary-allocations 499 ((row-count-ptr (cffi:foreign-alloc :long)))490 ((row-count-ptr (cffi:foreign-alloc 'sql-len))) 500 491 (with-error-handling (:hstmt hstmt) 501 502 (cffi:mem-ref row-count-ptr :long))))492 (SQLRowCount hstmt row-count-ptr) 493 (cffi:mem-ref row-count-ptr 'sql-len)))) 503 494 504 495 … … 508 499 ;; Column counting is 1-based 509 500 (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))) 516 509 (with-error-handling (:hstmt hstmt) 517 518 519 520 521 522 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) 523 516 (values 524 517 (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))))) 562 522 563 523 … … 590 550 (fetch-all-rows hstmt))) 591 551 592 (defun %sql-data-sources (henv &key (direction :first))593 (with-temporary-allocations594 ((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-handling599 (:henv henv)600 (SQLDataSources henv601 (ecase direction602 (:first $SQL_FETCH_FIRST)603 (:next $SQL_FETCH_NEXT))604 name-ptr605 (1+ $SQL_MAX_DSN_LENGTH)606 name-length-ptr607 description-ptr608 1024609 description-length-ptr))))610 (unless (= res $SQL_NO_DATA_FOUND)611 (values (get-string-nts name-ptr)612 (get-string-nts description-ptr))))))613 614 552 615 553 (defun %sql-prepare (hstmt sql) 554 (declare (string sql)) 616 555 (cffi:with-foreign-string (sql-ptr sql) 617 556 (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)))) 627 558 628 559 (defun set-connection-option (hdbc option param) 629 560 (with-error-handling (:hdbc hdbc) 630 (SQLSetConnectOption hdbc option param)))561 (SQLSetConnectOption hdbc option param))) 631 562 632 563 (defun disable-autocommit (hdbc) … … 637 568 638 569 639 ***570 ;;;*** 640 571 ;;; rav, 11.6.2005 641 572 ;;; added tracing support … … 643 574 (defun set-connection-attr-integer (hdbc option val) 644 575 (with-error-handling (:hdbc hdbc) 645 (SQLSetConnectAttr_long hdbc option val 0)))576 (SQLSetConnectAttr_long hdbc option val 0))) 646 577 647 578 (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))))) 651 583 652 584 (defun %start-connection-trace (hdbc filename) … … 656 588 (defun %stop-connection-trace (hdbc) 657 589 (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-allocations662 ((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-allocations670 ((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-attr677 (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))))690 590 691 591 ;;; 692 693 694 (defun %sql-set-pos (hstmt row option lock)695 (with-error-handling696 (:hstmt hstmt)697 (SQLSetPos hstmt row option lock)))698 699 (defun %sql-extended-fetch (hstmt fetch-type row)700 (with-temporary-allocations701 ((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-ptr705 row-status-ptr)706 (values (cffi:mem-ref row-count-ptr :unsigned-long)707 (cffi:mem-ref row-status-ptr :short)))))708 592 709 593 ; column-nr is zero-based 710 594 (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))) 715 600 716 601 (defun %sql-get-data-raw (hstmt position c-type data-ptr buffer-length ind-ptr) 602 (declare ((integer 0) position)) 717 603 (SQLGetData hstmt (1+ position) 718 604 c-type data-ptr buffer-length ind-ptr)) … … 727 613 (with-error-handling 728 614 (:hstmt hstmt :print-info t) ;; nil 729 (SQLPutData hstmt data-ptr size)))615 (SQLPutData hstmt data-ptr size))) 730 616 731 617 -
64-bit/src/odbc/odbc-main.lisp
r1 r4 455 455 (send-parameter-data param hstmt))))))))) 456 456 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 461 462 ((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! 465 469 466 470 (defmethod exec-prepared-query ((query prepared-statement) &rest parameters) -
64-bit/src/odbc/parameter.lisp
r1 r7 55 55 56 56 (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 60 60 hstmt 61 61 pos … … 110 110 (cond 111 111 ((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))))) 119 121 120 122 (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))) 122 124 (if (= len $SQL_NULL_DATA) 123 nil124 (progn125 (get-string (slot-value param 'value-ptr) len)))))125 nil 126 (progn 127 (get-string (slot-value param 'value-ptr) len))))) 126 128 127 129 ;;------------------------ … … 132 134 133 135 (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*)))) 135 138 (with-slots (value-type parameter-type buffer-length 136 139 column-size value-ptr … … 145 148 (cond 146 149 ((null value) 147 (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)148 149 150 151 (t 152 153 (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)154 (* 2 (lengthvalue))))))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)))))) 155 158 156 159 (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))) 158 161 (if (= len $SQL_NULL_DATA) 159 nil160 (progn161 (%get-unicode-string (slot-value param 'value-ptr) len)))))162 nil 163 (progn 164 (%get-unicode-string (slot-value param 'value-ptr) len))))) 162 165 163 166 ;;---------------------- … … 174 177 (setf value-type $SQL_C_LONG) 175 178 (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)))) 178 181 179 182 (defmethod set-parameter-value ((param integer-parameter) value) 180 (cond 183 (cond 181 184 ((null value) 182 (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long)183 184 (t (setf (cffi:mem-ref (slot-value param 'value-ptr) :long)185 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)))) 187 190 188 191 (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))) 190 193 (if (= len $SQL_NULL_DATA) 191 nil192 (progn193 (cffi:mem-ref (slot-value param 'value-ptr) :long)))))194 nil 195 (progn 196 (cffi:mem-ref (slot-value param 'value-ptr) 'sql-integer))))) 194 197 195 198 … … 203 206 (defmethod initialize-parameter ((param double-parameter) args) 204 207 (assert (not args)) 205 206 207 208 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)))) 211 214 212 215 (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))))) 221 225 222 226 (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) 224 228 nil 225 229 (cffi:mem-ref (slot-value param 'value-ptr) :double))) … … 242 246 (setf value-ptr (cffi:foreign-alloc :uchar :count 24)))) 243 247 244 245 248 (defmethod set-parameter-value ((param date-parameter) value) 246 249 (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) 248 251 $SQL_NULL_DATA) 249 (progn250 ;; 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-time254 (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))))) 256 259 257 260 (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 nil261 (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)))))) 263 266 264 267 … … 280 283 281 284 (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 (progn287 (error "buffer is to small")288 ; we could increase the buffer size with another bind parameter289 ;or set data_at_execution =1290 )291 (progn292 ;(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))))) 296 299 297 300 298 301 (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))) 300 303 (if (= len $SQL_NULL_DATA) 301 nil302 (get-byte-vector (slot-value param 'value-ptr) len))))304 nil 305 (get-byte-vector (slot-value param 'value-ptr) len)))) 303 306 304 307 … … 323 326 ;; the value-ptr will be needed to find the parameter, 324 327 ;; 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)))) 327 330 328 331 (defmethod set-parameter-value ((param clob-parameter) value) 329 332 (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) 331 334 $SQL_NULL_DATA) 332 (progn333 (setf (slot-value param 'temp-val) value)334 (setf (cffi:mem-ref (slot-value param 'value-ptr) :long)335 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) 337 340 (%sql-len-data-at-exec (length value)))))) 338 341 … … 373 376 ;; the value-ptr will be needed to find the parameter, 374 377 ;; 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)))) 377 380 378 381 (defmethod set-parameter-value ((param uclob-parameter) value) 379 382 (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) 381 384 $SQL_NULL_DATA) 382 385 (progn 383 386 (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) 385 388 (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) 387 390 (%sql-len-data-at-exec (* 2 (length value))))))) 388 391 … … 422 425 ;; the value-ptr will be needed to find the parameter, 423 426 ;; 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)))) 426 429 427 430 (defmethod set-parameter-value ((param blob-parameter) value) 428 431 (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) 430 433 $SQL_NULL_DATA) 431 434 (progn 432 435 (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) 434 437 (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) 436 439 (%sql-len-data-at-exec (length value)))))) 437 440
Note: See TracChangeset
for help on using the changeset viewer.