X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=db-odbc%2Fodbc-api.lisp;h=a15d628f8c3c82120ed7cbf7e91f00ba5f6465b2;hb=d107be8f0cad113b96b6cfe443cc4d7c08126db4;hp=915de7e2c7870a1ca1145fab70da2342d8c9303c;hpb=d0f147d0e7d942b379bd7cd472f26b00c33916bc;p=clsql.git diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index 915de7e..a15d628 100644 --- a/db-odbc/odbc-api.lisp +++ b/db-odbc/odbc-api.lisp @@ -31,12 +31,10 @@ May be locally bound to something else if a certain type is necessary.") as possible second argument) to the desired representation of date/time/timestamp.") (defvar +null-ptr+ (make-null-pointer :byte)) +(defparameter +null-handle-ptr+ (make-null-pointer :void)) (defvar *info-output* nil "Stream to send SUCCESS_WITH_INFO messages.") -(defun %null-ptr () - (make-null-pointer :byte)) - (defmacro %put-str (ptr string &optional max-length) (let ((size (gensym))) `(let ((,size (length ,string))) @@ -59,36 +57,36 @@ as possible second argument) to the desired representation of date/time/timestam (defun handle-error (henv hdbc hstmt) (let ((sql-state (allocate-foreign-string 256)) - (error-message (allocate-foreign-string $SQL_MAX_MESSAGE_LENGTH))) + (error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH))) (with-foreign-objects ((error-code :long) (msg-length :short)) (SQLError henv hdbc hstmt sql-state error-code error-message - $SQL_MAX_MESSAGE_LENGTH msg-length) - (values - (prog1 - (convert-from-foreign-string error-message) - (free-foreign-object error-message)) - (prog1 - (convert-from-foreign-string sql-state) - (free-foreign-object error-message)) - (deref-pointer msg-length :short) - (deref-pointer error-code :long))))) + #.$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 :long)))))) (defun sql-state (henv hdbc hstmt) (let ((sql-state (allocate-foreign-string 256)) - (error-message (allocate-foreign-string $SQL_MAX_MESSAGE_LENGTH))) + (error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH))) (with-foreign-objects ((error-code :long) (msg-length :short)) (SQLError henv hdbc hstmt sql-state error-code - error-message $SQL_MAX_MESSAGE_LENGTH msg-length) - (free-foreign-object error-message) - (prog1 - (convert-from-foreign-string sql-state) - (free-foreign-object sql-state))) - ;; test this: return a keyword for efficiency - ;;(%cstring-to-keyword sql-state) - )) + 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) + )))) (defmacro with-error-handling ((&key henv hdbc hstmt (print-info t)) odbc-call &body body) @@ -100,9 +98,9 @@ as possible second argument) to the desired representation of date/time/timestam (#.$SQL_SUCCESS_WITH_INFO (when ,print-info (multiple-value-bind (error-message sql-state) - (handle-error (or ,henv +null-ptr+) - (or ,hdbc +null-ptr+) - (or ,hstmt +null-ptr+)) + (handle-error (or ,henv +null-handle-ptr+) + (or ,hdbc +null-handle-ptr+) + (or ,hstmt +null-handle-ptr+)) (when *info-output* (format *info-output* "[ODBC info ~A] ~A state: ~A" ,result-code error-message @@ -118,9 +116,9 @@ as possible second argument) to the desired representation of date/time/timestam :odbc-message "Still executing")) (#.$SQL_ERROR (multiple-value-bind (error-message sql-state) - (handle-error (or ,henv +null-ptr+) - (or ,hdbc +null-ptr+) - (or ,hstmt +null-ptr+)) + (handle-error (or ,henv +null-handle-ptr+) + (or ,hdbc +null-handle-ptr+) + (or ,hstmt +null-handle-ptr+)) (error 'clsql-base-sys:clsql-odbc-error :odbc-message error-message @@ -276,9 +274,9 @@ as possible second argument) to the desired representation of date/time/timestam (with-error-handling (:hdbc hdbc) (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr) - (prog1 - (convert-from-foreign-string info-ptr) - (free-foreign-object info-ptr)))))) + (let ((info (convert-from-foreign-string info-ptr))) + (free-foreign-object info-ptr) + info))))) ;; those returning a word ((#.$SQL_ACTIVE_CONNECTIONS #.$SQL_ACTIVE_STATEMENTS @@ -427,7 +425,7 @@ as possible second argument) to the desired representation of date/time/timestam (let ((column-name-ptr (allocate-foreign-string 256))) (with-foreign-objects ((column-name-length-ptr :short) (column-sql-type-ptr :short) - (column-precision-ptr :long) + (column-precision-ptr :unsigned-long) (column-scale-ptr :short) (column-nullable-p-ptr :short)) (with-error-handling (:hstmt hstmt) @@ -442,14 +440,14 @@ as possible second argument) to the desired representation of date/time/timestam (values column-name (deref-pointer column-sql-type-ptr :short) - (deref-pointer column-precision-ptr :long) + (deref-pointer column-precision-ptr :unsigned-long) (deref-pointer column-scale-ptr :short) (deref-pointer column-nullable-p-ptr :short))))))) ;; parameter counting is 1-based (defun %describe-parameter (hstmt parameter-nr) (with-foreign-objects ((column-sql-type-ptr :short) - (column-precision-ptr :long) + (column-precision-ptr :unsigned-long) (column-scale-ptr :short) (column-nullable-p-ptr :short)) (with-error-handling @@ -461,7 +459,7 @@ as possible second argument) to the desired representation of date/time/timestam column-nullable-p-ptr) (values (deref-pointer column-sql-type-ptr :short) - (deref-pointer column-precision-ptr :long) + (deref-pointer column-precision-ptr :unsigned-long) (deref-pointer column-scale-ptr :short) (deref-pointer column-nullable-p-ptr :short))))) @@ -474,11 +472,11 @@ as possible second argument) to the desired representation of date/time/timestam (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr 256 descriptor-length-ptr numeric-descriptor-ptr) - (values - (prog1 - (convert-from-foreign-string descriptor-info-ptr) - (free-foreign-object descriptor-info-ptr)) - (deref-pointer numeric-descriptor-ptr :long)))))) + (let ((desc (convert-from-foreign-string descriptor-info-ptr))) + (free-foreign-object descriptor-info-ptr) + (values + desc + (deref-pointer numeric-descriptor-ptr :long))))))) (defun %prepare-describe-columns (hstmt table-qualifier table-owner table-name column-name) @@ -518,14 +516,21 @@ as possible second argument) to the desired representation of date/time/timestam description-ptr 1024 description-length-ptr)))) - (unless (= res $SQL_NO_DATA_FOUND) - (values - (prog1 - (convert-from-foreign-string name-ptr) - (free-foreign-object name-ptr)) - (prog1 - (convert-from-foreign-string description-ptr) - (free-foreign-object description-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)))))) + + (defun sql-to-c-type (sql-type) (ecase sql-type @@ -534,8 +539,8 @@ as possible second argument) to the desired representation of date/time/timestam (#.$SQL_INTEGER $SQL_C_SLONG) (#.$SQL_SMALLINT $SQL_C_SSHORT) (#.$SQL_DOUBLE $SQL_C_DOUBLE) - (#.$SQL_FLOAT $SQL_C_FLOAT) - (#.$SQL_REAL $SQL_C_DOUBLE) + (#.$SQL_FLOAT $SQL_C_DOUBLE) + (#.$SQL_REAL $SQL_C_FLOAT) (#.$SQL_DATE $SQL_C_DATE) (#.$SQL_TIME $SQL_C_TIME) (#.$SQL_TIMESTAMP $SQL_C_TIMESTAMP) @@ -615,8 +620,7 @@ as possible second argument) to the desired representation of date/time/timestam (#.$SQL_INTEGER (get-cast-int data-ptr)) (#.$SQL_BIGINT (read-from-string (get-cast-foreign-string data-ptr))) - (#.$SQL_TINYINT (read-from-string - (get-cast-foreign-string data-ptr))) + (#.$SQL_TINYINT (get-cast-byte data-ptr)) (#.$SQL_DECIMAL (let ((*read-base* 10)) (read-from-string (get-cast-foreign-string data-ptr)))) @@ -676,14 +680,13 @@ as possible second argument) to the desired representation of date/time/timestam (data-ptr (case c-type ;; add more? (#.$SQL_C_SLONG (uffi:allocate-foreign-object :long)) - (#.$SQL_C_DOUBLE (uffi:allocate-foreign-object :double)) (#.$SQL_C_DATE (allocate-foreign-object 'sql-c-date)) (#.$SQL_C_TIME (allocate-foreign-object 'sql-c-time)) (#.$SQL_C_TIMESTAMP (allocate-foreign-object 'sql-c-timestamp)) (#.$SQL_C_FLOAT (uffi:allocate-foreign-object :float)) - (#.$SQL_REAL (uffi:allocate-foreign-object :float)) + (#.$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_STINYINT (uffi:allocate-foreign-object :short)) (#.$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)))) @@ -692,7 +695,7 @@ as possible second argument) to the desired representation of date/time/timestam (when *break-on-unknown-data-type* (break "SQL type is ~A, precision ~D, size ~D, C type is ~A" sql-type precision size c-type)) - (uffi:allocate-foreign-object :pointer-void (1+ size))))) + (uffi:allocate-foreign-object :byte (1+ size))))) (out-len-ptr (uffi:allocate-foreign-object :long))) (values c-type data-ptr out-len-ptr size long-p))) @@ -767,7 +770,7 @@ as possible second argument) to the desired representation of date/time/timestam ;; depending on option, we return a long int or a string; string not implemented (defun get-connection-option (hdbc option) - (with-foreign-objects ((param-ptr :long)) + (with-foreign-object (param-ptr :long) (with-error-handling (:hdbc hdbc) (SQLGetConnectOption hdbc option param-ptr) (deref-pointer param-ptr :long)))) @@ -836,7 +839,7 @@ as possible second argument) to the desired representation of date/time/timestam data-length))) (error "wrong type. preliminary.")) while (and (= res $SQL_SUCCESS_WITH_INFO) - (equal (sql-state +null-ptr+ +null-ptr+ hstmt) + (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))) @@ -855,9 +858,9 @@ as possible second argument) to the desired representation of date/time/timestam (error "wrong type. preliminary.")) while (and (= res $SQL_SUCCESS_WITH_INFO) - #+ingore(eq (sql-state +null-ptr+ +null-ptr+ hstmt) + #+ingore(eq (sql-state +null-handle-ptr+ +null-handle-ptr+ hstmt) $sql-data-truncated) - (equal (sql-state +null-ptr+ +null-ptr+ hstmt) + (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) @@ -868,6 +871,8 @@ as possible second argument) to the desired representation of date/time/timestam str)))))) (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))) (defun timestamp-to-universal-time (ptr) (declare (type c-timestamp-ptr-type ptr)) @@ -884,7 +889,7 @@ as possible second argument) to the desired representation of date/time/timestam (defun universal-time-to-timestamp (time &optional (fraction 0)) (multiple-value-bind (sec min hour day month year) (decode-universal-time time) - (with-foreign-object (ptr 'sql-c-timestamp) + (let ((ptr (allocate-foreign-object 'sql-c-timestamp))) (setf (get-slot-value ptr 'sql-c-timestamp 'second) sec (get-slot-value ptr 'sql-c-timestamp 'minute) min (get-slot-value ptr 'sql-c-timestamp 'hour) hour @@ -908,7 +913,7 @@ as possible second argument) to the desired representation of date/time/timestam ptr)) (defun date-to-universal-time (ptr) - (declare (type c-timestamp-ptr-type ptr)) + (declare (type c-date-ptr-type ptr)) (encode-universal-time 0 0 0 (get-slot-value ptr 'sql-c-timestamp 'day) @@ -916,7 +921,7 @@ as possible second argument) to the desired representation of date/time/timestam (get-slot-value ptr 'sql-c-timestamp 'year))) (defun time-to-universal-time (ptr) - (declare (type c-timestamp-type ptr)) + (declare (type c-time-ptr-type ptr)) (encode-universal-time (get-slot-value ptr 'sql-c-timestamp 'second) (get-slot-value ptr 'sql-c-timestamp 'minute)