;;;; Purpose: Low-level ODBC API using UFFI
;;;; Authors: Kevin M. Rosenberg and Paul Meurer
;;;;
-;;;; $Id$
-;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2004 by Kevin M. Rosenberg
;;;; and Copyright (C) Paul Meurer 1999 - 2001. All rights reserved.
;;;;
(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)
- :format :iso)
+ (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
(SQLTransact
henv hdbc $SQL_ROLLBACK)))
-; col-nr is zero-based in Lisp
+; col-nr is zero-based in Lisp but 1 based in sql
; col-nr = :bookmark retrieves a bookmark.
(defun %bind-column (hstmt column-nr c-type data-ptr precision out-len-ptr)
(with-error-handling
(deref-pointer column-nullable-p-ptr :short)))))))
;; parameter counting is 1-based
+;; this function isn't used, which is good because FreeTDS dosn't support it.
(defun %describe-parameter (hstmt parameter-nr)
(with-foreign-objects ((column-sql-type-ptr :short)
(column-precision-ptr #.$ODBC-ULONG-TYPE)
(defun sql-to-c-type (sql-type)
(ecase sql-type
((#.$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_NUMERIC #.$SQL_DECIMAL -8 -9 -10) $SQL_C_CHAR) ;; Added -10 for MSSQL ntext type
(#.$SQL_INTEGER $SQL_C_SLONG)
+ (#.$SQL_BIGINT $SQL_C_SBIGINT)
(#.$SQL_SMALLINT $SQL_C_SSHORT)
(#.$SQL_DOUBLE $SQL_C_DOUBLE)
(#.$SQL_FLOAT $SQL_C_DOUBLE)
(def-type short-pointer-type (* :short))
(def-type int-pointer-type (* :int))
(def-type long-pointer-type (* #.$ODBC-LONG-TYPE))
+(def-type big-pointer-type (* #.$ODBC-BIG-TYPE))
(def-type float-pointer-type (* :float))
(def-type double-pointer-type (* :double))
(def-type string-pointer-type (* :unsigned-char))
(locally (declare (type long-pointer-type ptr))
(deref-pointer ptr #.$ODBC-LONG-TYPE)))
+(defun get-cast-big (ptr)
+ (locally (declare (type big-pointer-type ptr))
+ (deref-pointer ptr #.$ODBC-BIG-TYPE)))
+
(defun get-cast-single-float (ptr)
(locally (declare (type float-pointer-type ptr))
(deref-pointer ptr :float)))
(defun get-cast-binary (ptr len format)
"FORMAT is one of :unsigned-byte-vector, :bit-vector (:string, :hex-string)"
- (with-cast-pointer (casted ptr :byte)
+ (with-cast-pointer (casted ptr :unsigned-byte)
(ecase format
(:unsigned-byte-vector
(let ((vector (make-array len :element-type '(unsigned-byte 8))))
(dotimes (i len)
(setf (aref vector i)
- (deref-array casted '(:array :byte) i)))
+ (deref-array casted '(:array :unsigned-byte) i)))
vector))
(:bit-vector
(let ((vector (make-array (ash len 3) :element-type 'bit)))
(#.$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_BIGINT (get-cast-big data-ptr))
(#.$SQL_DECIMAL
(let ((*read-base* 10))
(read-from-string (get-cast-foreign-string data-ptr))))
(get-cast-binary data-ptr out-len *binary-format*))
((#.$SQL_C_SSHORT #.$SQL_C_STINYINT) ; LMH short ints
(get-cast-short data-ptr)) ; LMH
+ (#.$SQL_C_SBIGINT (uffi:allocate-foreign-object #.$ODBC-BIG-TYPE)
+ (get-cast-short data-ptr))
#+ignore
(#.$SQL_C_CHAR
(code-char (get-cast-short data-ptr)))
(#.$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_SBIGINT (uffi:allocate-foreign-object #.$ODBC-BIG-TYPE))
(#.$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))))
(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)))
+ (otherwise
+ (let ((str)
+ (offset 0)
+ (octets (make-array out-len :element-type '(unsigned-byte 8) :initial-element 0)))
+ (loop
+ do
+ (loop for i from 0 to (1- (min out-len +max-precision+))
+ do (setf (aref octets (+ offset i)) (deref-array data-ptr '(:array :unsigned-byte) i))
+ finally (incf offset (1- i)))
+ 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 (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE)))
+ (setf str (uffi:octets-to-string octets))
(if (= sql-type $SQL_DECIMAL)
(let ((*read-base* 10))
(read-from-string str))
- str))))))
+ str))))))
(setf (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE) #.$SQL_NO_TOTAL) ;; reset the out length for the next row
result))
(free-foreign-object desc)))
(nreverse results)))
+
projects / clsql.git / blobdiff