Index: combined/src/odbc/cffi-support.lisp =================================================================== --- combined/src/odbc/cffi-support.lisp (revision combined,1) +++ combined/src/odbc/cffi-support.lisp (revision combined,2.1.1) @@ -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/odbc-ff-interface.lisp =================================================================== --- combined/src/odbc/odbc-ff-interface.lisp (revision combined,1) +++ combined/src/odbc/odbc-ff-interface.lisp (revision combined,2.1.1) @@ -31,235 +31,199 @@ -(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 - ) +;;;; 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-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 +241,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 +288,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 +297,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 +309,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,2.1.1) @@ -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,23 @@ ()) +;;;; 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)) ; TODO: How do we know this is + ; big enough? + (error-message (alloc-chars #.$SQL_MAX_MESSAGE_LENGTH)) + (error-code (cffi:foreign-alloc 'sql-integer)) + (msg-length (cffi:foreign-alloc 'sql-small-int))) + ;; TODO: Does this include null-terminator for error-message? + (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)))) @@ -66,13 +70,14 @@ ;; problem: calling SQLError clears the error state ;#+ignore +;;;; dso+ (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) )) @@ -164,29 +169,27 @@ +;;;; dso+ (defun %new-environment-handle () - (cffi:with-foreign-object (phenv 'sql-handle) + (declare (ftype sql-h-env)) + (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)))) + +;;;; dso+ (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)))) + +;;;; dso+ (defun %free-statement (hstmt option) - (with-error-handling + (with-error-handling (:hstmt hstmt) - (SQLFreeStmt - hstmt + (SQLFreeStmt + hstmt (ecase option (:drop $SQL_DROP) @@ -217,15 +220,8 @@ ;; 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)))))) - ;; +;;;; dso+ (defun %sql-driver-connect (henv hdbc connection-string completion-option) + (declare (string connection-string)) (let ((completion-option (ecase completion-option @@ -234,65 +230,75 @@ (: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 ; TODO: Should this 1023, for + ; the terminating char? + length-ptr + completion-option)) (get-string-nts complete-connection-str-ptr))))) +;;;; dso+ (defun %disconnect (hdbc) - (with-error-handling - (:hdbc hdbc) - (SQLDisconnect hdbc))) - + (with-error-handling + (:hdbc hdbc) + (SQLDisconnect hdbc))) + +;;;; dso+ (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))) + +;;;; dso+ (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. +;;;; dso+ (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 ((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 +;;;; dso+ (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 ((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) + ))) + +;;;; dso+ (defun %sql-fetch (hstmt) (with-error-handling @@ -300,12 +306,14 @@ (SQLFetch hstmt))) +;;;; dso+ (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)))) + +;;;; dso+ (defun %sql-get-info (hdbc info-type) (ecase info-type @@ -344,15 +352,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 +393,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 +449,18 @@ #.$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 + ((info-ptr (cffi:foreign-alloc :uint32)) ; TODO: It'd be nice + ; to have this as a + ; sql-* type. + (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 +472,42 @@ #.$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)))))) + +;;;; dso+ (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)))) + +;;;; dso+ (defun %sql-execute (hstmt) (with-error-handling - (:hstmt hstmt) - (SQLExecute hstmt))) - + (:hstmt hstmt) + (SQLExecute hstmt))) + +;;;; dso+ (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)))) + +;;;; dso+ (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)))) @@ -507,57 +516,29 @@ ;; Column counting is 1-based +;;;; dso+ (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 ((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 + ;; TODO: Does 256 leave room for terminating + ;; nulls? + 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 +571,16 @@ (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)))))) - - + +;;;; dso+ (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)))) + +;;;; dso+ (defun set-connection-option (hdbc option param) (with-error-handling (:hdbc hdbc) - (SQLSetConnectOption hdbc option param))) + (SQLSetConnectOption hdbc option param))) (defun disable-autocommit (hdbc) @@ -641,12 +595,15 @@ ;;; added tracing support +;;;; dso+ (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))) + +;;;; dso+ (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) @@ -691,32 +648,21 @@ ;;; - -(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 +;;;; dso+ (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 ((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))) + +;;;; dso+ (defun %sql-get-data-raw (hstmt position c-type data-ptr buffer-length ind-ptr) + (declare ((integer 0) position)) (SQLGetData hstmt (1+ position) c-type data-ptr buffer-length ind-ptr)) +;;;; dso+ (defun %sql-param-data (hstmt param-ptr) (with-error-handling (:hstmt hstmt :print-info t) ;; nil @@ -724,10 +670,12 @@ +;;;; dso+ (defun %sql-put-data (hstmt data-ptr size) (with-error-handling (:hstmt hstmt :print-info t) ;; nil - (SQLPutData hstmt data-ptr size))) - - + (SQLPutData hstmt data-ptr size))) + + +;;;; dso+ (defun %sql-more-results (hstmt) (let ((res (SQLMoreResults hstmt))) Index: combined/src/odbc/parameter.lisp =================================================================== --- combined/src/odbc/parameter.lisp (revision combined,1) +++ combined/src/odbc/parameter.lisp (revision combined,2.1.1) @@ -54,7 +54,8 @@ param))) +;;;; dso: not so sure about this one and its callers (defun bind-parameter (hstmt pos param) (setf (slot-value param 'ind-ptr) - (cffi:foreign-alloc :long)) + (cffi:foreign-alloc 'sql-len)) (%sql-bind-parameter hstmt @@ -175,5 +176,5 @@ (setf parameter-type $SQL_INTEGER) (setf buffer-length 4) - (setf value-ptr (cffi:foreign-alloc :long)))) + (setf value-ptr (cffi:foreign-alloc 'sql-integer)))) (defmethod set-parameter-value ((param integer-parameter) value) @@ -324,5 +325,5 @@ ;; we store the position there (setf buffer-length 4) - (setf value-ptr (cffi:foreign-alloc :long)))) + (setf value-ptr (cffi:foreign-alloc 'sql-len)))) (defmethod set-parameter-value ((param clob-parameter) value) @@ -374,5 +375,5 @@ ;; we store the position there (setf buffer-length 4) - (setf value-ptr (cffi:foreign-alloc :long)))) + (setf value-ptr (cffi:foreign-alloc 'sql-len)))) (defmethod set-parameter-value ((param uclob-parameter) value) @@ -423,5 +424,5 @@ ;; we store the position there (setf buffer-length 4) - (setf value-ptr (cffi:foreign-alloc :long)))) + (setf value-ptr (cffi:foreign-alloc 'sql-len)))) (defmethod set-parameter-value ((param blob-parameter) value)