(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))
(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))
(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
(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)
(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
(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?"
(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
(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))
projects / clsql.git / blobdiff