X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=db-odbc%2Fodbc-api.lisp;h=208dafa7536190665644a5709ad9fb99f04eb81b;hp=f01be3127739c4fb1adca4201fac1ab47f2f364f;hb=906d7a71b35ee1cd6d281623694bc90ced22c339;hpb=f1d668746523a72a6893a46380468a9e033545e4 diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index f01be31..208dafa 100644 --- a/db-odbc/odbc-api.lisp +++ b/db-odbc/odbc-api.lisp @@ -22,17 +22,12 @@ 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) - (let ((time (clsql-sys:utime->time universal-time))) - (setf time (clsql-sys:time+ - time - (clsql-sys:make-duration :usec (/ fraction 1000)))) - (clsql-sys:format-time nil 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. By default, returns an iso-timestring.") +(defvar *time-format* + (lambda (time) + (clsql-sys:format-time nil time :format :iso)) + "Bound to a function that converts from a clsql:wall-time 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)) @@ -53,21 +48,6 @@ as possible second argument) to the desired representation of date/time/timestam (char-code (char ,string i)))) (setf (deref-array char-ptr '(:array :byte) ,size) 0))))) -(defun %cstring-into-vector (ptr vector offset size-in-bytes) - (dotimes (i size-in-bytes) - (setf (schar vector offset) - (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)) @@ -231,7 +211,8 @@ as possible second argument) to the desired representation of date/time/timestam (with-error-handling (:hdbc hdbc) (SQLDriverConnect hdbc - window-handle + (or window-handle + +null-handle-ptr+) connection-ptr $SQL_NTS completed-connection-string-ptr $SQL_MAX_CONN_OUT completed-connection-length @@ -586,8 +567,9 @@ as possible second argument) to the desired representation of date/time/timestam (defun sql-to-c-type (sql-type) (ecase sql-type + ;; Added -10 for MSSQL ntext type and -11 for nvarchar ((#.$SQL_CHAR #.$SQL_VARCHAR #.$SQL_LONGVARCHAR - #.$SQL_NUMERIC #.$SQL_DECIMAL -8 -9 -10) $SQL_C_CHAR) ;; Added -10 for MSSQL ntext type + #.$SQL_NUMERIC #.$sql_decimal -8 -9 -10 -11) $SQL_C_CHAR) (#.$SQL_INTEGER $SQL_C_SLONG) (#.$SQL_BIGINT $SQL_C_SBIGINT) (#.$SQL_SMALLINT $SQL_C_SSHORT) @@ -689,13 +671,11 @@ as possible second argument) to the desired representation of date/time/timestam (t (case c-type ((#.$SQL_C_DATE #.$SQL_C_TYPE_DATE) - (funcall *time-conversion-function* (date-to-universal-time data-ptr))) + (funcall *time-format* (date-to-clsql-time data-ptr))) ((#.$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))) + (funcall *time-format* (time-to-clsql-time data-ptr))) ((#.$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))) + (funcall *time-format* (timestamp-to-clsql-time data-ptr))) (#.$SQL_INTEGER (get-cast-int data-ptr)) (#.$SQL_C_FLOAT @@ -885,78 +865,64 @@ as possible second argument) to the desired representation of date/time/timestam (defun read-data-in-chunks (hstmt column-nr data-ptr c-type sql-type - out-len-ptr result-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 (get-cast-long out-len-ptr)) - (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) - (>= 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) - (*read-default-float-format* 'double-float)) - (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)) + (result (if (equal out-len #.$SQL_NULL_DATA) + (return-from read-data-in-chunks *null*) + + ;;this isn't the most efficient way of doing it: + ;;the foreign string gets copied to lisp, then + ;;that is copied into the final string. However, + ;;the previous impl that tried to copy one + ;;character over at a time failed miserably on + ;;multibyte characters. + ;; + ;;In the face of multibyte characters, the out-len + ;;tells us the length in bytes but that doesn't + ;;particularly help us here in allocating a lisp + ;;array. So our best strategy is to just let the + ;;foreign library that's already dealing with + ;;encodings do its thing. + + (with-output-to-string (str) + (loop do (if (= c-type #.$SQL_CHAR) + (write-sequence (get-cast-foreign-string data-ptr) str) + (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))))))) + + ;; reset the out length for the next row + (setf (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE) #.$SQL_NO_TOTAL) + (if (= sql-type $SQL_DECIMAL) + (let ((*read-base* 10)) + (read-from-string result)) + 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) +(defun timestamp-to-clsql-time (ptr) (declare (type c-timestamp-ptr-type ptr)) - (values - (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) - (get-slot-value ptr 'sql-c-timestamp 'day) - (get-slot-value ptr 'sql-c-timestamp 'month) - (get-slot-value ptr 'sql-c-timestamp 'year)) - (get-slot-value ptr 'sql-c-timestamp 'fraction))) + (clsql-sys:make-time + :second (get-slot-value ptr 'sql-c-timestamp 'second) + :minute (get-slot-value ptr 'sql-c-timestamp 'minute) + :hour (get-slot-value ptr 'sql-c-timestamp 'hour) + :day (get-slot-value ptr 'sql-c-timestamp 'day) + :month (get-slot-value ptr 'sql-c-timestamp 'month) + :year (get-slot-value ptr 'sql-c-timestamp 'year) + :usec (let ((frac (get-slot-value ptr 'sql-c-timestamp 'fraction))) + (if frac (/ frac 1000) 0)))) (defun universal-time-to-timestamp (time &optional (fraction 0)) "TODO: Dead function?" @@ -986,21 +952,20 @@ as possible second argument) to the desired representation of date/time/timestam (get-slot-value ptr 'sql-c-timestamp 'fraction) fraction) ptr)) -(defun date-to-universal-time (ptr) +(defun date-to-clsql-time (ptr) (declare (type c-date-ptr-type ptr)) - (encode-universal-time - 0 0 0 - (get-slot-value ptr 'sql-c-timestamp 'day) - (get-slot-value ptr 'sql-c-timestamp 'month) - (get-slot-value ptr 'sql-c-timestamp 'year))) + (clsql-sys:make-time + :second 0 :minute 0 :hour 0 + :day (get-slot-value ptr 'sql-c-timestamp 'day) + :month (get-slot-value ptr 'sql-c-timestamp 'month) + :year (get-slot-value ptr 'sql-c-timestamp 'year))) -(defun time-to-universal-time (ptr) +(defun time-to-clsql-time (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) - (get-slot-value ptr 'sql-c-timestamp 'hour) - 1 1 0)) + (clsql-sys:make-time + :second (get-slot-value ptr 'sql-c-timestamp 'second) + :minute (get-slot-value ptr 'sql-c-timestamp 'minute) + :hour (get-slot-value ptr 'sql-c-timestamp 'hour))) ;;; Added by KMR @@ -1017,16 +982,18 @@ as possible second argument) to the desired representation of date/time/timestam (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)) +(defun %table-statistics (table hstmt &key unique (ensure t) + &aux (table (princ-to-string + (clsql-sys::unescaped-database-identifier table)))) (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))))) + (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 ((results nil))