X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=db-odbc%2Fodbc-api.lisp;h=eb68f205b42c32ce248b6f1a217c389a992f75ad;hp=5ff3d09cb7f4750e32cedaf68fb1e45fb083eae9;hb=d9f41af62750c622945bb17b622a39689ee5b840;hpb=db9892632e6eb7869aea7a94c16b523a82de1501 diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index 5ff3d09..eb68f20 100644 --- a/db-odbc/odbc-api.lisp +++ b/db-odbc/odbc-api.lisp @@ -6,7 +6,7 @@ ;;;; Purpose: Low-level ODBC API using UFFI ;;;; Authors: Kevin M. Rosenberg and Paul Meurer ;;;; -;;;; $Id: odbc-package.lisp 7061 2003-09-07 06:34:45Z kevin $ +;;;; $Id$ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2004 by Kevin M. Rosenberg ;;;; and Copyright (C) Paul Meurer 1999 - 2001. All rights reserved. @@ -24,11 +24,16 @@ 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-sys:format-time + nil (clsql-sys: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)) @@ -39,8 +44,10 @@ as possible second argument) to the desired representation of date/time/timestam (let ((size (gensym))) `(let ((,size (length ,string))) (when (and ,max-length (> ,size ,max-length)) - (error "string \"~a\" of length ~d is longer than max-length: ~d" - ,string ,size ,max-length)) + (error 'clsql:sql-database-data-error + :message + (format nil "string \"~a\" of length ~d is longer than max-length: ~d" + ,string ,size ,max-length))) (with-cast-pointer (char-ptr ,ptr :byte) (dotimes (i ,size) (setf (deref-array char-ptr '(:array :byte) i) @@ -58,7 +65,7 @@ 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) + (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE) (msg-length :short)) (SQLError henv hdbc hstmt sql-state error-code error-message @@ -71,12 +78,12 @@ as possible second argument) to the desired representation of date/time/timestam err state (deref-pointer msg-length :short) - (deref-pointer error-code :long)))))) + (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) + (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) @@ -108,22 +115,35 @@ 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 - :odbc-message "Invalid handle")) + 'clsql-sys:sql-database-error + :message "ODBC: Invalid handle")) (#.$SQL_STILL_EXECUTING (error - 'clsql-base-sys:clsql-odbc-error - :odbc-message "Still executing")) + 'clsql-sys:sql-temporary-error + :message "ODBC: Still executing")) (#.$SQL_ERROR (multiple-value-bind (error-message sql-state) (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 - :sql-state sql-state))) + 'clsql-sys:sql-database-error + :message error-message + :secondary-error-id sql-state))) + (#.$SQL_NO_DATA_FOUND + (progn ,result-code ,@body)) + ;; work-around for Allegro 7.0beta AMD64 which + ;; has for negative numbers (otherwise + (multiple-value-bind (error-message sql-state) + (handle-error (or ,henv +null-handle-ptr+) + (or ,hdbc +null-handle-ptr+) + (or ,hstmt +null-handle-ptr+)) + (error + 'clsql-sys:sql-database-error + :message error-message + :secondary-error-id sql-state)) + #+ignore (progn ,result-code ,@body)))))) (defun %new-environment-handle () @@ -131,9 +151,9 @@ as possible second argument) to the desired representation of date/time/timestam (with-foreign-object (phenv 'sql-handle) (with-error-handling () - (SQLAllocEnv phenv) + (SQLAllocHandle $SQL_HANDLE_ENV +null-handle-ptr+ phenv) (deref-pointer phenv 'sql-handle))))) - (%set-attr-odbc-version henv $SQL_OV_ODBC2) + (%set-attr-odbc-version henv $SQL_OV_ODBC3) henv)) @@ -144,9 +164,10 @@ as possible second argument) to the desired representation of date/time/timestam (defun %new-db-connection-handle (henv) (with-foreign-object (phdbc 'sql-handle) + (setf (deref-pointer phdbc sql-handle) +null-handle-ptr+) (with-error-handling (:henv henv) - (SQLAllocConnect henv phdbc) + (SQLAllocHandle $SQL_HANDLE_DBC henv phdbc) (deref-pointer phdbc 'sql-handle)))) (defun %free-statement (hstmt option) @@ -227,12 +248,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 (phstmt 'sql-handle) + (with-error-handling + (:hdbc hdbc) + (SQLAllocHandle $SQL_HANDLE_STMT hdbc phstmt) + (deref-pointer phstmt 'sql-handle))))) + (if (uffi:null-pointer-p statement-handle) + (error 'clsql:sql-database-error :message "Received null statement handle.") + statement-handle))) + (defun %sql-get-info (hdbc info-type) (ecase info-type ;; those return string @@ -362,7 +387,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) @@ -371,7 +396,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 @@ -385,12 +410,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) @@ -415,17 +440,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 :unsigned-long) + (column-precision-ptr #.$ODBC-ULONG-TYPE) (column-scale-ptr :short) (column-nullable-p-ptr :short)) (with-error-handling (:hstmt hstmt) @@ -440,14 +465,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 :unsigned-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 :unsigned-long) + (column-precision-ptr #.$ODBC-ULONG-TYPE) (column-scale-ptr :short) (column-nullable-p-ptr :short)) (with-error-handling @@ -459,14 +484,14 @@ 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 :unsigned-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 @@ -476,7 +501,7 @@ as possible second argument) to the desired representation of date/time/timestam (free-foreign-object descriptor-info-ptr) (values desc - (deref-pointer numeric-descriptor-ptr :long))))))) + (deref-pointer numeric-descriptor-ptr #.$ODBC-LONG-TYPE))))))) (defun %prepare-describe-columns (hstmt table-qualifier table-owner table-name column-name) @@ -544,17 +569,20 @@ as possible second argument) to the desired representation of date/time/timestam (#.$SQL_DATE $SQL_C_DATE) (#.$SQL_TIME $SQL_C_TIME) (#.$SQL_TIMESTAMP $SQL_C_TIMESTAMP) + (#.$SQL_TYPE_DATE $SQL_C_TYPE_DATE) + (#.$SQL_TYPE_TIME $SQL_C_TYPE_TIME) + (#.$SQL_TYPE_TIMESTAMP $SQL_C_TYPE_TIMESTAMP) ((#.$SQL_BINARY #.$SQL_VARBINARY #.$SQL_LONGVARBINARY) $SQL_C_BINARY) (#.$SQL_TINYINT $SQL_C_STINYINT) (#.$SQL_BIT $SQL_C_BIT))) -(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 float-pointer-type '(* :float)) -(def-type double-pointer-type '(* :double)) -(def-type string-pointer-type '(* :unsigned-char)) +(def-type byte-pointer-type (* :byte)) +(def-type short-pointer-type (* :short)) +(def-type int-pointer-type (* :int)) +(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)) (defun get-cast-byte (ptr) (locally (declare (type byte-pointer-type ptr)) @@ -570,7 +598,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)) @@ -606,7 +634,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*) @@ -620,18 +648,17 @@ 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 (get-cast-byte data-ptr)) (#.$SQL_DECIMAL (let ((*read-base* 10)) (read-from-string (get-cast-foreign-string data-ptr)))) (t (case c-type - (#.$SQL_C_DATE + ((#.$SQL_C_DATE #.$SQL_C_TYPE_DATE) (funcall *time-conversion-function* (date-to-universal-time data-ptr))) - (#.$SQL_C_TIME + ((#.$SQL_C_TIME #.$SQL_C_TYPE_TIME) (multiple-value-bind (universal-time frac) (time-to-universal-time data-ptr) (funcall *time-conversion-function* universal-time frac))) - (#.$SQL_C_TIMESTAMP + ((#.$SQL_C_TIMESTAMP #.$SQL_C_TYPE_TIMESTAMP) (multiple-value-bind (universal-time frac) (timestamp-to-universal-time data-ptr) (funcall *time-conversion-function* universal-time frac))) (#.$SQL_INTEGER @@ -658,6 +685,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))) @@ -679,14 +707,14 @@ 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_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_SLONG (uffi:allocate-foreign-object #.$ODBC-LONG-TYPE)) + ((#.$SQL_C_DATE #.$SQL_C_TYPE_DATE) (allocate-foreign-object 'sql-c-date)) + ((#.$SQL_C_TIME #.$SQL_C_TYPE_TIME) (allocate-foreign-object 'sql-c-time)) + ((#.$SQL_C_TIMESTAMP #.$SQL_C_TYPE_TIMESTAMP) (allocate-foreign-object 'sql-c-timestamp)) (#.$SQL_C_FLOAT (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 :short)) + (#.$SQL_C_STINYINT (uffi:allocate-foreign-object :byte)) (#.$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)))) @@ -696,7 +724,7 @@ as possible second argument) to the desired representation of date/time/timestam (break "SQL type is ~A, precision ~D, size ~D, C type is ~A" sql-type precision size c-type)) (uffi:allocate-foreign-object :byte (1+ size))))) - (out-len-ptr (uffi:allocate-foreign-object :long))) + (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) @@ -733,7 +761,8 @@ as possible second argument) to the desired representation of date/time/timestam (prog1 (cond (flatp (when (> column-count 1) - (error "If more than one column is to be fetched, flatp has to be nil.")) + (error 'clsql:sql-database-error + :message "If more than one column is to be fetched, flatp has to be nil.")) (loop until (= (%sql-fetch hstmt) $SQL_NO_DATA_FOUND) collect (read-data (aref data-ptrs 0) @@ -770,10 +799,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-object (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) @@ -791,12 +820,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 @@ -822,7 +851,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 @@ -837,7 +866,7 @@ as possible second argument) to the desired representation of date/time/timestam data-ptr str offset data-length))) - (error "wrong type. preliminary.")) + (error 'clsql:sql-database-error :message "wrong type. preliminary.")) while (and (= res $SQL_SUCCESS_WITH_INFO) (equal (sql-state +null-handle-ptr+ +null-handle-ptr+ hstmt) "01004")) @@ -855,7 +884,7 @@ as possible second argument) to the desired representation of date/time/timestam data-ptr str offset (min out-len (1- +max-precision+)))) - (error "wrong type. preliminary.")) + (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) @@ -864,15 +893,15 @@ as possible second argument) to the desired representation of date/time/timestam "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))) +(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)) @@ -943,14 +972,11 @@ as possible second argument) to the desired representation of date/time/timestam (defun %table-statistics (table hstmt &key unique (ensure t)) (with-cstrings ((table-cs table)) (with-error-handling (:hstmt hstmt) - (print hstmt) - (print table-cs) - (print (uffi:convert-from-cstring table-cs)) (SQLStatistics hstmt +null-ptr+ 0 +null-ptr+ 0 - table-cs (length table) ;;$SQL_NTS + table-cs $SQL_NTS (if unique $SQL_INDEX_UNIQUE $SQL_INDEX_ALL) (if ensure $SQL_ENSURE $SQL_QUICK)))))