X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=db-odbc%2Fodbc-api.lisp;h=1896a4727d60f35b514bb8591f056cde77d24e4e;hp=c5cca32d82f9496cbb755cadc97d21d77fb96dda;hb=6b34e2293a52b03e8611c85e4e53a0ab5c8a3c1a;hpb=8a8ee2d7d791b7a3efaed06420802a925d16fca3 diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index c5cca32..1896a47 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. @@ -21,14 +21,14 @@ (defvar *null* nil "Lisp representation of SQL Null value, default = nil. 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)) - (clsql-sys:format-time - nil (clsql-sys:utime->time universal-time) + (clsql-sys:format-time + nil (clsql-sys:utime->time universal-time) :format :iso) #+ignore universal-time) @@ -44,11 +44,13 @@ 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) + (setf (deref-array char-ptr '(:array :byte) i) (char-code (char ,string i)))) (setf (deref-array char-ptr '(:array :byte) ,size) 0))))) @@ -59,7 +61,7 @@ as possible second argument) to the desired representation of date/time/timestam (deref-array ptr '(:array :unsigned-char) i))) (incf offset)) offset) - + (defun handle-error (henv hdbc hstmt) (let ((sql-state (allocate-foreign-string 256)) (error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH))) @@ -75,7 +77,7 @@ as possible second argument) to the desired representation of date/time/timestam (values err state - (deref-pointer msg-length :short) + (deref-pointer msg-length :short) (deref-pointer error-code #.$ODBC-LONG-TYPE)))))) (defun sql-state (henv hdbc hstmt) @@ -85,7 +87,7 @@ as possible second argument) to the desired representation of date/time/timestam (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))) + (let ((state (convert-from-foreign-string sql-state))) (free-foreign-object error-message) (free-foreign-object sql-state) state @@ -113,21 +115,21 @@ as possible second argument) to the desired representation of date/time/timestam (progn ,result-code ,@body)) (#.$SQL_INVALID_HANDLE (error - 'clsql-sys:clsql-odbc-error - :odbc-message "Invalid handle")) + 'clsql-sys:sql-database-error + :message "ODBC: Invalid handle")) (#.$SQL_STILL_EXECUTING (error - 'clsql-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-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 @@ -138,9 +140,9 @@ as possible second argument) to the desired representation of date/time/timestam (or ,hdbc +null-handle-ptr+) (or ,hstmt +null-handle-ptr+)) (error - 'clsql-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)) #+ignore (progn ,result-code ,@body)))))) @@ -149,29 +151,30 @@ 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)) (defun %sql-free-environment (henv) - (with-error-handling + (with-error-handling (:henv henv) (SQLFreeEnv henv))) (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) - (with-error-handling + (with-error-handling (:hstmt hstmt) - (SQLFreeStmt - hstmt + (SQLFreeStmt + hstmt (ecase option (:drop $SQL_DROP) (:close $SQL_CLOSE) @@ -190,27 +193,41 @@ as possible second argument) to the desired representation of date/time/timestam (with-cstrings ((server-ptr server) (uid-ptr uid) (pwd-ptr pwd)) - (with-error-handling + (with-error-handling (:hdbc hdbc) - (SQLConnect hdbc server-ptr $SQL_NTS uid-ptr + (SQLConnect hdbc server-ptr $SQL_NTS uid-ptr $SQL_NTS pwd-ptr $SQL_NTS)))) +(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))))) (defun %disconnect (hdbc) - (with-error-handling + (with-error-handling (:hdbc hdbc) (SQLDisconnect hdbc))) (defun %commit (henv hdbc) - (with-error-handling + (with-error-handling (:henv henv :hdbc hdbc) - (SQLTransact + (SQLTransact henv hdbc $SQL_COMMIT))) (defun %rollback (henv hdbc) - (with-error-handling + (with-error-handling (:henv henv :hdbc hdbc) - (SQLTransact + (SQLTransact henv hdbc $SQL_ROLLBACK))) ; col-nr is zero-based in Lisp @@ -229,7 +246,7 @@ as possible second argument) to the desired representation of date/time/timestam (with-error-handling (:hstmt hstmt) (SQLBindParameter hstmt (1+ parameter-nr) - parameter-type ;$SQL_PARAM_INPUT + parameter-type ;$SQL_PARAM_INPUT c-type ;$SQL_C_CHAR sql-type ;$SQL_VARCHAR precision ;(1- (length str)) @@ -240,21 +257,21 @@ as possible second argument) to the desired representation of date/time/timestam ))) (defun %sql-fetch (hstmt) - (with-error-handling + (with-error-handling (:hstmt hstmt) (SQLFetch hstmt))) (defun %new-statement-handle (hdbc) (let ((statement-handle - (with-foreign-object (hstmt-ptr 'sql-handle) - (with-error-handling + (with-foreign-object (phstmt 'sql-handle) + (with-error-handling (:hdbc hdbc) - (SQLAllocStmt hdbc hstmt-ptr) - (deref-pointer hstmt-ptr 'sql-handle))))) + (SQLAllocHandle $SQL_HANDLE_STMT hdbc phstmt) + (deref-pointer phstmt 'sql-handle))))) (if (uffi:null-pointer-p statement-handle) - (error "Received null 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 @@ -291,9 +308,9 @@ 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))) + (let ((info-ptr (allocate-foreign-string 1024))) (with-foreign-object (info-length-ptr :short) - (with-error-handling + (with-error-handling (:hdbc hdbc) (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr) (let ((info (convert-from-foreign-string info-ptr))) @@ -329,7 +346,7 @@ as possible second argument) to the desired representation of date/time/timestam #.$SQL_TXN_CAPABLE) (with-foreign-objects ((info-ptr :short) (info-length-ptr :short)) - (with-error-handling + (with-error-handling (:hdbc hdbc) (SQLGetInfo hdbc info-type @@ -339,7 +356,7 @@ as possible second argument) to the desired representation of date/time/timestam (deref-pointer info-ptr :short))) ) ;; those returning a long bitmask - ((#.$SQL_ALTER_TABLE + ((#.$SQL_ALTER_TABLE #.$SQL_BOOKMARK_PERSISTENCE #.$SQL_CONVERT_BIGINT #.$SQL_CONVERT_BINARY @@ -386,7 +403,7 @@ as possible second argument) to the desired representation of date/time/timestam #.$SQL_UNION) (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE) (info-length-ptr :short)) - (with-error-handling + (with-error-handling (:hdbc hdbc) (SQLGetInfo hdbc info-type @@ -409,11 +426,11 @@ as possible second argument) to the desired representation of date/time/timestam ) (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE) (info-length-ptr :short)) - (with-error-handling + (with-error-handling (:hdbc hdbc) (SQLGetInfo hdbc info-type info-ptr 255 info-length-ptr) (deref-pointer info-ptr #.$ODBC-LONG-TYPE)))))) - + (defun %sql-exec-direct (sql hstmt henv hdbc) (with-cstring (sql-ptr sql) (with-error-handling @@ -465,14 +482,14 @@ as possible second argument) to the desired representation of date/time/timestam (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 #.$ODBC-ULONG-TYPE) (column-scale-ptr :short) (column-nullable-p-ptr :short)) - (with-error-handling + (with-error-handling (:hstmt hstmt) (SQLDescribeParam hstmt parameter-nr column-sql-type-ptr @@ -490,7 +507,7 @@ as possible second argument) to the desired representation of date/time/timestam (with-foreign-objects ((descriptor-length-ptr :short) (numeric-descriptor-ptr #.$ODBC-LONG-TYPE)) (with-error-handling - (:hstmt hstmt) + (:hstmt hstmt) (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr 256 descriptor-length-ptr numeric-descriptor-ptr) @@ -499,25 +516,25 @@ as possible second argument) to the desired representation of date/time/timestam (values desc (deref-pointer numeric-descriptor-ptr #.$ODBC-LONG-TYPE))))))) - -(defun %prepare-describe-columns (hstmt table-qualifier table-owner + +(defun %prepare-describe-columns (hstmt table-qualifier table-owner table-name column-name) (with-cstrings ((table-qualifier-ptr table-qualifier) - (table-owner-ptr table-owner) + (table-owner-ptr table-owner) (table-name-ptr table-name) (column-name-ptr column-name)) (with-error-handling - (:hstmt hstmt) + (:hstmt hstmt) (SQLColumns hstmt table-qualifier-ptr (length table-qualifier) table-owner-ptr (length table-owner) table-name-ptr (length table-name) column-name-ptr (length column-name))))) -(defun %describe-columns (hdbc table-qualifier table-owner +(defun %describe-columns (hdbc table-qualifier table-owner table-name column-name) (with-statement-handle (hstmt hdbc) - (%prepare-describe-columns hstmt table-qualifier table-owner + (%prepare-describe-columns hstmt table-qualifier table-owner table-name column-name) (fetch-all-rows hstmt))) @@ -551,13 +568,13 @@ as possible second argument) to the desired representation of date/time/timestam (free-foreign-object name-ptr) (free-foreign-object description-ptr) nil)))))) - + (defun sql-to-c-type (sql-type) (ecase sql-type - ((#.$SQL_CHAR #.$SQL_VARCHAR #.$SQL_LONGVARCHAR - #.$SQL_NUMERIC #.$SQL_DECIMAL #.$SQL_BIGINT -8 -9) $SQL_C_CHAR) + ((#.$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_INTEGER $SQL_C_SLONG) (#.$SQL_SMALLINT $SQL_C_SSHORT) (#.$SQL_DOUBLE $SQL_C_DOUBLE) @@ -566,17 +583,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 '(* #.$ODBC-LONG-TYPE)) -(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)) @@ -635,25 +655,25 @@ as possible second argument) to the desired representation of date/time/timestam (t (case sql-type ;; SQL extended datatypes - (#.$SQL_TINYINT (get-cast-byte data-ptr)) + (#.$SQL_TINYINT (get-cast-byte data-ptr)) (#.$SQL_C_STINYINT (get-cast-byte data-ptr)) ;; ? (#.$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_TINYINT (get-cast-byte data-ptr)) - (#.$SQL_DECIMAL + (#.$SQL_DECIMAL (let ((*read-base* 10)) (read-from-string (get-cast-foreign-string data-ptr)))) - (t + (#.$SQL_BIT (get-cast-byte 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 @@ -676,9 +696,9 @@ as possible second argument) to the desired representation of date/time/timestam (code-char (get-cast-short data-ptr))) (t (get-cast-foreign-string data-ptr))))))))) - + ;; 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))) @@ -703,9 +723,9 @@ 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 #.$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_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)) @@ -713,10 +733,10 @@ as possible second argument) to the desired representation of date/time/timestam (#.$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)))) - (t + (t ;; Maybe should signal a restartable condition for this? (when *break-on-unknown-data-type* - (break "SQL type is ~A, precision ~D, size ~D, C type is ~A" + (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 #.$ODBC-LONG-TYPE))) @@ -754,12 +774,13 @@ as possible second argument) to the desired representation of date/time/timestam (aref out-len-ptrs col-nr) out-len-ptr)))) ;; the main loop (prog1 - (cond (flatp + (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) + (read-data (aref data-ptrs 0) (aref c-types 0) (aref sql-types 0) (aref out-len-ptrs 0) @@ -769,7 +790,7 @@ as possible second argument) to the desired representation of date/time/timestam collect (loop for col-nr from 0 to (1- column-count) collect - (read-data (aref data-ptrs col-nr) + (read-data (aref data-ptrs col-nr) (aref c-types col-nr) (aref sql-types col-nr) (aref out-len-ptrs col-nr) @@ -809,7 +830,7 @@ as possible second argument) to the desired representation of date/time/timestam (set-connection-option hdbc $SQL_AUTOCOMMIT $SQL_AUTOCOMMIT_ON)) (defun %sql-set-pos (hstmt row option lock) - (with-error-handling + (with-error-handling (:hstmt hstmt) (SQLSetPos hstmt row option lock))) @@ -840,67 +861,70 @@ 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 +(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)) - (let* ((res (%sql-get-data hstmt column-nr c-type data-ptr + (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)) - (offset 0)) - (case out-len - (#.$SQL_NULL_DATA - (return-from read-data-in-chunks *null*)) - (#.$SQL_NO_TOTAL ;; don't know how long it is going to be - (let ((str (make-array 0 :element-type 'character :adjustable t))) - (loop do (if (= c-type #.$SQL_CHAR) - (let ((data-length (foreign-string-length data-ptr))) - (adjust-array str (+ offset data-length) - :initial-element #\?) - (setf offset (%cstring-into-vector - data-ptr str - offset - data-length))) - (error "wrong type. preliminary.")) - while (and (= res $SQL_SUCCESS_WITH_INFO) - (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))) - (setf str (coerce str 'string)) - (if (= sql-type $SQL_DECIMAL) - (let ((*read-base* 10)) - (read-from-string str)) - 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 "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))) - (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))) + (offset 0) + (result (case out-len + (#.$SQL_NULL_DATA + (return-from read-data-in-chunks *null*)) + (#.$SQL_NO_TOTAL ;; don't know how long it is going to be + (let ((str (make-array 0 :element-type 'character :adjustable t))) + (loop do (if (= c-type #.$SQL_CHAR) + (let ((data-length (foreign-string-length data-ptr))) + (adjust-array str (+ offset data-length) + :initial-element #\?) + (setf offset (%cstring-into-vector + data-ptr str + offset + data-length))) + (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")) + do (setf res (%sql-get-data hstmt column-nr c-type data-ptr + +max-precision+ out-len-ptr))) + (setf str (coerce str 'string)) + (if (= sql-type $SQL_DECIMAL) + (let ((*read-base* 10)) + (read-from-string str)) + 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))) + (if (= sql-type $SQL_DECIMAL) + (let ((*read-base* 10)) + (read-from-string 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))) (defun timestamp-to-universal-time (ptr) (declare (type c-timestamp-ptr-type ptr)) (values - (encode-universal-time + (encode-universal-time (get-slot-value ptr 'sql-c-timestamp 'second) (get-slot-value ptr 'sql-c-timestamp 'minute) (get-slot-value ptr 'sql-c-timestamp 'hour) @@ -945,7 +969,7 @@ as possible second argument) to the desired representation of date/time/timestam (defun time-to-universal-time (ptr) (declare (type c-time-ptr-type ptr)) - (encode-universal-time + (encode-universal-time (get-slot-value ptr 'sql-c-timestamp 'second) (get-slot-value ptr 'sql-c-timestamp 'minute) (get-slot-value ptr 'sql-c-timestamp 'hour) @@ -956,7 +980,7 @@ as possible second argument) to the desired representation of date/time/timestam (defun %set-attr-odbc-version (henv version) (with-error-handling (:henv henv) - (SQLSetEnvAttr henv $SQL_ATTR_ODBC_VERSION + (SQLSetEnvAttr henv $SQL_ATTR_ODBC_VERSION (make-pointer version :void) 0))) (defun %list-tables (hstmt) @@ -966,7 +990,7 @@ 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) - (SQLStatistics + (SQLStatistics hstmt +null-ptr+ 0 +null-ptr+ 0 @@ -988,7 +1012,7 @@ as possible second argument) to the desired representation of date/time/timestam (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)