Index: combined/src/odbc/cffi-support.lisp =================================================================== --- combined/src/odbc/cffi-support.lisp (revision combined,1) +++ combined/src/odbc/cffi-support.lisp (revision combined,3) @@ -8,5 +8,5 @@ (defun get-string-nts (ptr) - (cffi:foreign-string-to-lisp ptr MOST-POSITIVE-FIXNUM t)) + (cffi:foreign-string-to-lisp ptr MOST-POSITIVE-FIXNUM t)) (defun put-string (ptr vector) Index: combined/src/odbc/column.lisp =================================================================== --- combined/src/odbc/column.lisp (revision combined,1) +++ combined/src/odbc/column.lisp (revision combined,3) @@ -77,5 +77,5 @@ column ;(setf value-ptr (cffi:foreign-alloc :long buffer-length)) - (setf ind-ptr (cffi:foreign-alloc :long)) + (setf ind-ptr (cffi:foreign-alloc 'sql-len)) (%bind-column hstmt pos @@ -113,9 +113,9 @@ (defmethod get-column-value ((column string-column)) - (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long))) + (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) (if (= len $SQL_NULL_DATA) - nil - (progn - (get-string (slot-value column 'value-ptr) len))))) + nil + (progn + (get-string (slot-value column 'value-ptr) len))))) ;;;------------------- ;;; unicode-string @@ -147,11 +147,11 @@ (defmethod get-column-value ((column unicode-string-column)) - (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long))) + (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) ;; len is size in bytes, not characters! (if (= len $SQL_NULL_DATA) - nil - (progn -; (break) - (wchar-bytes-to-string (get-byte-vector (slot-value column 'value-ptr) len)))))) + nil + (progn + ;; (break) + (wchar-bytes-to-string (get-byte-vector (slot-value column 'value-ptr) len)))))) @@ -166,15 +166,15 @@ (declare (ignore args)) (setf (slot-value column 'c-type) $SQL_C_SLONG) - (setf (slot-value column 'buffer-length) - (cffi:foreign-type-size :long)) - (setf (slot-value column 'value-ptr) - (cffi:foreign-alloc :long))) + (setf (slot-value column 'buffer-length) + (cffi:foreign-type-size 'sql-integer)) + (setf (slot-value column 'value-ptr) + (cffi:foreign-alloc 'sql-integer))) (defmethod get-column-value ((column integer-column)) - (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long))) + (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) (if (= len $SQL_NULL_DATA) - nil - (cffi:mem-ref (slot-value column 'value-ptr) :long)))) + nil + (cffi:mem-ref (slot-value column 'value-ptr) 'sql-integer)))) @@ -193,11 +193,11 @@ (defmethod get-column-value ((column double-column)) - ;(%get-long (slot-value column 'ind-ptr)) - ;(%get-double-float (slot-value column 'value-ptr)) - (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long))) - (if (= len $SQL_NULL_DATA) - nil - (progn - (cffi:mem-ref (slot-value column 'value-ptr) :double))))) + ;; (%get-long (slot-value column 'ind-ptr)) + ;; (%get-double-float (slot-value column 'value-ptr)) + (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) + (if (= len $SQL_NULL_DATA) + nil + (progn + (cffi:mem-ref (slot-value column 'value-ptr) :double))))) ;;;------------------------ @@ -214,9 +214,9 @@ (defmethod get-column-value ((column date-column)) - (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long))) + (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) (if (= len $SQL_NULL_DATA) - nil - (funcall *universal-time-to-date-dataype* - (timestamp-to-universal-time (slot-value column 'value-ptr)))))) + nil + (funcall *universal-time-to-date-dataype* + (timestamp-to-universal-time (slot-value column 'value-ptr)))))) ;;;-------------------------- @@ -241,5 +241,5 @@ (defmethod get-column-value ((column binary-column)) - (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long))) + (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) (if (= len $SQL_NULL_DATA) nil @@ -260,8 +260,8 @@ (defmethod get-column-value ((column bigint-column)) - (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long))) - (if (= len $SQL_NULL_DATA) - nil - (parse-integer (get-string (slot-value column 'value-ptr) len))))) + (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) + (if (= len $SQL_NULL_DATA) + nil + (parse-integer (get-string (slot-value column 'value-ptr) len))))) ;;;---------------------------- @@ -313,15 +313,15 @@ (defmethod get-column-value ((column decimal-column)) - (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) :long))) + (let ((len (cffi:mem-ref (slot-value column 'ind-ptr) 'sql-len))) (if (= len $SQL_NULL_DATA) - nil - (let ((bytes (get-byte-vector (slot-value column 'value-ptr) len)) - (sum 0)) - (dotimes (i 16) - (setf sum (+ (* 256 sum) (aref bytes (- (+ 3 16) 1 i))))) - (* - sum - (if (zerop (aref bytes 2)) -1 1) ;sign - (expt 10 (- (aref bytes 1)))))))) + nil + (let ((bytes (get-byte-vector (slot-value column 'value-ptr) len)) + (sum 0)) + (dotimes (i 16) + (setf sum (+ (* 256 sum) (aref bytes (- (+ 3 16) 1 i))))) + (* + sum + (if (zerop (aref bytes 2)) -1 1) ;sign + (expt 10 (- (aref bytes 1)))))))) @@ -341,5 +341,5 @@ (let* ((value-ptr (cffi:foreign-alloc :char :count (slot-value column 'buffer-length))) - (ind-ptr (cffi:foreign-alloc :long))) + (ind-ptr (cffi:foreign-alloc 'sql-len))) (unwind-protect (get-character-data @@ -365,5 +365,5 @@ (defmethod get-column-value ((column uclob-column)) (let* ((value-ptr (cffi:foreign-alloc :char :count (slot-value column 'buffer-length))) - (ind-ptr (cffi:foreign-alloc :long))) + (ind-ptr (cffi:foreign-alloc 'sql-len))) (unwind-protect (get-unicode-character-data @@ -389,5 +389,5 @@ (defmethod get-column-value ((column blob-column)) (let* ((value-ptr (cffi:foreign-alloc :uchar :count (slot-value column 'buffer-length))) - (ind-ptr (cffi:foreign-alloc :long))) + (ind-ptr (cffi:foreign-alloc 'sql-len))) (unwind-protect (get-binary-data @@ -423,22 +423,23 @@ ind-ptr))) (handle-error sqlret) - (let ((len (cffi:mem-ref ind-ptr :long))) - ;(break) + (let ((len (cffi:mem-ref ind-ptr 'sql-len))) + ;;(break) (cond ((= len $sql_null_data) nil) - ;; character data has a 0 byte appended, the length does not include it - ;; but it is taken into account when placing the data into the buffer + ;; character data has a 0 byte appended, the length does not + ;; include it but it is taken into account when placing the + ;; data into the buffer ((and (/= len $SQL_NO_TOTAL) (<= (+ 1 len) buffer-length)) - ;; the data fits into the buffer, return it - (get-string value-ptr len)) + ;; the data fits into the buffer, return it + (get-string value-ptr len)) ;; we have to fetch the data in several steps (t - (let ((sos (make-string-output-stream))) - (loop - (if (and (= sqlret $SQL_SUCCESS_WITH_INFO) - (equal (sql-state nil nil hstmt) - "01004")) + (let ((sos (make-string-output-stream))) + (loop + (if (and (= sqlret $SQL_SUCCESS_WITH_INFO) + (equal (sql-state nil nil hstmt) + "01004")) ;; an 0 byte is append to a string, ignore that @@ -446,20 +447,21 @@ (write-string str sos) (setf sqlret (%sql-get-data-raw hstmt - position - $SQL_C_CHAR - value-ptr - buffer-length - ind-ptr)) + position + $SQL_C_CHAR + value-ptr + buffer-length + ind-ptr)) (handle-error sqlret)) (return))) - ;; fetch the last part of the data - (setf len (cffi:mem-ref ind-ptr :long)) - (let ((str (get-string value-ptr len))) - (write-string str sos)) - (get-output-stream-string sos)))))))) + ;; fetch the last part of the data + (setf len (cffi:mem-ref ind-ptr 'sql-len)) + (let ((str (get-string value-ptr len))) + (write-string str sos)) + (get-output-stream-string sos)))))))) ;;; the version for 16bit unicode -(defun get-unicode-character-data (hstmt position value-ptr buffer-length ind-ptr) +(defun get-unicode-character-data (hstmt position value-ptr buffer-length + ind-ptr) ;; local error handling, we can not use the general error handling ;; since this resets the sql-state @@ -481,38 +483,40 @@ ind-ptr))) (handle-error sqlret) - (let ((len (cffi:mem-ref ind-ptr :long))) + (let ((len (cffi:mem-ref ind-ptr 'sql-len))) (cond ((= len $sql_null_data) nil) - ;; character data has a 0 byte appended, the length does not include it - ;; but it is taken into account when placing the data into the buffer + ;; character data has a 0 byte appended, the length does not + ;; include it but it is taken into account when placing the + ;; data into the buffer ((and (/= len $SQL_NO_TOTAL) (<= (+ 2 len) buffer-length)) - ;; the data fits into the buffer, return it - (%get-unicode-string value-ptr len)) + ;; the data fits into the buffer, return it + (%get-unicode-string value-ptr len)) ;; we have to fetch the data in several steps (t - (let ((sos (make-string-output-stream :element-type 'character))) - (loop - (if (and (= sqlret $SQL_SUCCESS_WITH_INFO) - (equal (sql-state nil nil hstmt) - "01004")) + (let ((sos (make-string-output-stream :element-type 'character))) + (loop + (if (and (= sqlret $SQL_SUCCESS_WITH_INFO) + (equal (sql-state nil nil hstmt) + "01004")) ;; an 0 byte is append to a string, ignore that - (let ((str (%get-unicode-string value-ptr (- buffer-length 2)))) + (let ((str + (%get-unicode-string value-ptr (- buffer-length 2)))) (write-string str sos) (setf sqlret (%sql-get-data-raw hstmt - position - $SQL_C_WCHAR - value-ptr - buffer-length - ind-ptr)) + position + $SQL_C_WCHAR + value-ptr + buffer-length + ind-ptr)) (handle-error sqlret)) (return))) - ;; fetch the last part of the data - (setf len (cffi:mem-ref ind-ptr :long)) - (let ((str (%get-unicode-string value-ptr len))) - (write-string str sos)) - (get-output-stream-string sos)))))))) + ;; fetch the last part of the data + (setf len (cffi:mem-ref ind-ptr 'sql-len)) + (let ((str (%get-unicode-string value-ptr len))) + (write-string str sos)) + (get-output-stream-string sos)))))))) (defun get-binary-data (hstmt position value-ptr buffer-length ind-ptr) @@ -530,38 +534,39 @@ (error condition))))) - (let* ((sqlret (%sql-get-data-raw hstmt - position - $SQL_C_BINARY - value-ptr - buffer-length - ind-ptr))) - (handle-error sqlret) - (let ((len (cffi:mem-ref ind-ptr :long))) - (if (= len $sql_null_data) - nil - (let ((res (make-array 0 :element-type '(unsigned-byte 8) :adjustable t)) - (res-len 0)) - (loop - (if (and (= sqlret $SQL_SUCCESS_WITH_INFO) - (equal (sql-state nil nil hstmt) - "01004")) + (let* ((sqlret (%sql-get-data-raw hstmt + position + $SQL_C_BINARY + value-ptr + buffer-length + ind-ptr))) + (handle-error sqlret) + (let ((len (cffi:mem-ref ind-ptr 'sql-len))) + (if (= len $sql_null_data) + nil + (let ((res (make-array 0 + :element-type '(unsigned-byte 8) + :adjustable t)) + (res-len 0)) + (loop + (if (and (= sqlret $SQL_SUCCESS_WITH_INFO) + (equal (sql-state nil nil hstmt) + "01004")) - (let ((vec (get-byte-vector value-ptr buffer-length))) - (setf res (adjust-array res (+ res-len buffer-length))) - (setf (subseq res res-len (+ res-len buffer-length)) vec) - (setf res-len (length res)) - (setf sqlret (%sql-get-data-raw hstmt - position - $SQL_C_BINARY - value-ptr - buffer-length - ind-ptr)) - (handle-error sqlret)) - (return))) + (let ((vec (get-byte-vector value-ptr buffer-length))) + (setf res (adjust-array res (+ res-len buffer-length))) + (setf (subseq res res-len (+ res-len buffer-length)) vec) + (setf res-len (length res)) + (setf sqlret (%sql-get-data-raw hstmt + position + $SQL_C_BINARY + value-ptr + buffer-length + ind-ptr)) + (handle-error sqlret)) + (return))) - (setf len (cffi:mem-ref ind-ptr :long)) - (let ((vec (get-byte-vector value-ptr len))) - (setf res (adjust-array res (+ res-len len))) - (setf (subseq res res-len (+ res-len len)) vec)) - res)))))) - + (setf len (cffi:mem-ref ind-ptr 'sql-len)) + (let ((vec (get-byte-vector value-ptr len))) + (setf res (adjust-array res (+ res-len len))) + (setf (subseq res res-len (+ res-len len)) vec)) + res)))))) Index: combined/src/odbc/odbc-ff-interface.lisp =================================================================== --- combined/src/odbc/odbc-ff-interface.lisp (revision combined,1) +++ combined/src/odbc/odbc-ff-interface.lisp (revision combined,3) @@ -18,248 +18,203 @@ (load-foreign-library :odbc) +(defctype string-ptr :pointer) + + + +;;;; dso- + +(defctype sql-small-int :int16) +(defctype sql-u-small-int :uint16) +(defctype sql-integer :int32) +(defctype sql-u-integer :uint32) +(defctype sql-pointer :pointer) +(defctype sql-len sql-integer) +(defctype sql-u-len sql-u-integer) +(defctype sql-return sql-small-int) + +(defctype *sql-small-int :pointer) +(defctype *sql-integer :pointer) +(defctype *sql-len :pointer) +(defctype *sql-u-len :pointer) + (defctype sql-handle :pointer) -(defctype *sql-handle :pointer) -(defctype RETCODE :short) -(defctype *short :pointer) -(defctype *sdword :pointer) -(defctype *sword :pointer) -(defctype *ulong :pointer) - - -(defctype string-ptr :pointer) - - - -(defcfun "SQLAllocEnv" retcode (penv *sql-handle)) - -(defcfun "SQLAllocConnect" retcode - (henv sql-handle) ; HENV henv - (*phdbc *sql-handle)) ; HDBC FAR *phdbc - -(defcfun "SQLConnect" retcode - (hdbc sql-handle) ; HDBC hdbc - (*szDSN string-ptr) ; UCHAR FAR *szDSN - (cbDSN :short) ; SWORD cbDSN - (*szUID string-ptr) ; UCHAR FAR *szUID - (cbUID :short) ; SWORD cbUID - (*szAuthStr string-ptr) ; UCHAR FAR *szAuthStr - (cbAuthStr :short) ; SWORD cbAuthStr - ) +(defctype sql-h-env sql-handle) +(defctype sql-h-dbc sql-handle) +(defctype sql-h-stmt sql-handle) +(defctype sql-h-wnd :pointer) + +(defctype *sql-h-env :pointer) +(defctype *sql-h-dbc :pointer) +(defctype *sql-h-stmt :pointer) + +(defmacro defsqlfun (name (&rest args)) + `(defcfun ,name sql-return ,@args)) + +;;;; -dso + + + +(defsqlfun "SQLAllocEnv" + ((penv *sql-h-env))) + +(defsqlfun "SQLAllocConnect" + ((henv sql-h-env) ; HENV henv + (*phdbc *sql-h-dbc))) ; HDBC FAR *phdbc + +(defsqlfun "SQLDriverConnect" + ((hdbc sql-h-dbc) ; HDBC hdbc + (hwnd sql-h-wnd) ; SQLHWND hwnd + ;(*szConnStrIn string-ptr) ; UCHAR FAR *szConnStrIn + (*szConnStrIn string-ptr) ; UCHAR FAR *szConnStrIn + (cbConnStrIn sql-small-int) ; SWORD cbConnStrIn + ;(*szConnStrOut string-ptr) ; UCHAR FAR *szConnStrOut + (*szConnStrOut string-ptr) ; UCHAR FAR *szConnStrOut + (cbConnStrOutMax sql-small-int) ; SWORD cbConnStrOutMaxw + (*pcbConnStrOut *sql-small-int) ; SWORD FAR *pcbConnStrOut + (fDriverCompletion :unsigned-short))) ; UWORD fDriverCompletion + +(defsqlfun "SQLDisconnect" + ((hdbc sql-h-dbc))) ; HDBC hdbc + +(defsqlfun "SQLAllocStmt" + ((hdbc sql-h-dbc) ; HDBC hdbc + (*phstmt *sql-h-stmt))) ; HSTMT FAR *phstmt + + + +(defsqlfun "SQLGetInfo" + ((hdbc sql-h-dbc) ; HDBC hdbc + (fInfoType sql-u-small-int) ; UWORD fInfoType + (rgbInfoValue sql-pointer) ; PTR rgbInfoValue + (cbInfoValueMax sql-small-int) ; SWORD cbInfoValueMax + (*pcbInfoValue *sql-small-int))) ; SWORD FAR *pcbInfoValue + + +(defsqlfun ("SQLGetInfo" SQLGetInfo-Str) + ((hdbc sql-h-dbc) ; HDBC hdbc + (fInfoType sql-u-small-int) ; UWORD fInfoType + (rgbInfoValue string-ptr) ; PTR rgbInfoValue + (cbInfoValueMax sql-small-int) ; SWORD cbInfoValueMax + (*pcbInfoValue *sql-small-int))) ; SWORD FAR *pcbInfoValue + + +(defsqlfun "SQLPrepare" + ((hstmt sql-h-stmt) ; HSTMT hstmt + (*szSqlStr string-ptr) ; UCHAR FAR *szSqlStr + (cbSqlStr sql-integer))) ; SDWORD cbSqlStr + + + +(defsqlfun "SQLExecute" + ((hstmt sql-h-stmt))) ; HSTMT hstmt + + +(defsqlfun "SQLExecDirect" + ((hstmt sql-h-stmt) ; HSTMT hstmt + (*szSqlStr string-ptr) ; UCHAR FAR *szSqlStr + (cbSqlStr sql-integer))) ; SDWORD cbSqlStr + + + +(defsqlfun "SQLFreeStmt" + ((hstmt sql-h-stmt) ; HSTMT hstmt + (fOption sql-u-small-int))) ; UWORD fOption + + + +(defsqlfun "SQLError" + ((henv sql-h-env) ; HENV henv + (hdbc sql-h-dbc) ; HDBC hdbc + (hstmt sql-h-stmt) ; HSTMT hstmt + ; (*szSqlState string-ptr) ; UCHAR FAR *szSqlState + (*szSqlState string-ptr) ; UCHAR FAR *szSqlState + (*pfNativeError *sql-integer) ; SDWORD FAR *pfNativeError + ; (*szErrorMsg string-ptr) ; UCHAR FAR *szErrorMsg + (*szErrorMsg string-ptr) ; UCHAR FAR *szErrorMsg + (cbErrorMsgMax sql-small-int) ; SWORD cbErrorMsgMax + (*pcbErrorMsg *sql-small-int))) ; SWORD FAR *pcbErrorMsg + + + +(defsqlfun "SQLNumResultCols" + ((hstmt sql-h-stmt) ; HSTMT hstmt + (*pccol *sql-small-int))) ; SWORD FAR *pccol + + +(defsqlfun "SQLRowCount" + ((hstmt sql-h-stmt) ; HSTMT hstmt + (*pcrow *sql-len))) ; SDWORD FAR *pcrow + + +(defsqlfun "SQLDescribeCol" + ((hstmt sql-h-stmt) ; HSTMT hstmt + (icol sql-u-small-int) ; UWORD icol + (*szColName string-ptr) ; UCHAR FAR *szColName + (cbColNameMax sql-small-int) ; SWORD cbColNameMax + (*pcbColName *sql-small-int) ; SWORD FAR *pcbColName + (*pfSqlType *sql-small-int) ; SWORD FAR *pfSqlType + (*pcbColDef *sql-u-len) ; UDWORD FAR *pcbColDef + (*pibScale *sql-small-int) ; SWORD FAR *pibScale + (*pfNullable *sql-small-int))) ; SWORD FAR *pfNullable + + +(defsqlfun "SQLBindCol" + ((hstmt sql-h-stmt) ; HSTMT hstmt + (icol sql-u-small-int) ; UWORD icol + (fCType sql-small-int) ; SWORD fCType + (rgbValue sql-pointer) ; PTR rgbValue + (cbValueMax sql-len) ; SDWORD cbValueMax + (*pcbValue *sql-len))) ; SDWORD FAR *pcbValue + - (defcfun "SQLDriverConnect" retcode - (hdbc sql-handle) ; HDBC hdbc - (hwnd sql-handle) ; SQLHWND hwnd - ;(*szConnStrIn string-ptr) ; UCHAR FAR *szConnStrIn - (*szConnStrIn string-ptr) ; UCHAR FAR *szConnStrIn - (cbConnStrIn :short) ; SWORD cbConnStrIn - ;(*szConnStrOut string-ptr) ; UCHAR FAR *szConnStrOut - (*szConnStrOut string-ptr) ; UCHAR FAR *szConnStrOut - (cbConnStrOutMax :short) ; SWORD cbConnStrOutMaxw - (*pcbConnStrOut *short) ; SWORD FAR *pcbConnStrOut - (fDriverCompletion :unsigned-short) ; UWORD fDriverCompletion - ) - - (defcfun "SQLDisconnect" retcode - (hdbc sql-handle)) ; HDBC hdbc - - (defcfun "SQLAllocStmt" retcode - (hdbc sql-handle) ; HDBC hdbc - (*phstmt *sql-handle)) ; HSTMT FAR *phstmt - - - - (defcfun "SQLGetInfo" retcode - (hdbc sql-handle) ; HDBC hdbc - (fInfoType :short) ; UWORD fInfoType - (rgbInfoValue :pointer) ; PTR rgbInfoValue - (cbInfoValueMax :short) ; SWORD cbInfoValueMax - (*pcbInfoValue :pointer) ; SWORD FAR *pcbInfoValue - ) - - (defcfun ("SQLGetInfo" SQLGetInfo-Str) retcode - (hdbc sql-handle) ; HDBC hdbc - (fInfoType :short) ; UWORD fInfoType - (rgbInfoValue string-ptr) ; PTR rgbInfoValue - (cbInfoValueMax :short) ; SWORD cbInfoValueMax - (*pcbInfoValue :pointer) ; SWORD FAR *pcbInfoValue - ) - - - (defcfun "SQLPrepare" retcode - (hstmt sql-handle) ; HSTMT hstmt - (*szSqlStr string-ptr) ; UCHAR FAR *szSqlStr - (cbSqlStr :long) ; SDWORD cbSqlStr - ) - - - (defcfun "SQLExecute" retcode - (hstmt sql-handle) ; HSTMT hstmt - ) - - - (defcfun "SQLExecDirect" retcode - (hstmt sql-handle) ; HSTMT hstmt - (*szSqlStr string-ptr) ; UCHAR FAR *szSqlStr - (cbSqlStr :long) ; SDWORD cbSqlStr - ) - - - (defcfun "SQLFreeStmt" retcode - (hstmt sql-handle) ; HSTMT hstmt - (fOption :short)) ; UWORD fOption - - - (defcfun "SQLCancel" retcode - (hstmt sql-handle) ; HSTMT hstmt - ) - - - (defcfun "SQLError" retcode - (henv sql-handle) ; HENV henv - (hdbc sql-handle) ; HDBC hdbc - (hstmt sql-handle) ; HSTMT hstmt -; (*szSqlState string-ptr) ; UCHAR FAR *szSqlState - (*szSqlState string-ptr) ; UCHAR FAR *szSqlState - (*pfNativeError *SDWORD) ; SDWORD FAR *pfNativeError -; (*szErrorMsg string-ptr) ; UCHAR FAR *szErrorMsg - (*szErrorMsg string-ptr) ; UCHAR FAR *szErrorMsg - (cbErrorMsgMax :short) ; SWORD cbErrorMsgMax - (*pcbErrorMsg *short)) ; SWORD FAR *pcbErrorMsg - - - - (defcfun "SQLNumResultCols" retcode - (hstmt sql-handle) ; HSTMT hstmt - (*pccol :pointer) ; SWORD FAR *pccol - ) - - - (defcfun "SQLRowCount" retcode - (hstmt sql-handle) ; HSTMT hstmt - (*pcrow *sdword) ; SDWORD FAR *pcrow - ) - - - (defcfun "SQLDescribeCol" retcode - (hstmt sql-handle) ; HSTMT hstmt - (icol :short) ; UWORD icol - (*szColName string-ptr) ; UCHAR FAR *szColName - (cbColNameMax :short) ; SWORD cbColNameMax - (*pcbColName *short) ; SWORD FAR *pcbColName - (*pfSqlType *short) ; SWORD FAR *pfSqlType - (*pcbColDef *ulong) ; UDWORD FAR *pcbColDef - (*pibScale *short) ; SWORD FAR *pibScale - (*pfNullable *short) ; SWORD FAR *pfNullable - ) - - - (defcfun "SQLColAttributes" retcode - (hstmt sql-handle) ; HSTMT hstmt - (icol :short) ; UWORD icol - (fDescType :short) ; UWORD fDescType - (rgbDesc :pointer) ; PTR rgbDesc - (cbDescMax :short) ; SWORD cbDescMax - (*pcbDesc *sword) ; SWORD FAR *pcbDesc - (*pfDesc *sdword) ; SDWORD FAR *pfDesc - ) - - - (defcfun "SQLColumns" retcode - (hstmt sql-handle) ; HSTMT hstmt - (*szTableQualifier string-ptr) ; UCHAR FAR *szTableQualifier - (cbTableQualifier :short) ; SWORD cbTableQualifier - (*szTableOwner string-ptr) ; UCHAR FAR *szTableOwner - (cbTableOwner :short) ; SWORD cbTableOwner - (*szTableName string-ptr) ; UCHAR FAR *szTableName - (cbTableName :short) ; SWORD cbTableName - (*szColumnName string-ptr) ; UCHAR FAR *szColumnName - (cbColumnName :short) ; SWORD cbColumnName - ) - - - (defcfun "SQLBindCol" retcode - (hstmt sql-handle) ; HSTMT hstmt - (icol :short) ; UWORD icol - (fCType :short) ; SWORD fCType - (rgbValue :pointer) ; PTR rgbValue - (cbValueMax :long) ; SDWORD cbValueMax - (*pcbValue *sdword) ; SDWORD FAR *pcbValue - ) - - - (defcfun "SQLFetch" retcode - (hstmt sql-handle) ; HSTMT hstmt - ) - - - (defcfun "SQLTransact" retcode - (henv sql-handle) ; HENV henv - (hdbc sql-handle) ; HDBC hdbc - (fType :short) ; UWORD fType ($SQL_COMMIT or $SQL_ROLLBACK) - ) - - - ;; ODBC 2.0 - (defcfun "SQLDescribeParam" retcode - (hstmt sql-handle) ; HSTMT hstmt - (ipar :short) ; UWORD ipar - (*pfSqlType *sword) ; SWORD FAR *pfSqlType - (*pcbColDef *ulong) ; UDWORD FAR *pcbColDef - (*pibScale *sword) ; SWORD FAR *pibScale - (*pfNullable *sword) ; SWORD FAR *pfNullable - ) - - - ;; ODBC 2.0 - (defcfun "SQLBindParameter" retcode - (hstmt sql-handle) ; HSTMT hstmt - (ipar :short) ; UWORD ipar - (fParamType :short) ; SWORD fParamType - (fCType :short) ; SWORD fCType - (fSqlType :short) ; SWORD fSqlType - (cbColDef :ulong) ; UDWORD cbColDef - (ibScale :short) ; SWORD ibScale - (rgbValue :pointer) ; PTR rgbValue - (cbValueMax :long) ; SDWORD cbValueMax - (*pcbValue *sdword) ; SDWORD FAR *pcbValue - ) - - - ;; level 1 - (defcfun "SQLGetData" retcode - (hstmt sql-handle) ; HSTMT hstmt - (icol :short) ; UWORD icol - (fCType :short) ; SWORD fCType - (rgbValue :pointer) ; PTR rgbValue - (cbValueMax :long) ; SDWORD cbValueMax - (*pcbValue *sdword) ; SDWORD FAR *pcbValue - ) - - - (defcfun "SQLParamData" retcode - (hstmt sql-handle) ; HSTMT hstmt - (*prgbValue :pointer) ; PTR FAR *prgbValue - ) - - - (defcfun "SQLPutData" retcode - (hstmt sql-handle) ; HSTMT hstmt - (rgbValue :pointer) ; PTR rgbValue - (cbValue :long) ; SDWORD cbValue - ) - - - (defcfun "SQLGetConnectOption" retcode - (hdbc sql-handle) ; HDBC hdbc - (fOption :short) ; UWORD fOption - (pvParam :pointer) ; PTR pvParam - ) - - - (defcfun "SQLSetConnectOption" retcode - (hdbc sql-handle) ; HDBC hdbc - (fOption :short) ; UWORD fOption - (vParam :ulong) ; UDWORD vParam - ) +(defsqlfun "SQLFetch" + ((hstmt sql-h-stmt))) ; HSTMT hstmt + + +(defsqlfun "SQLTransact" + ((henv sql-h-env) ; HENV henv + (hdbc sql-h-dbc) ; HDBC hdbc + (fType sql-u-small-int))) ; UWORD fType ($SQL_COMMIT or $SQL_ROLLBACK) + + +;; ODBC 2.0 +(defsqlfun "SQLBindParameter" + ((hstmt sql-h-stmt) ; HSTMT hstmt + (ipar sql-u-small-int) ; UWORD ipar + (fParamType sql-small-int) ; SWORD fParamType + (fCType sql-small-int) ; SWORD fCType + (fSqlType sql-small-int) ; SWORD fSqlType + (cbColDef sql-u-len) ; UDWORD cbColDef + (ibScale sql-small-int) ; SWORD ibScale + (rgbValue sql-pointer) ; PTR rgbValue + (cbValueMax sql-len) ; SDWORD cbValueMax + (*pcbValue *sql-len))) ; SDWORD FAR *pcbValue + + +;; level 1 +(defsqlfun "SQLGetData" + ((hstmt sql-h-stmt) ; HSTMT hstmt + (icol sql-u-small-int) ; UWORD icol + (fCType sql-small-int) ; SWORD fCType + (rgbValue sql-pointer) ; PTR rgbValue + (cbValueMax sql-len) ; SDWORD cbValueMax + (*pcbValue *sql-len))) ; SDWORD FAR *pcbValue + + +(defsqlfun "SQLParamData" + ((hstmt sql-h-stmt) ; HSTMT hstmt + (*prgbValue sql-pointer))) ; PTR FAR *prgbValue + + +(defsqlfun "SQLPutData" + ((hstmt sql-h-stmt) ; HSTMT hstmt + (rgbValue sql-pointer) ; PTR rgbValue + (cbValue sql-len))) ; SDWORD cbValue + + +(defsqlfun "SQLSetConnectOption" + ((hdbc sql-h-dbc) ; HDBC hdbc + (fOption sql-u-small-int) ; UWORD fOption + (vParam sql-u-len))) ; UDWORD vParam @@ -277,79 +232,45 @@ ; driver-specific value, the value in ValuePtr may be a signed integer. -(defcfun ("SQLSetConnectAttr" SQLSetConnectAttr_long) retcode - (hdbc sql-handle) ; HDBC hdbc - (fOption :short) ; UWORD fOption - (pvParam :long) ; UDWORD vParam - (stringlength :long) - ) - - -(defcfun ("SQLSetConnectAttr" SQLSetConnectAttr_string) retcode - (hdbc sql-handle) ; HDBC hdbc - (fOption :short) ; UWORD fOption - (pvParam string-ptr) ; UDWORD vParam - (stringlength :long) - ) - - - - (defcfun "SQLSetPos" retcode - (hstmt sql-handle) ; HSTMT hstmt - (irow :short) ; UWORD irow - (fOption :short) ; UWORD fOption - (fLock :short) ; UWORD fLock - ) - - - ; level 2 - (defcfun "SQLExtendedFetch" retcode - (hstmt sql-handle) ; HSTMT hstmt - (fFetchType :short) ; UWORD fFetchType - (irow :long) ; SDWORD irow - (*pcrow :pointer) ; UDWORD FAR *pcrow - (*rgfRowStatus :pointer) ; UWORD FAR *rgfRowStatus - ) - - (defcfun "SQLDataSources" retcode - (henv sql-handle) ; HENV henv - (fDirection :short) - (*szDSN string-ptr) ; UCHAR FAR *szDSN - (cbDSNMax :short) ; SWORD cbDSNMax - (*pcbDSN *sword) ; SWORD *pcbDSN - (*szDescription string-ptr) ; UCHAR *szDescription - (cbDescriptionMax :short) ; SWORD cbDescriptionMax - (*pcbDescription *sword) ; SWORD *pcbDescription - ) - - - (defcfun "SQLFreeEnv" retcode - (henv sql-handle) ; HSTMT hstmt - ) - - - (defcfun "SQLMoreResults" retcode - (hstmt sql-handle)) +(defsqlfun ("SQLSetConnectAttr" SQLSetConnectAttr_long) + ((hdbc sql-h-dbc) ; HDBC hdbc + ;; TODO: The new def of fOption doesn't seem compatible with the + ;; original, but matches my headers. + (fOption sql-integer) ; UWORD fOption + (pvParam sql-integer) ; UDWORD vParam + (stringlength sql-integer))) + + +(defsqlfun ("SQLSetConnectAttr" SQLSetConnectAttr_string) + ((hdbc sql-handle) ; HDBC hdbc + (fOption sql-integer) ; UWORD fOption + (pvParam string-ptr) ; UDWORD vParam + (stringlength sql-integer))) + + +;; level 2 +(defsqlfun "SQLMoreResults" + ((hstmt sql-h-stmt))) ;;; foreign type definitions - (defcstruct sql-c-time "" - (hour :short) - (minute :short) - (second :short)) - - (defcstruct sql-c-date "" - (year :short) - (month :short) - (day :short)) - - (defcstruct sql-c-timestamp "" - (year :short) - (month :short) - (day :short) - (hour :short) - (minute :short) - (second :short) - (fraction :long)) +(defcstruct sql-c-time "" + (hour sql-u-small-int) + (minute sql-u-small-int) + (second sql-u-small-int)) + +(defcstruct sql-c-date "" + (year sql-small-int) + (month sql-u-small-int) + (day sql-u-small-int)) + +(defcstruct sql-c-timestamp "" + (year sql-small-int) + (month sql-u-small-int) + (day sql-u-small-int) + (hour sql-u-small-int) + (minute sql-u-small-int) + (second sql-u-small-int) + (fraction sql-u-integer)) (defun %put-sql-c-date (adr %year %month %day) @@ -358,6 +279,7 @@ (setf (foreign-slot-value adr 'sql-c-date 'day) %day)) - -(defun %put-sql-c-timestamp (adr %year %month %day %hour %minute %second %fraction) + +(defun %put-sql-c-timestamp (adr %year %month %day %hour %minute %second + %fraction) (setf (foreign-slot-value adr 'sql-c-timestamp 'second) %second) (setf (foreign-slot-value adr 'sql-c-timestamp 'minute) %minute) @@ -366,9 +288,8 @@ (setf (foreign-slot-value adr 'sql-c-timestamp 'month) %month) (setf (foreign-slot-value adr 'sql-c-timestamp 'year) %year) - (setf (foreign-slot-value adr 'sql-c-timestamp 'fraction) %fraction) - ) + (setf (foreign-slot-value adr 'sql-c-timestamp 'fraction) %fraction)) (defun timestamp-to-universal-time (adr) - (with-foreign-slots + (with-foreign-slots ((year month day hour minute second fraction) adr sql-c-timestamp) (values @@ -379,18 +300,18 @@ day month - year ) + year) fraction))) - + (defun date-to-universal-time (adr) - (with-foreign-slots + (with-foreign-slots ((year month day) adr sql-c-date) (encode-universal-time - 0 0 0 - day - month - year))) - - -(defmacro %sql-len-data-at-exec (length) + 0 0 0 + day + month + year))) + + +(defmacro %sql-len-data-at-exec (length) `(- $SQL_LEN_DATA_AT_EXEC_OFFSET ,length)) Index: combined/src/odbc/odbc-functions.lisp =================================================================== --- combined/src/odbc/odbc-functions.lisp (revision combined,1) +++ combined/src/odbc/odbc-functions.lisp (revision combined,3) @@ -17,8 +17,9 @@ `(let (,@allocs) (unwind-protect - (progn ,@body) - ,@(mapcar (lambda (alloc) (list 'cffi:foreign-free (first alloc))) allocs)))) - - + (progn ,@body) + ,@(mapcar (lambda (alloc) (list 'cffi:foreign-free (first alloc))) + allocs)))) + + @@ -44,20 +45,21 @@ ()) +;; TODO: Why doesn't this use with-temporary-allocations? -dso (defun handle-error (henv hdbc hstmt) - (let - ((sql-state (alloc-chars 256)) - (error-message (alloc-chars #.$SQL_MAX_MESSAGE_LENGTH)) - (error-code (cffi:foreign-alloc :long)) - (msg-length (cffi:foreign-alloc :short))) - (SQLError henv - hdbc - hstmt sql-state - error-code error-message - $SQL_MAX_MESSAGE_LENGTH msg-length) - (values - (get-string-nts error-message) - (get-string-nts sql-state) - (cffi:mem-ref msg-length :short) - (cffi:mem-ref error-code :long)))) + (let + ((sql-state (alloc-chars 256)) + (error-message (alloc-chars #.$SQL_MAX_MESSAGE_LENGTH)) + (error-code (cffi:foreign-alloc 'sql-integer)) + (msg-length (cffi:foreign-alloc 'sql-small-int))) + (SQLError henv + hdbc + hstmt sql-state + error-code error-message + $SQL_MAX_MESSAGE_LENGTH msg-length) + (values + (get-string-nts error-message) + (get-string-nts sql-state) + (cffi:mem-ref msg-length 'sql-small-int) + (cffi:mem-ref error-code 'sql-integer)))) @@ -67,12 +69,12 @@ ;#+ignore (defun sql-state (henv hdbc hstmt) - (with-temporary-allocations + (with-temporary-allocations ((sql-state (cffi:foreign-alloc :char :count 256)) (error-message (cffi:foreign-alloc :char :count $SQL_MAX_MESSAGE_LENGTH)) - (error-code (cffi:foreign-alloc :long)) - (msg-length (cffi:foreign-alloc :short))) + (error-code (cffi:foreign-alloc 'sql-integer)) + (msg-length (cffi:foreign-alloc 'sql-small-int))) (SQLError henv hdbc hstmt sql-state error-code error-message $SQL_MAX_MESSAGE_LENGTH msg-length) - (get-string sql-state 5) ;(%cstring-to-keyword sql-state) + (get-string sql-state 5) ;(%cstring-to-keyword sql-state) )) @@ -165,28 +167,22 @@ (defun %new-environment-handle () - (cffi:with-foreign-object (phenv 'sql-handle) + (cffi:with-foreign-object (phenv 'sql-h-env) (with-error-handling - () - (SQLAllocEnv phenv) - (cffi:mem-ref phenv 'sql-handle) - ))) - -(defun %sql-free-environment (henv) - (with-error-handling - (:henv henv) - (SQLFreeEnv henv))) + () + (SQLAllocEnv phenv) + (cffi:mem-ref phenv 'sql-h-env)))) (defun %new-db-connection-handle (henv) - (cffi:with-foreign-object (phdbc 'sql-handle) + (cffi:with-foreign-object (phdbc 'sql-h-dbc) (with-error-handling (:henv henv) - (SQLAllocConnect henv phdbc) - (cffi:mem-ref phdbc 'sql-handle)))) + (SQLAllocConnect henv phdbc) + (cffi:mem-ref phdbc 'sql-h-dbc)))) (defun %free-statement (hstmt option) - (with-error-handling + (with-error-handling (:hstmt hstmt) - (SQLFreeStmt - hstmt + (SQLFreeStmt + hstmt (ecase option (:drop $SQL_DROP) @@ -217,15 +213,7 @@ ;; functional interface -(defun %sql-connect (hdbc server uid pwd) - (cffi:with-foreign-string (server-ptr server) - (cffi:with-foreign-string (uid-ptr uid) - (cffi:with-foreign-string (pwd-ptr pwd) - (with-error-handling - (:hdbc hdbc) - (SQLConnect hdbc server-ptr $SQL_NTS uid-ptr - $SQL_NTS pwd-ptr $SQL_NTS)))))) - ;; (defun %sql-driver-connect (henv hdbc connection-string completion-option) + (declare (string connection-string)) (let ((completion-option (ecase completion-option @@ -234,64 +222,67 @@ (:prompt $SQL_DRIVER_PROMPT) (:noprompt $SQL_DRIVER_NOPROMPT)))) - (cffi:with-foreign-string (connection-str-ptr connection-string) + (cffi:with-foreign-string (connection-str-ptr connection-string) (with-temporary-allocations ((complete-connection-str-ptr (alloc-chars 1024)) - (length-ptr (cffi:foreign-alloc :short))) - (with-error-handling + (length-ptr (cffi:foreign-alloc 'sql-small-int))) + (with-error-handling (:henv henv :hdbc hdbc) - - (SQLDriverConnect hdbc - (cffi:null-pointer) ; no window - connection-str-ptr - (length connection-string) - ;$SQL_NTS - complete-connection-str-ptr - 1024 - length-ptr - completion-option)) + + (SQLDriverConnect hdbc + (cffi:null-pointer) ; no window + connection-str-ptr ; TODO: How does + ; encoding affect the + ; length? + (length connection-string) ;$SQL_NTS + complete-connection-str-ptr + 1024 + length-ptr + completion-option)) (get-string-nts complete-connection-str-ptr))))) (defun %disconnect (hdbc) - (with-error-handling - (:hdbc hdbc) - (SQLDisconnect hdbc))) + (with-error-handling + (:hdbc hdbc) + (SQLDisconnect hdbc))) (defun %commit (henv hdbc) - (with-error-handling - (:henv henv :hdbc hdbc) - (SQLTransact - henv hdbc $SQL_COMMIT))) + (with-error-handling + (:henv henv :hdbc hdbc) + (SQLTransact + henv hdbc $SQL_COMMIT))) (defun %rollback (henv hdbc) - (with-error-handling - (:henv henv :hdbc hdbc) - (SQLTransact - henv hdbc $SQL_ROLLBACK))) + (with-error-handling + (:henv henv :hdbc hdbc) + (SQLTransact + henv hdbc $SQL_ROLLBACK))) ; col-nr is zero-based in Lisp ; col-nr = :bookmark retrieves a bookmark. (defun %bind-column (hstmt column-nr c-type data-ptr precision out-len-ptr) - (with-error-handling - (:hstmt hstmt) - (SQLBindCol hstmt - (if (eq column-nr :bookmark) 0 (1+ column-nr)) - c-type data-ptr precision out-len-ptr))) + (declare (type (integer 0) column-nr)) + (with-error-handling + (:hstmt hstmt) + (SQLBindCol hstmt + (if (eq column-nr :bookmark) 0 (1+ column-nr)) + c-type data-ptr precision out-len-ptr))) ; parameter-nr is zero-based in Lisp (defun %sql-bind-parameter (hstmt parameter-nr parameter-type c-type - sql-type precision scale data-ptr - max-value out-len-ptr) - (with-error-handling - (:hstmt hstmt) - (SQLBindParameter hstmt (1+ parameter-nr) - parameter-type ;$SQL_PARAM_INPUT - c-type ;$SQL_C_CHAR - sql-type ;$SQL_VARCHAR - precision ;(1- (length str)) - scale ;0 - data-ptr - max-value - out-len-ptr ;#.(cffi:null-pointer) - ))) + sql-type precision scale data-ptr + max-value out-len-ptr) + (declare (type (integer 0) parameter-nr)) + (with-error-handling + (:hstmt hstmt) + (SQLBindParameter hstmt (1+ parameter-nr) + parameter-type ;$SQL_PARAM_INPUT + c-type ;$SQL_C_CHAR + sql-type ;$SQL_VARCHAR + precision ;(1- (length str)) + scale ;0 + data-ptr + max-value + out-len-ptr ;#.(cffi:null-pointer) + ))) (defun %sql-fetch (hstmt) @@ -301,10 +292,10 @@ (defun %new-statement-handle (hdbc) - (with-temporary-allocations - ((hstmt-ptr (cffi:foreign-alloc 'sql-handle))) - (with-error-handling + (with-temporary-allocations + ((hstmt-ptr (cffi:foreign-alloc 'sql-h-stmt))) + (with-error-handling (:hdbc hdbc) - (SQLAllocStmt hdbc hstmt-ptr) - (cffi:mem-ref hstmt-ptr 'sql-handle)))) + (SQLAllocStmt hdbc hstmt-ptr) + (cffi:mem-ref hstmt-ptr 'sql-h-stmt)))) (defun %sql-get-info (hdbc info-type) @@ -344,15 +335,17 @@ #.$SQL_TABLE_TERM #.$SQL_USER_NAME) - (with-temporary-allocations + (with-temporary-allocations ((info-ptr (alloc-chars 1024)) - (info-length-ptr (cffi:foreign-alloc :short))) - (with-error-handling - (:hdbc hdbc) - #-pcl + (info-length-ptr (cffi:foreign-alloc 'sql-small-int))) + (with-error-handling + (:hdbc hdbc) + #-pcl (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr) - #+pcl + #+pcl (SQLGetInfo-Str hdbc info-type info-ptr 1023 info-length-ptr) + ;; TODO: I believe the following assumes that the buffer was + ;; big enough to include the null-terminator. (get-string-nts info-ptr)))) - ;; those returning a word + ;; those returning a 16-bit integer ((#.$SQL_ACTIVE_CONNECTIONS #.$SQL_ACTIVE_STATEMENTS @@ -383,17 +376,16 @@ #.$SQL_TXN_CAPABLE) (with-temporary-allocations - ((info-ptr (cffi::foreign-alloc :short)) - (info-length-ptr (cffi::foreign-alloc :short))) - (with-error-handling - (:hdbc hdbc) - (SQLGetInfo hdbc - info-type - info-ptr - 255 - info-length-ptr) - (cffi:mem-ref info-ptr :short))) - ) - ;; those returning a long bitmask - ((#.$SQL_ALTER_TABLE + ((info-ptr (cffi::foreign-alloc 'sql-small-int)) + (info-length-ptr (cffi::foreign-alloc 'sql-small-int))) + (with-error-handling + (:hdbc hdbc) + (SQLGetInfo hdbc + info-type + info-ptr + 0 + info-length-ptr) + (cffi:mem-ref info-ptr 'sql-small-int)))) + ;; those returning a 32-bit bitmask + ((#.$SQL_ALTER_TABLE #.$SQL_BOOKMARK_PERSISTENCE #.$SQL_CONVERT_BIGINT @@ -440,17 +432,21 @@ #.$SQL_TXN_ISOLATION_OPTION #.$SQL_UNION) - (with-temporary-allocations - ((info-ptr (cffi:foreign-alloc :unsigned-long)) - (info-length-ptr (cffi:foreign-alloc :short))) - (with-error-handling - (:hdbc hdbc) - (SQLGetInfo hdbc - info-type - info-ptr - 255 - info-length-ptr) - (cffi:mem-ref info-ptr :unsigned-long))) - ) - ;; those returning a long integer + (with-temporary-allocations + ;; TODO: It'd be nice to have this as a sql-* type. However, + ;; while the X/Open spec is usually quiet about data sizes, + ;; it specifically says a 32-bit bitmask for these; so if + ;; SQL-INTEGER changes to 64-bit, these may or may not change + ;; as well. -dso + ((info-ptr (cffi:foreign-alloc :uint32)) + (info-length-ptr (cffi:foreign-alloc 'sql-small-int))) + (with-error-handling + (:hdbc hdbc) + (SQLGetInfo hdbc + info-type + info-ptr + 0 + info-length-ptr) + (cffi:mem-ref info-ptr :uint32)))) + ;; those returning an integer ((#.$SQL_DEFAULT_TXN_ISOLATION #.$SQL_DRIVER_HDBC @@ -462,43 +458,38 @@ #.$SQL_MAX_BINARY_LITERAL_LEN #.$SQL_MAX_CHAR_LITERAL_LEN - #.$SQL_ACTIVE_ENVIRONMENTS - ) - (with-temporary-allocations - ((info-ptr (cffi:foreign-alloc :long)) - (info-length-ptr (cffi:foreign-alloc :short))) - (with-error-handling - (:hdbc hdbc) - (SQLGetInfo hdbc info-type info-ptr 255 info-length-ptr) - (cffi:mem-ref info-ptr :unsigned-long)))))) + #.$SQL_ACTIVE_ENVIRONMENTS) + (with-temporary-allocations + ((info-ptr (cffi:foreign-alloc 'sql-integer)) + (info-length-ptr (cffi:foreign-alloc 'sql-small-int))) + (with-error-handling + (:hdbc hdbc) + (SQLGetInfo hdbc info-type info-ptr 0 info-length-ptr) + (cffi:mem-ref info-ptr 'sql-integer)))))) (defun %sql-exec-direct (sql hstmt henv hdbc) + (declare (string sql)) (cffi:with-foreign-string (sql-ptr sql) (with-error-handling (:hstmt hstmt :henv henv :hdbc hdbc) - (SQLExecDirect hstmt sql-ptr $SQL_NTS)))) - -(defun %sql-cancel (hstmt) - (with-error-handling - (:hstmt hstmt) - (SQLCancel hstmt))) + (SQLExecDirect hstmt sql-ptr $SQL_NTS)))) (defun %sql-execute (hstmt) (with-error-handling - (:hstmt hstmt) - (SQLExecute hstmt))) + (:hstmt hstmt) + (SQLExecute hstmt))) (defun result-columns-count (hstmt) (with-temporary-allocations - ((columns-nr-ptr (cffi:foreign-alloc :short))) + ((columns-nr-ptr (cffi:foreign-alloc 'sql-small-int))) (with-error-handling (:hstmt hstmt) - (SQLNumResultCols hstmt columns-nr-ptr) - (cffi:mem-ref columns-nr-ptr :short)))) + (SQLNumResultCols hstmt columns-nr-ptr) + (cffi:mem-ref columns-nr-ptr 'sql-small-int)))) (defun result-rows-count (hstmt) (with-temporary-allocations - ((row-count-ptr (cffi:foreign-alloc :long))) + ((row-count-ptr (cffi:foreign-alloc 'sql-len))) (with-error-handling (:hstmt hstmt) - (SQLRowCount hstmt row-count-ptr) - (cffi:mem-ref row-count-ptr :long)))) + (SQLRowCount hstmt row-count-ptr) + (cffi:mem-ref row-count-ptr 'sql-len)))) @@ -508,56 +499,25 @@ ;; Column counting is 1-based (defun %describe-column (hstmt column-nr) - (with-temporary-allocations ((column-name-ptr (alloc-chars 256)) - (column-name-length-ptr (cffi:foreign-alloc :short)) - (column-sql-type-ptr (cffi:foreign-alloc :short)) - (column-precision-ptr (cffi:foreign-alloc :unsigned-long)) - (column-scale-ptr (cffi:foreign-alloc :short)) - (column-nullable-p-ptr (cffi:foreign-alloc :short))) + (declare (type (integer 1) column-nr)) + (with-temporary-allocations + ((column-name-ptr (alloc-chars 256)) + (column-name-length-ptr (cffi:foreign-alloc 'sql-small-int)) + (column-sql-type-ptr (cffi:foreign-alloc 'sql-small-int)) + (column-precision-ptr (cffi:foreign-alloc 'sql-u-len)) + (column-scale-ptr (cffi:foreign-alloc 'sql-small-int)) + (column-nullable-p-ptr (cffi:foreign-alloc 'sql-small-int))) (with-error-handling (:hstmt hstmt) - (SQLDescribeCol hstmt column-nr column-name-ptr 256 - column-name-length-ptr - column-sql-type-ptr - column-precision-ptr - column-scale-ptr - column-nullable-p-ptr) + (SQLDescribeCol hstmt column-nr column-name-ptr 256 + column-name-length-ptr + column-sql-type-ptr + column-precision-ptr + column-scale-ptr + column-nullable-p-ptr) (values (get-string-nts column-name-ptr) - (cffi:mem-ref column-sql-type-ptr :short) - (cffi:mem-ref column-precision-ptr :unsigned-long) - (cffi:mem-ref column-scale-ptr :short) - (cffi:mem-ref column-nullable-p-ptr :short))))) - -;; parameter counting is 1-based -(defun %describe-parameter (hstmt parameter-nr) - (with-temporary-allocations ((column-sql-type-ptr (cffi:foreign-alloc :short)) - (column-precision-ptr (cffi:foreign-alloc :long)) - (column-scale-ptr (cffi:foreign-alloc :short)) - (column-nullable-p-ptr (cffi:foreign-alloc :short))) - (with-error-handling - (:hstmt hstmt) - (SQLDescribeParam hstmt parameter-nr - column-sql-type-ptr - column-precision-ptr - column-scale-ptr - column-nullable-p-ptr) - (values - (cffi:mem-ref column-sql-type-ptr :short) - (cffi:mem-ref column-precision-ptr :unsigned-long) - (cffi:mem-ref column-scale-ptr :short) - (cffi:mem-ref column-nullable-p-ptr :short))))) - -(defun %column-attributes (hstmt column-nr descriptor-type) - (with-temporary-allocations - ((descriptor-info-ptr (alloc-chars 256)) - (descriptor-length-ptr (cffi:foreign-alloc :short)) - (numeric-descriptor-ptr (cffi:foreign-alloc :long))) - (with-error-handling - (:hstmt hstmt) - (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr 256 - descriptor-length-ptr - numeric-descriptor-ptr) - (values - (get-string-nts descriptor-info-ptr) - (cffi:mem-ref numeric-descriptor-ptr :long))))) + (cffi:mem-ref column-sql-type-ptr 'sql-small-int) + (cffi:mem-ref column-precision-ptr 'sql-u-len) + (cffi:mem-ref column-scale-ptr 'sql-small-int) + (cffi:mem-ref column-nullable-p-ptr 'sql-small-int))))) @@ -590,43 +550,14 @@ (fetch-all-rows hstmt))) -(defun %sql-data-sources (henv &key (direction :first)) - (with-temporary-allocations - ((name-ptr (alloc-chars (1+ $SQL_MAX_DSN_LENGTH))) - (name-length-ptr (cffi:foreign-alloc :short)) - (description-ptr (alloc-chars 1024)) - (description-length-ptr (cffi:foreign-alloc :short))) - (let ((res (with-error-handling - (:henv henv) - (SQLDataSources henv - (ecase direction - (:first $SQL_FETCH_FIRST) - (:next $SQL_FETCH_NEXT)) - name-ptr - (1+ $SQL_MAX_DSN_LENGTH) - name-length-ptr - description-ptr - 1024 - description-length-ptr)))) - (unless (= res $SQL_NO_DATA_FOUND) - (values (get-string-nts name-ptr) - (get-string-nts description-ptr)))))) - (defun %sql-prepare (hstmt sql) + (declare (string sql)) (cffi:with-foreign-string (sql-ptr sql) (with-error-handling (:hstmt hstmt) - (SQLPrepare hstmt sql-ptr $SQL_NTS)))) - -;; depending on option, we return a long int or a string; string not implemented -(defun get-connection-option (hdbc option) - (with-temporary-allocations - ((param-ptr (cffi:foreign-alloc :long))) ;#+ignore #.(1+ $SQL_MAX_OPTION_STRING_LENGTH))) - (with-error-handling (:hdbc hdbc) - (SQLGetConnectOption hdbc option param-ptr) - (cffi:mem-ref param-ptr :long)))) + (SQLPrepare hstmt sql-ptr $SQL_NTS)))) (defun set-connection-option (hdbc option param) (with-error-handling (:hdbc hdbc) - (SQLSetConnectOption hdbc option param))) + (SQLSetConnectOption hdbc option param))) (defun disable-autocommit (hdbc) @@ -637,5 +568,5 @@ -*** +;;;*** ;;; rav, 11.6.2005 ;;; added tracing support @@ -643,10 +574,11 @@ (defun set-connection-attr-integer (hdbc option val) (with-error-handling (:hdbc hdbc) - (SQLSetConnectAttr_long hdbc option val 0))) + (SQLSetConnectAttr_long hdbc option val 0))) (defun set-connection-attr-string (hdbc option val) - (with-error-handling (:hdbc hdbc) - (cffi:with-foreign-string (ptr val) - (SQLSetConnectAttr_string hdbc option ptr (length val))))) + (with-error-handling (:hdbc hdbc) + (cffi:with-foreign-string (ptr val) + ;; TODO: Null-terminator with length? + (SQLSetConnectAttr_string hdbc option ptr (length val))))) (defun %start-connection-trace (hdbc filename) @@ -656,63 +588,17 @@ (defun %stop-connection-trace (hdbc) (set-connection-attr-integer hdbc $SQL_ATTR_TRACE $SQL_OPT_TRACE_OFF)) - - -(defun get-connection-attr-integer (hdbc attr) - (with-temporary-allocations - ((ptr (cffi:foreign-alloc :long)) - (lenptr (cffi:foreign-alloc :long))) - (with-error-handling (:hdbc hdbc) - (SQLGetConnectAttr hdbc attr ptr 0 lenptr)) - (cffi:mem-ref ptr :long))) - -(defun get-connection-attr-string (hdbc attr) - (with-temporary-allocations - ((ptr (alloc-chars 256)) - (lenptr (cffi:foreign-alloc :long))) - (with-error-handling (:hdbc hdbc) - (SQLGetConnectAttr hdbc attr ptr 256 lenptr)) - (get-string ptr (cffi:mem-ref lenptr :long)))) - -;;; small test for the get-connection-attr -(defun %get-current-catalog (hdbc) - (get-connection-attr-string hdbc $SQL_ATTR_CURRENT_CATALOG)) - -(defun %set-current-catalog (hdbc catalog) - (set-connection-attr-string hdbc $SQL_ATTR_CURRENT_CATALOG catalog)) - - - -(defun %connection-ok-p (hdbc) - (with-error-handling (:hdbc hdbc) - (ecase (get-connection-attr-integer hdbc $SQL_ATTR_CONNECTION_DEAD) - (#.$sql_cd_true nil) - (#.$sql_cd_false t)))) ;;; - - -(defun %sql-set-pos (hstmt row option lock) - (with-error-handling - (:hstmt hstmt) - (SQLSetPos hstmt row option lock))) - -(defun %sql-extended-fetch (hstmt fetch-type row) - (with-temporary-allocations - ((row-count-ptr (cffi:foreign-alloc :unsigned-long)) - (row-status-ptr (cffi:foreign-alloc :short))) - (with-error-handling (:hstmt hstmt) - (SQLExtendedFetch hstmt fetch-type row row-count-ptr - row-status-ptr) - (values (cffi:mem-ref row-count-ptr :unsigned-long) - (cffi:mem-ref row-status-ptr :short))))) ; column-nr is zero-based (defun %sql-get-data (hstmt column-nr c-type data-ptr precision out-len-ptr) - (with-error-handling - (:hstmt hstmt :print-info nil) - (SQLGetData hstmt (if (eq column-nr :bookmark) 0 (1+ column-nr)) - c-type data-ptr precision out-len-ptr))) + (declare (type (integer 0) column-nr)) + (with-error-handling + (:hstmt hstmt :print-info nil) + (SQLGetData hstmt (if (eq column-nr :bookmark) 0 (1+ column-nr)) + c-type data-ptr precision out-len-ptr))) (defun %sql-get-data-raw (hstmt position c-type data-ptr buffer-length ind-ptr) + (declare (type (integer 0) position)) (SQLGetData hstmt (1+ position) c-type data-ptr buffer-length ind-ptr)) @@ -727,5 +613,5 @@ (with-error-handling (:hstmt hstmt :print-info t) ;; nil - (SQLPutData hstmt data-ptr size))) + (SQLPutData hstmt data-ptr size))) Index: combined/src/odbc/odbc-main.lisp =================================================================== --- combined/src/odbc/odbc-main.lisp (revision combined,1) +++ combined/src/odbc/odbc-main.lisp (revision combined,3) @@ -455,12 +455,16 @@ (send-parameter-data param hstmt))))))))) -;; this functions works only, since we store at -;; value-ptr the position of the parameter -(defun sql-param-data-position (hstmt) - (with-temporary-allocations +;; this functions works only, since we store at value-ptr the position +;; of the parameter +;; dso-- +(defun sql-param-data-position (hstmt) + (with-temporary-allocations ((ptr (cffi:foreign-alloc :pointer))) - (let ((res (with-error-handling (:hstmt hstmt) (%sql-param-data hstmt ptr)))) - (values res (if (= res $SQL_NEED_DATA) - (cffi:mem-ref (cffi:mem-ref ptr :pointer) :long )))))) + (let ((res (with-error-handling (:hstmt hstmt) + (%sql-param-data hstmt ptr)))) + (values res (if (= res $SQL_NEED_DATA) + (cffi:mem-ref (cffi:mem-ref ptr :pointer) :int32)))))) + ; TODO: The :int32 above + ; should probably be changed! (defmethod exec-prepared-query ((query prepared-statement) &rest parameters) Index: combined/src/odbc/odbc-utilities.lisp =================================================================== --- combined/src/odbc/odbc-utilities.lisp (revision combined,1) +++ combined/src/odbc/odbc-utilities.lisp (revision combined,3) @@ -12,4 +12,6 @@ (defvar *default-oracle-dsn* "default-oracle-dsn") (defvar *default-sql-server-dsn* "default-sql-server-dsn") +(defvar *default-mysql-dsn* "default-mysql-dsn") + @@ -42,4 +44,9 @@ ))) +(defun connect-mysql (server user password) + (connect-generic :dsn *default-mysql-dsn* + :server server :uid user :pwd password)) + + (defun with-prepared-statement-fun (con string params fun) (let ((stm (apply #'prepare-statement con string params))) Index: combined/src/odbc/parameter.lisp =================================================================== --- combined/src/odbc/parameter.lisp (revision combined,1) +++ combined/src/odbc/parameter.lisp (revision combined,3) @@ -55,7 +55,7 @@ (defun bind-parameter (hstmt pos param) - (setf (slot-value param 'ind-ptr) - (cffi:foreign-alloc :long)) - (%sql-bind-parameter + (setf (slot-value param 'ind-ptr) + (cffi:foreign-alloc 'sql-len)) + (%sql-bind-parameter hstmt pos @@ -110,18 +110,20 @@ (cond ((null value) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) - $SQL_NULL_DATA) - (put-string (slot-value param 'value-ptr) "")) - (t - (cffi:lisp-string-to-foreign value (slot-value param 'value-ptr) (1+ (length value))) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) - (length value))))) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) + $SQL_NULL_DATA) + (put-string (slot-value param 'value-ptr) "")) + (t + (cffi:lisp-string-to-foreign value + (slot-value param 'value-ptr) + (1+ (length value))) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) + (length value))))) (defmethod get-parameter-value ((param string-parameter)) - (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) :long))) + (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len))) (if (= len $SQL_NULL_DATA) - nil - (progn - (get-string (slot-value param 'value-ptr) len))))) + nil + (progn + (get-string (slot-value param 'value-ptr) len))))) ;;------------------------ @@ -132,5 +134,6 @@ (defmethod initialize-parameter ((param unicode-string-parameter) args) - (let ((length-of-buffer (* 2 (or (car args) *default-string-parameter-size*)))) + (let ((length-of-buffer + (* 2 (or (car args) *default-string-parameter-size*)))) (with-slots (value-type parameter-type buffer-length column-size value-ptr @@ -145,19 +148,19 @@ (cond ((null value) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) - $SQL_NULL_DATA) - ;; not necessary - (%put-unicode-string (slot-value param 'value-ptr) "")) - (t - (%put-unicode-string (slot-value param 'value-ptr) value) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) - (* 2 (length value)))))) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) + $SQL_NULL_DATA) + ;; not necessary + (%put-unicode-string (slot-value param 'value-ptr) "")) + (t + (%put-unicode-string (slot-value param 'value-ptr) value) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) + (* 2 (length value)))))) (defmethod get-parameter-value ((param unicode-string-parameter)) - (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) :long))) + (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len))) (if (= len $SQL_NULL_DATA) - nil - (progn - (%get-unicode-string (slot-value param 'value-ptr) len))))) + nil + (progn + (%get-unicode-string (slot-value param 'value-ptr) len))))) ;;---------------------- @@ -174,22 +177,22 @@ (setf value-type $SQL_C_LONG) (setf parameter-type $SQL_INTEGER) - (setf buffer-length 4) - (setf value-ptr (cffi:foreign-alloc :long)))) + (setf buffer-length (cffi:foreign-type-size 'sql-integer)) + (setf value-ptr (cffi:foreign-alloc 'sql-integer)))) (defmethod set-parameter-value ((param integer-parameter) value) - (cond + (cond ((null value) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) - $SQL_NULL_DATA)) - (t (setf (cffi:mem-ref (slot-value param 'value-ptr) :long) - value) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) 0)))) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) + $SQL_NULL_DATA)) + (t (setf (cffi:mem-ref (slot-value param 'value-ptr) 'sql-integer) + value) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) 0)))) (defmethod get-parameter-value ((param integer-parameter)) - (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) :long))) + (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len))) (if (= len $SQL_NULL_DATA) - nil - (progn - (cffi:mem-ref (slot-value param 'value-ptr) :long))))) + nil + (progn + (cffi:mem-ref (slot-value param 'value-ptr) 'sql-integer))))) @@ -203,23 +206,24 @@ (defmethod initialize-parameter ((param double-parameter) args) (assert (not args)) - (with-slots (value-type parameter-type buffer-length value-ptr - ind-ptr) param - (setf value-type $SQL_C_DOUBLE) - (setf parameter-type $SQL_DOUBLE) - (setf buffer-length 8) - (setf value-ptr (cffi:foreign-alloc :double )))) + (with-slots (value-type parameter-type buffer-length value-ptr + ind-ptr) param + (setf value-type $SQL_C_DOUBLE) + (setf parameter-type $SQL_DOUBLE) + (setf buffer-length (cffi:foreign-type-size :double)) + (setf value-ptr (cffi:foreign-alloc :double)))) (defmethod set-parameter-value ((param double-parameter) value) - (cond - ((null value) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) - $SQL_NULL_DATA)) - (t - (setf (cffi:mem-ref (slot-value param 'value-ptr) :double) - (coerce value 'double-float)) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) 8)))) + (cond + ((null value) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) + $SQL_NULL_DATA)) + (t + (setf (cffi:mem-ref (slot-value param 'value-ptr) :double) + (coerce value 'double-float)) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) + (cffi:foreign-type-size :double))))) (defmethod get-parameter-value ((param double-parameter)) - (if (= (cffi:mem-ref (slot-value param 'ind-ptr) :long) $SQL_NULL_DATA) + (if (= (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) $SQL_NULL_DATA) nil (cffi:mem-ref (slot-value param 'value-ptr) :double))) @@ -242,23 +246,22 @@ (setf value-ptr (cffi:foreign-alloc :uchar :count 24)))) - (defmethod set-parameter-value ((param date-parameter) value) (if (null value) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) $SQL_NULL_DATA) - (progn - ;; fixme warum 1? - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) 1) - (multiple-value-bind (sec min hour day month year) - (decode-universal-time - (funcall *date-datatype-to-universal-time* value)) - (%put-sql-c-timestamp (slot-value param 'value-ptr) year month day hour min sec 0))))) + (progn + ;; fixme warum 1? + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) 1) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time + (funcall *date-datatype-to-universal-time* value)) + (%put-sql-c-timestamp (slot-value param 'value-ptr) year month day hour min sec 0))))) (defmethod get-parameter-value ((param date-parameter)) - (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) :long))) - (if (= len $SQL_NULL_DATA) - nil - (funcall *universal-time-to-date-dataype* - (timestamp-to-universal-time (slot-value param 'value-ptr)))))) + (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len))) + (if (= len $SQL_NULL_DATA) + nil + (funcall *universal-time-to-date-dataype* + (timestamp-to-universal-time (slot-value param 'value-ptr)))))) @@ -280,25 +283,24 @@ (defmethod set-parameter-value ((param binary-parameter) value) -(if (null value) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) - $SQL_NULL_DATA) - (if (< (slot-value param 'buffer-length) (length value)) - (progn - (error "buffer is to small") - ; we could increase the buffer size with another bind parameter - ; or set data_at_execution =1 - ) - (progn - ;(break) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) - (length value)) - (put-byte-vector (slot-value param 'value-ptr) value))))) + (if (null value) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) + $SQL_NULL_DATA) + (if (< (slot-value param 'buffer-length) (length value)) + (progn + (error "buffer is to small") + ;; we could increase the buffer size with another bind + ;; parameter or set data_at_execution =1 + ) + (progn + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) + (length value)) + (put-byte-vector (slot-value param 'value-ptr) value))))) (defmethod get-parameter-value ((param binary-parameter)) - (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) :long))) + (let ((len (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len))) (if (= len $SQL_NULL_DATA) - nil - (get-byte-vector (slot-value param 'value-ptr) len)))) + nil + (get-byte-vector (slot-value param 'value-ptr) len)))) @@ -323,16 +325,16 @@ ;; the value-ptr will be needed to find the parameter, ;; we store the position there - (setf buffer-length 4) - (setf value-ptr (cffi:foreign-alloc :long)))) + (setf buffer-length (cffi:foreign-type-size 'sql-pointer)) + (setf value-ptr (cffi:foreign-alloc 'sql-pointer)))) (defmethod set-parameter-value ((param clob-parameter) value) (if (null value) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) $SQL_NULL_DATA) - (progn - (setf (slot-value param 'temp-val) value) - (setf (cffi:mem-ref (slot-value param 'value-ptr) :long) - (slot-value param 'position)) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) + (progn + (setf (slot-value param 'temp-val) value) + (setf (cffi:mem-ref (slot-value param 'value-ptr) :long) + (slot-value param 'position)) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) (%sql-len-data-at-exec (length value)))))) @@ -373,16 +375,16 @@ ;; the value-ptr will be needed to find the parameter, ;; we store the position there - (setf buffer-length 4) - (setf value-ptr (cffi:foreign-alloc :long)))) + (setf buffer-length (cffi:foreign-type-size 'sql-pointer)) + (setf value-ptr (cffi:foreign-alloc 'sql-pointer)))) (defmethod set-parameter-value ((param uclob-parameter) value) (if (null value) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) $SQL_NULL_DATA) (progn (setf (slot-value param 'temp-val) value) - (setf (cffi:mem-ref (slot-value param 'value-ptr) :long) + (setf (cffi:mem-ref (slot-value param 'value-ptr) ':long) (slot-value param 'position)) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) (%sql-len-data-at-exec (* 2 (length value))))))) @@ -422,17 +424,19 @@ ;; the value-ptr will be needed to find the parameter, ;; we store the position there - (setf buffer-length 4) - (setf value-ptr (cffi:foreign-alloc :long)))) + (setf buffer-length (cffi:foreign-type-size 'sql-pointer)) + (setf value-ptr (cffi:foreign-alloc 'sql-pointer))) +) (defmethod set-parameter-value ((param blob-parameter) value) (if (null value) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) $SQL_NULL_DATA) (progn (setf (slot-value param 'temp-val) value) - (setf (cffi:mem-ref (slot-value param 'value-ptr) :long) + (setf (cffi:mem-ref (slot-value param 'value-ptr) ':long) (slot-value param 'position)) - (setf (cffi:mem-ref (slot-value param 'ind-ptr) :long) - (%sql-len-data-at-exec (length value)))))) + (setf (cffi:mem-ref (slot-value param 'ind-ptr) 'sql-len) + (%sql-len-data-at-exec (length value))) + ))) (defmethod send-parameter-data ((param blob-parameter) hstmt) @@ -440,5 +444,5 @@ (len (length temp-val)) (buffer (cffi:foreign-alloc :uchar - :count (if (zerop len) 1 len)))) + :count (if (zerop len) 1 len)))) (put-byte-vector buffer temp-val) Index: combined/src/test/test-mysql.lisp =================================================================== --- combined/src/test/test-mysql.lisp (revision combined,1) +++ combined/src/test/test-mysql.lisp (revision combined,3) @@ -12,4 +12,5 @@ (mysql-test4 con) (mysql-test5 con) + (mysql-test6 con) ) @@ -186,2 +187,28 @@ (commit con) ) + + +(defun mysql-drop-test-proc (con proc) + (unless (zerop (caar (exec-query con (format nil + " + select count(*) + from information_schema.routines + where routine_name ='~A' + and routine_schema='test'" proc)))) + (exec-command con (format nil "drop procedure ~A" proc)))) + + +(defun mysql-test6 (con) + (mysql-drop-test-proc con "test99") + (exec-command con " +CREATE PROCEDURE test99 (in p1 int, out p2 INT) + BEGIN + set p2=p1+5; + END;") + (commit con) + (pprint + (let ((stm (prepare-statement con "{call test.test99(?,?)}" + '(:integer :in) + '(:integer :out)))) + (assert (= 6 (first (exec-prepared-command stm 1)))) + (free-statement stm))) Index: combined/src/test/test-oracle.lisp =================================================================== --- combined/src/test/test-oracle.lisp (revision combined,1) +++ combined/src/test/test-oracle.lisp (revision combined,3) @@ -64,7 +64,8 @@ con "update type_test set t_blob=?,t_clob=? where id =1" '(:blob :in) '(:clob :in)))) - (exec-prepared-update stm - (make-array 10000 :element-type '(unsigned-byte 8) :initial-element 33) - (make-string 100001 :initial-element #\o))) + (exec-prepared-update + stm ;; sizes were 100000 and 100001 + (make-array 100000 :element-type '(unsigned-byte 8) :initial-element 33) + (make-string 1000001 :initial-element #\o))) (commit con))