X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=db-odbc%2Fodbc-api.lisp;h=a320d7e3f561543d87314f5469b698de2de48dbe;hb=a6576bcf62dd1e710085ec74089d0730d599001b;hp=915de7e2c7870a1ca1145fab70da2342d8c9303c;hpb=d0f147d0e7d942b379bd7cd472f26b00c33916bc;p=clsql.git diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index 915de7e..a320d7e 100644 --- a/db-odbc/odbc-api.lisp +++ b/db-odbc/odbc-api.lisp @@ -24,19 +24,22 @@ May be locally bound to something else if a certain type is necessary.") (defvar *binary-format* :unsigned-byte-vector) -(defvar *time-conversion-function* (lambda (universal-time &optional fraction) - (declare (ignore fraction)) - universal-time) +(defvar *time-conversion-function* + (lambda (universal-time &optional fraction) + (declare (ignore fraction)) + (clsql-base:format-time + nil (clsql-base:utime->time universal-time) + :format :iso) + #+ignore + universal-time) "Bound to a function that converts from a Lisp universal time fixnum (and a fractional -as possible second argument) to the desired representation of date/time/timestamp.") +as possible second argument) to the desired representation of date/time/timestamp. By default, returns an iso-timestring.") (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 +62,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))) - (with-foreign-objects ((error-code :long) + (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) - (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 #.$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 :long) + (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) - (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 +103,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 @@ -110,19 +113,19 @@ as possible second argument) to the desired representation of date/time/timestam (progn ,result-code ,@body)) (#.$SQL_INVALID_HANDLE (error - 'clsql-base-sys:clsql-odbc-error + 'clsql-base:clsql-odbc-error :odbc-message "Invalid handle")) (#.$SQL_STILL_EXECUTING (error - 'clsql-base-sys:clsql-odbc-error + 'clsql-base:clsql-odbc-error :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 + 'clsql-base:clsql-odbc-error :odbc-message error-message :sql-state sql-state))) (otherwise @@ -229,12 +232,16 @@ as possible second argument) to the desired representation of date/time/timestam (SQLFetch hstmt))) (defun %new-statement-handle (hdbc) - (with-foreign-object (hstmt-ptr 'sql-handle) - (with-error-handling - (:hdbc hdbc) - (SQLAllocStmt hdbc hstmt-ptr) - (deref-pointer hstmt-ptr 'sql-handle)))) - + (let ((statement-handle + (with-foreign-object (hstmt-ptr 'sql-handle) + (with-error-handling + (:hdbc hdbc) + (SQLAllocStmt hdbc hstmt-ptr) + (deref-pointer hstmt-ptr 'sql-handle))))) + (if (uffi:null-pointer-p statement-handle) + (error "Received null statement handle.") + statement-handle))) + (defun %sql-get-info (hdbc info-type) (ecase info-type ;; those return string @@ -276,9 +283,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 @@ -364,7 +371,7 @@ as possible second argument) to the desired representation of date/time/timestam #.$SQL_TIMEDATE_FUNCTIONS #.$SQL_TXN_ISOLATION_OPTION #.$SQL_UNION) - (with-foreign-objects ((info-ptr :long) + (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE) (info-length-ptr :short)) (with-error-handling (:hdbc hdbc) @@ -373,7 +380,7 @@ as possible second argument) to the desired representation of date/time/timestam info-ptr 255 info-length-ptr) - (deref-pointer info-ptr :long))) + (deref-pointer info-ptr #.$ODBC-LONG-TYPE))) ) ;; those returning a long integer ((#.$SQL_DEFAULT_TXN_ISOLATION @@ -387,12 +394,12 @@ as possible second argument) to the desired representation of date/time/timestam #.$SQL_MAX_CHAR_LITERAL_LEN #.$SQL_ACTIVE_ENVIRONMENTS ) - (with-foreign-objects ((info-ptr :long) + (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE) (info-length-ptr :short)) (with-error-handling (:hdbc hdbc) (SQLGetInfo hdbc info-type info-ptr 255 info-length-ptr) - (deref-pointer info-ptr :long)))))) + (deref-pointer info-ptr #.$ODBC-LONG-TYPE)))))) (defun %sql-exec-direct (sql hstmt henv hdbc) (with-cstring (sql-ptr sql) @@ -417,17 +424,17 @@ as possible second argument) to the desired representation of date/time/timestam (deref-pointer columns-nr-ptr :short)))) (defun result-rows-count (hstmt) - (with-foreign-objects ((row-count-ptr :long)) + (with-foreign-objects ((row-count-ptr #.$ODBC-LONG-TYPE)) (with-error-handling (:hstmt hstmt) (SQLRowCount hstmt row-count-ptr) - (deref-pointer row-count-ptr :long)))) + (deref-pointer row-count-ptr #.$ODBC-LONG-TYPE)))) ;; column counting is 1-based (defun %describe-column (hstmt column-nr) (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 #.$ODBC-ULONG-TYPE) (column-scale-ptr :short) (column-nullable-p-ptr :short)) (with-error-handling (:hstmt hstmt) @@ -442,14 +449,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 #.$ODBC-ULONG-TYPE) (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 #.$ODBC-ULONG-TYPE) (column-scale-ptr :short) (column-nullable-p-ptr :short)) (with-error-handling @@ -461,24 +468,24 @@ 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 #.$ODBC-ULONG-TYPE) (deref-pointer column-scale-ptr :short) (deref-pointer column-nullable-p-ptr :short))))) (defun %column-attributes (hstmt column-nr descriptor-type) (let ((descriptor-info-ptr (allocate-foreign-string 256))) (with-foreign-objects ((descriptor-length-ptr :short) - (numeric-descriptor-ptr :long)) + (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 - (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 #.$ODBC-LONG-TYPE))))))) (defun %prepare-describe-columns (hstmt table-qualifier table-owner table-name column-name) @@ -518,14 +525,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 +548,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) @@ -546,7 +560,7 @@ as possible second argument) to the desired representation of date/time/timestam (def-type byte-pointer-type '(* :byte)) (def-type short-pointer-type '(* :short)) (def-type int-pointer-type '(* :int)) -(def-type long-pointer-type '(* :long)) +(def-type long-pointer-type '(* #.$ODBC-LONG-TYPE)) (def-type float-pointer-type '(* :float)) (def-type double-pointer-type '(* :double)) (def-type string-pointer-type '(* :unsigned-char)) @@ -565,7 +579,7 @@ as possible second argument) to the desired representation of date/time/timestam (defun get-cast-long (ptr) (locally (declare (type long-pointer-type ptr)) - (deref-pointer ptr :long))) + (deref-pointer ptr #.$ODBC-LONG-TYPE))) (defun get-cast-single-float (ptr) (locally (declare (type float-pointer-type ptr)) @@ -601,7 +615,7 @@ 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 :long)) + (let* ((out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE)) (value (cond ((= out-len $SQL_NULL_DATA) *null*) @@ -615,8 +629,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)))) @@ -654,6 +667,7 @@ as possible second argument) to the desired representation of date/time/timestam ;; FIXME: this could be better optimized for types which use READ-FROM-STRING above (if (and (or (eq result-type t) (eq result-type :string)) + value (not (stringp value))) (write-to-string value) value))) @@ -675,13 +689,12 @@ as possible second argument) to the desired representation of date/time/timestam (long-p (= size +max-precision+)) (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_SLONG (uffi:allocate-foreign-object #.$ODBC-LONG-TYPE)) (#.$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_SSHORT (uffi:allocate-foreign-object :short)) @@ -692,8 +705,8 @@ 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))))) - (out-len-ptr (uffi:allocate-foreign-object :long))) + (uffi:allocate-foreign-object :byte (1+ size))))) + (out-len-ptr (uffi:allocate-foreign-object #.$ODBC-LONG-TYPE))) (values c-type data-ptr out-len-ptr size long-p))) (defun fetch-all-rows (hstmt &key free-option flatp) @@ -767,10 +780,10 @@ 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 #.$ODBC-LONG-TYPE) (with-error-handling (:hdbc hdbc) (SQLGetConnectOption hdbc option param-ptr) - (deref-pointer param-ptr :long)))) + (deref-pointer param-ptr #.$ODBC-LONG-TYPE)))) (defun set-connection-option (hdbc option param) (with-error-handling (:hdbc hdbc) @@ -788,12 +801,12 @@ as possible second argument) to the desired representation of date/time/timestam (SQLSetPos hstmt row option lock))) (defun %sql-extended-fetch (hstmt fetch-type row) - (with-foreign-objects ((row-count-ptr :unsigned-long) + (with-foreign-objects ((row-count-ptr #.$ODBC-ULONG-TYPE) (row-status-ptr :short)) (with-error-handling (:hstmt hstmt) (SQLExtendedFetch hstmt fetch-type row row-count-ptr row-status-ptr) - (values (deref-pointer row-count-ptr :unsigned-long) + (values (deref-pointer row-count-ptr #.$ODBC-ULONG-TYPE) (deref-pointer row-status-ptr :short))))) ; column-nr is zero-based @@ -819,7 +832,7 @@ as possible second argument) to the desired representation of date/time/timestam (declare (type long-ptr-type out-len-ptr)) (let* ((res (%sql-get-data hstmt column-nr c-type data-ptr +max-precision+ out-len-ptr)) - (out-len (deref-pointer out-len-ptr :long)) + (out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE)) (offset 0)) (case out-len (#.$SQL_NULL_DATA @@ -836,7 +849,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,19 +868,21 @@ 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) - out-len (deref-pointer out-len-ptr :long))) + out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE))) (if (= sql-type $SQL_DECIMAL) (let ((*read-base* 10)) (read-from-string str)) 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 +899,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 +923,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 +931,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) @@ -934,3 +949,46 @@ as possible second argument) to the desired representation of date/time/timestam (defun %list-tables (hstmt) (with-error-handling (:hstmt hstmt) (SQLTables hstmt +null-ptr+ 0 +null-ptr+ 0 +null-ptr+ 0 +null-ptr+ 0))) + +(defun %table-statistics (table hstmt &key unique (ensure t)) + (with-cstrings ((table-cs table)) + (with-error-handling (:hstmt hstmt) + (SQLStatistics + hstmt + +null-ptr+ 0 + +null-ptr+ 0 + table-cs $SQL_NTS + (if unique $SQL_INDEX_UNIQUE $SQL_INDEX_ALL) + (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))) + (nreverse results))) +