X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=db-odbc%2Fodbc-api.lisp;h=f01be3127739c4fb1adca4201fac1ab47f2f364f;hb=dd29edebc8540f1439053278723dea90ee2e06e5;hp=dfdbe21ed10fec7bb1e0b6dd6aa872a1efa986d1;hpb=d2d49ab13c98bc7a1819a0fd3968268a5567bdc3;p=clsql.git diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index dfdbe21..f01be31 100644 --- a/db-odbc/odbc-api.lisp +++ b/db-odbc/odbc-api.lisp @@ -56,43 +56,60 @@ as possible second argument) to the desired representation of date/time/timestam (defun %cstring-into-vector (ptr vector offset size-in-bytes) (dotimes (i size-in-bytes) (setf (schar vector offset) - (ensure-char-character - (deref-array ptr '(:array :unsigned-char) i))) + (ensure-char-character + ;; this is MUCH faster than (sb-alien:deref ptr i) even though + ;; sb-alien:deref makes more sense. I snagged this by looking at + ;; cffi which we had used previously without this bug + #+(and sbcl (not cffi)) + (sb-sys:sap-ref-8 (sb-alien:alien-sap ptr) i) + #-(and sbcl (not cffi)) + (deref-array ptr '(:array :unsigned-char) i) + )) (incf offset)) offset) +(defmacro with-allocate-foreign-string ((var len) &body body) + "Safely does uffi:allocate-foreign-string-- making sure we do the uffi:free-foreign-object" + `(let ((,var)) + (unwind-protect + (progn + (setf ,var (uffi:allocate-foreign-string ,len)) + ,@body) + (when ,var + (uffi:free-foreign-object ,var))))) + +(defmacro with-allocate-foreign-strings (bindings &rest body) + (if bindings + `(with-allocate-foreign-string ,(car bindings) + (with-allocate-foreign-strings ,(cdr bindings) + ,@body)) + `(progn ,@body))) + (defun handle-error (henv hdbc hstmt) - (let ((sql-state (allocate-foreign-string 256)) - (error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH))) - (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE) - (msg-length :short)) - (SQLError henv hdbc hstmt sql-state - error-code error-message - #.$SQL_MAX_MESSAGE_LENGTH msg-length) - (let ((err (convert-from-foreign-string error-message)) - (state (convert-from-foreign-string sql-state))) - (free-foreign-object error-message) - (free-foreign-object sql-state) - (values - err - state - (deref-pointer msg-length :short) - (deref-pointer error-code #.$ODBC-LONG-TYPE)))))) + (with-allocate-foreign-strings ((sql-state 256) + (error-message #.$SQL_MAX_MESSAGE_LENGTH)) + (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE) + (msg-length :short)) + (SQLError henv hdbc hstmt sql-state + error-code error-message + #.$SQL_MAX_MESSAGE_LENGTH msg-length) + (values + (convert-from-foreign-string error-message) + (convert-from-foreign-string sql-state) + (deref-pointer msg-length :short) + (deref-pointer error-code #.$ODBC-LONG-TYPE))))) (defun sql-state (henv hdbc hstmt) - (let ((sql-state (allocate-foreign-string 256)) - (error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH))) - (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE) - (msg-length :short)) - (SQLError henv hdbc hstmt sql-state error-code - error-message #.$SQL_MAX_MESSAGE_LENGTH msg-length) - (let ((state (convert-from-foreign-string sql-state))) - (free-foreign-object error-message) - (free-foreign-object sql-state) - state - ;; test this: return a keyword for efficiency - ;;(%cstring-to-keyword state) - )))) + (with-allocate-foreign-strings ((sql-state 256) + (error-message #.$SQL_MAX_MESSAGE_LENGTH)) + (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE) + (msg-length :short)) + (SQLError henv hdbc hstmt sql-state error-code + error-message #.$SQL_MAX_MESSAGE_LENGTH msg-length) + (convert-from-foreign-string sql-state) + ;; test this: return a keyword for efficiency + ;;(%cstring-to-keyword state) + ))) (defmacro with-error-handling ((&key henv hdbc hstmt (print-info t)) odbc-call &body body) @@ -209,23 +226,24 @@ as possible second argument) to the desired representation of date/time/timestam (defun %sql-driver-connect (hdbc connection-string completion window-handle) (with-cstring (connection-ptr connection-string) - (let ((completed-connection-string (allocate-foreign-string $SQL_MAX_CONN_OUT))) - (unwind-protect - (with-foreign-object (completed-connection-length :short) - (with-error-handling - (:hdbc hdbc) - (SQLDriverConnect hdbc - window-handle - connection-ptr $SQL_NTS - completed-connection-string $SQL_MAX_CONN_OUT - completed-connection-length - completion))) - (free-foreign-object completed-connection-string))))) + (with-allocate-foreign-string (completed-connection-string-ptr $SQL_MAX_CONN_OUT) + (with-foreign-object (completed-connection-length :short) + (with-error-handling + (:hdbc hdbc) + (SQLDriverConnect hdbc + window-handle + connection-ptr $SQL_NTS + completed-connection-string-ptr $SQL_MAX_CONN_OUT + completed-connection-length + completion)))))) (defun %disconnect (hdbc) (with-error-handling (:hdbc hdbc) - (SQLDisconnect hdbc))) + (SQLDisconnect hdbc) + (with-error-handling + (:hdbc hdbc) + (SQLFreeHandle $SQL_HANDLE_DBC hdbc)))) (defun %commit (henv hdbc) (with-error-handling @@ -239,7 +257,7 @@ as possible second argument) to the desired representation of date/time/timestam (SQLTransact henv hdbc $SQL_ROLLBACK))) -; col-nr is zero-based in Lisp +; col-nr is zero-based in Lisp but 1 based in sql ; col-nr = :bookmark retrieves a bookmark. (defun %bind-column (hstmt column-nr c-type data-ptr precision out-len-ptr) (with-error-handling @@ -317,14 +335,12 @@ as possible second argument) to the desired representation of date/time/timestam #.$SQL_SPECIAL_CHARACTERS #.$SQL_TABLE_TERM #.$SQL_USER_NAME) - (let ((info-ptr (allocate-foreign-string 1024))) + (with-allocate-foreign-string (info-ptr 1024) (with-foreign-object (info-length-ptr :short) - (with-error-handling - (:hdbc hdbc) - (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr) - (let ((info (convert-from-foreign-string info-ptr))) - (free-foreign-object info-ptr) - info))))) + (with-error-handling + (:hdbc hdbc) + (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr) + (convert-from-foreign-string info-ptr))))) ;; those returning a word ((#.$SQL_ACTIVE_CONNECTIONS #.$SQL_ACTIVE_STATEMENTS @@ -470,29 +486,28 @@ as possible second argument) to the desired representation of date/time/timestam ;; column counting is 1-based (defun %describe-column (hstmt column-nr) - (let ((column-name-ptr (allocate-foreign-string 256))) + (with-allocate-foreign-string (column-name-ptr 256) (with-foreign-objects ((column-name-length-ptr :short) (column-sql-type-ptr :short) (column-precision-ptr #.$ODBC-ULONG-TYPE) (column-scale-ptr :short) (column-nullable-p-ptr :short)) - (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) - (let ((column-name (convert-from-foreign-string column-name-ptr))) - (free-foreign-object column-name-ptr) - (values - column-name - (deref-pointer column-sql-type-ptr :short) - (deref-pointer column-precision-ptr #.$ODBC-ULONG-TYPE) - (deref-pointer column-scale-ptr :short) - (deref-pointer column-nullable-p-ptr :short))))))) + (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) + (values + (convert-from-foreign-string column-name-ptr) + (deref-pointer column-sql-type-ptr :short) + (deref-pointer column-precision-ptr #.$ODBC-ULONG-TYPE) + (deref-pointer column-scale-ptr :short) + (deref-pointer column-nullable-p-ptr :short)))))) ;; parameter counting is 1-based +;; this function isn't used, which is good because FreeTDS dosn't support it. (defun %describe-parameter (hstmt parameter-nr) (with-foreign-objects ((column-sql-type-ptr :short) (column-precision-ptr #.$ODBC-ULONG-TYPE) @@ -512,19 +527,17 @@ as possible second argument) to the desired representation of date/time/timestam (deref-pointer column-nullable-p-ptr :short))))) (defun %column-attributes (hstmt column-nr descriptor-type) - (let ((descriptor-info-ptr (allocate-foreign-string 256))) + (with-allocate-foreign-string (descriptor-info-ptr 256) (with-foreign-objects ((descriptor-length-ptr :short) (numeric-descriptor-ptr #.$ODBC-LONG-TYPE)) - (with-error-handling - (:hstmt hstmt) - (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr - 256 descriptor-length-ptr - numeric-descriptor-ptr) - (let ((desc (convert-from-foreign-string descriptor-info-ptr))) - (free-foreign-object descriptor-info-ptr) - (values - desc - (deref-pointer numeric-descriptor-ptr #.$ODBC-LONG-TYPE))))))) + (with-error-handling + (:hstmt hstmt) + (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr + 256 descriptor-length-ptr + numeric-descriptor-ptr) + (values + (convert-from-foreign-string descriptor-info-ptr) + (deref-pointer numeric-descriptor-ptr #.$ODBC-LONG-TYPE)))))) (defun %prepare-describe-columns (hstmt table-qualifier table-owner table-name column-name) @@ -548,43 +561,35 @@ as possible second argument) to the desired representation of date/time/timestam (fetch-all-rows hstmt))) (defun %sql-data-sources (henv &key (direction :first)) - (let ((name-ptr (allocate-foreign-string (1+ $SQL_MAX_DSN_LENGTH))) - (description-ptr (allocate-foreign-string 1024))) - (with-foreign-objects ((name-length-ptr :short) - (description-length-ptr :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)))) - (cond - ((= res $SQL_NO_DATA_FOUND) - (let ((name (convert-from-foreign-string name-ptr)) - (desc (convert-from-foreign-string description-ptr))) - (free-foreign-object name-ptr) - (free-foreign-object description-ptr) - (values - name - desc))) - (t - (free-foreign-object name-ptr) - (free-foreign-object description-ptr) - nil)))))) + (with-allocate-foreign-strings ((name-ptr (1+ $SQL_MAX_DSN_LENGTH)) + (description-ptr 1024)) + (with-foreign-objects ((name-length-ptr :short) + (description-length-ptr :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)))) + (when (= res $SQL_NO_DATA_FOUND) + (values + (convert-from-foreign-string name-ptr) + (convert-from-foreign-string description-ptr))))))) (defun sql-to-c-type (sql-type) (ecase sql-type ((#.$SQL_CHAR #.$SQL_VARCHAR #.$SQL_LONGVARCHAR - #.$SQL_NUMERIC #.$SQL_DECIMAL #.$SQL_BIGINT -8 -9 -10) $SQL_C_CHAR) ;; Added -10 for MSSQL ntext type + #.$SQL_NUMERIC #.$SQL_DECIMAL -8 -9 -10) $SQL_C_CHAR) ;; Added -10 for MSSQL ntext type (#.$SQL_INTEGER $SQL_C_SLONG) + (#.$SQL_BIGINT $SQL_C_SBIGINT) (#.$SQL_SMALLINT $SQL_C_SSHORT) (#.$SQL_DOUBLE $SQL_C_DOUBLE) (#.$SQL_FLOAT $SQL_C_DOUBLE) @@ -603,6 +608,7 @@ as possible second argument) to the desired representation of date/time/timestam (def-type short-pointer-type (* :short)) (def-type int-pointer-type (* :int)) (def-type long-pointer-type (* #.$ODBC-LONG-TYPE)) +(def-type big-pointer-type (* #.$ODBC-BIG-TYPE)) (def-type float-pointer-type (* :float)) (def-type double-pointer-type (* :double)) (def-type string-pointer-type (* :unsigned-char)) @@ -623,6 +629,10 @@ as possible second argument) to the desired representation of date/time/timestam (locally (declare (type long-pointer-type ptr)) (deref-pointer ptr #.$ODBC-LONG-TYPE))) +(defun get-cast-big (ptr) + (locally (declare (type big-pointer-type ptr)) + (deref-pointer ptr #.$ODBC-BIG-TYPE))) + (defun get-cast-single-float (ptr) (locally (declare (type float-pointer-type ptr)) (deref-pointer ptr :float))) @@ -637,13 +647,13 @@ as possible second argument) to the desired representation of date/time/timestam (defun get-cast-binary (ptr len format) "FORMAT is one of :unsigned-byte-vector, :bit-vector (:string, :hex-string)" - (with-cast-pointer (casted ptr :byte) + (with-cast-pointer (casted ptr :unsigned-byte) (ecase format (:unsigned-byte-vector (let ((vector (make-array len :element-type '(unsigned-byte 8)))) (dotimes (i len) (setf (aref vector i) - (deref-array casted '(:array :byte) i))) + (deref-array casted '(:array :unsigned-byte) i))) vector)) (:bit-vector (let ((vector (make-array (ash len 3) :element-type 'bit))) @@ -657,10 +667,9 @@ as possible second argument) to the desired representation of date/time/timestam (defun read-data (data-ptr c-type sql-type out-len-ptr result-type) (declare (type long-ptr-type out-len-ptr)) - (let* ((out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE)) + (let* ((out-len (get-cast-long out-len-ptr)) (value - (cond ((= out-len $SQL_NULL_DATA) - *null*) + (cond ((= out-len $SQL_NULL_DATA) *null*) (t (case sql-type ;; SQL extended datatypes @@ -669,11 +678,13 @@ as possible second argument) to the desired representation of date/time/timestam (#.$SQL_C_SSHORT (get-cast-short data-ptr)) ;; ? (#.$SQL_SMALLINT (get-cast-short data-ptr)) ;; ?? (#.$SQL_INTEGER (get-cast-int data-ptr)) - (#.$SQL_BIGINT (read-from-string - (get-cast-foreign-string data-ptr))) - (#.$SQL_DECIMAL - (let ((*read-base* 10)) - (read-from-string (get-cast-foreign-string data-ptr)))) + (#.$SQL_BIGINT (get-cast-big data-ptr)) + ;; TODO: Change this to read in rationals instead of doubles + ((#.$SQL_DECIMAL #.$SQL_NUMERIC) + (let* ((*read-base* 10) + (*read-default-float-format* 'double-float) + (str (get-cast-foreign-string data-ptr))) + (read-from-string str))) (#.$SQL_BIT (get-cast-byte data-ptr)) (t (case c-type @@ -700,6 +711,7 @@ as possible second argument) to the desired representation of date/time/timestam (get-cast-binary data-ptr out-len *binary-format*)) ((#.$SQL_C_SSHORT #.$SQL_C_STINYINT) ; LMH short ints (get-cast-short data-ptr)) ; LMH + (#.$SQL_C_SBIGINT (get-cast-big data-ptr)) #+ignore (#.$SQL_C_CHAR (code-char (get-cast-short data-ptr))) @@ -739,6 +751,7 @@ as possible second argument) to the desired representation of date/time/timestam (#.$SQL_C_DOUBLE (uffi:allocate-foreign-object :double)) (#.$SQL_C_BIT (uffi:allocate-foreign-object :byte)) (#.$SQL_C_STINYINT (uffi:allocate-foreign-object :byte)) + (#.$SQL_C_SBIGINT (uffi:allocate-foreign-object #.$ODBC-BIG-TYPE)) (#.$SQL_C_SSHORT (uffi:allocate-foreign-object :short)) (#.$SQL_C_CHAR (uffi:allocate-foreign-string (1+ size))) (#.$SQL_C_BINARY (uffi:allocate-foreign-string (1+ (* 2 size)))) @@ -870,13 +883,14 @@ as possible second argument) to the desired representation of date/time/timestam (defconstant $sql-data-truncated (intern "01004" :keyword)) + (defun read-data-in-chunks (hstmt column-nr data-ptr c-type sql-type out-len-ptr result-type) (declare (type long-ptr-type out-len-ptr) (ignore result-type)) (let* ((res (%sql-get-data hstmt column-nr c-type data-ptr +max-precision+ out-len-ptr)) - (out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE)) + (out-len (get-cast-long out-len-ptr)) (offset 0) (result (case out-len (#.$SQL_NULL_DATA @@ -904,28 +918,30 @@ as possible second argument) to the desired representation of date/time/timestam str))) (otherwise (let ((str (make-string out-len))) - (loop do (if (= c-type #.$SQL_CHAR) - (setf offset (%cstring-into-vector ;string - data-ptr str - offset - (min out-len (1- +max-precision+)))) - (error 'clsql:sql-database-error :message "wrong type. preliminary.")) - while - (and (= res $SQL_SUCCESS_WITH_INFO) - #+ingore(eq (sql-state +null-handle-ptr+ +null-handle-ptr+ hstmt) - $sql-data-truncated) - (equal (sql-state +null-handle-ptr+ +null-handle-ptr+ hstmt) - "01004")) - do (setf res (%sql-get-data hstmt column-nr c-type data-ptr - +max-precision+ out-len-ptr) - out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE))) + (loop + do + (if (= c-type #.$SQL_CHAR) + (setf offset (%cstring-into-vector ;string + data-ptr str + offset + (min out-len (1- +max-precision+)))) + (error 'clsql:sql-database-error :message "wrong type. preliminary.")) + while + (and (= res $SQL_SUCCESS_WITH_INFO) + (>= out-len +max-precision+)) + do (setf res (%sql-get-data hstmt column-nr c-type data-ptr + +max-precision+ out-len-ptr) + out-len (get-cast-long out-len-ptr))) (if (= sql-type $SQL_DECIMAL) - (let ((*read-base* 10)) + (let ((*read-base* 10) + (*read-default-float-format* 'double-float)) (read-from-string str)) - str)))))) + str)))))) + (setf (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE) #.$SQL_NO_TOTAL) ;; reset the out length for the next row result)) + (def-type c-timestamp-ptr-type (* (:struct sql-c-timestamp))) (def-type c-time-ptr-type (* (:struct sql-c-time))) (def-type c-date-ptr-type (* (:struct sql-c-date))) @@ -943,6 +959,7 @@ as possible second argument) to the desired representation of date/time/timestam (get-slot-value ptr 'sql-c-timestamp 'fraction))) (defun universal-time-to-timestamp (time &optional (fraction 0)) + "TODO: Dead function?" (multiple-value-bind (sec min hour day month year) (decode-universal-time time) (let ((ptr (allocate-foreign-object 'sql-c-timestamp))) @@ -956,6 +973,7 @@ as possible second argument) to the desired representation of date/time/timestam ptr))) (defun %put-timestamp (ptr time &optional (fraction 0)) + "TODO: Dead function?" (declare (type c-timestamp-ptr-type ptr)) (multiple-value-bind (sec min hour day month year) (decode-universal-time time) @@ -989,6 +1007,9 @@ as possible second argument) to the desired representation of date/time/timestam (defun %set-attr-odbc-version (henv version) (with-error-handling (:henv henv) + ;;note that we are passing version as an integer that happens to be + ;;stuffed into a pointer. + ;;http://msdn.microsoft.com/en-us/library/ms709285%28v=VS.85%29.aspx (SQLSetEnvAttr henv $SQL_ATTR_ODBC_VERSION (make-pointer version :void) 0))) @@ -1008,33 +1029,28 @@ as possible second argument) to the desired representation of date/time/timestam (if ensure $SQL_ENSURE $SQL_QUICK))))) (defun %list-data-sources (henv) - (let ((dsn (allocate-foreign-string (1+ $SQL_MAX_DSN_LENGTH))) - (desc (allocate-foreign-string 256)) - (results nil)) - (unwind-protect - (with-foreign-objects ((dsn-len :short) - (desc-len :short)) - (let ((res (with-error-handling (:henv henv) - (SQLDataSources henv $SQL_FETCH_FIRST dsn - (1+ $SQL_MAX_DSN_LENGTH) - dsn-len desc 256 desc-len)))) - (when (or (eql res $SQL_SUCCESS) - (eql res $SQL_SUCCESS_WITH_INFO)) - (push (convert-from-foreign-string dsn) results)) - - (do ((res (with-error-handling (:henv henv) - (SQLDataSources henv $SQL_FETCH_NEXT dsn - (1+ $SQL_MAX_DSN_LENGTH) - dsn-len desc 256 desc-len)) - (with-error-handling (:henv henv) - (SQLDataSources henv $SQL_FETCH_NEXT dsn - (1+ $SQL_MAX_DSN_LENGTH) - dsn-len desc 256 desc-len)))) - ((not (or (eql res $SQL_SUCCESS) - (eql res $SQL_SUCCESS_WITH_INFO)))) - (push (convert-from-foreign-string dsn) results)))) - (progn - (free-foreign-object dsn) - (free-foreign-object desc))) + (let ((results nil)) + (with-foreign-strings ((dsn-ptr (1+ $SQL_MAX_DSN_LENGTH)) + (desc-ptr 256)) + (with-foreign-objects ((dsn-len :short) + (desc-len :short)) + (let ((res (with-error-handling (:henv henv) + (SQLDataSources henv $SQL_FETCH_FIRST dsn-ptr + (1+ $SQL_MAX_DSN_LENGTH) + dsn-len desc-ptr 256 desc-len)))) + (when (or (eql res $SQL_SUCCESS) + (eql res $SQL_SUCCESS_WITH_INFO)) + (push (convert-from-foreign-string dsn-ptr) results)) + + (do ((res (with-error-handling (:henv henv) + (SQLDataSources henv $SQL_FETCH_NEXT dsn-ptr + (1+ $SQL_MAX_DSN_LENGTH) + dsn-len desc-ptr 256 desc-len)) + (with-error-handling (:henv henv) + (SQLDataSources henv $SQL_FETCH_NEXT dsn-ptr + (1+ $SQL_MAX_DSN_LENGTH) + dsn-len desc-ptr 256 desc-len)))) + ((not (or (eql res $SQL_SUCCESS) + (eql res $SQL_SUCCESS_WITH_INFO)))) + (push (convert-from-foreign-string dsn-ptr) results))))) (nreverse results))) -