;;;; 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.
(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)
(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
(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))))))
()
(SQLAllocEnv phenv)
(deref-pointer phenv 'sql-handle)))))
- (%set-attr-odbc-version henv $SQL_OV_ODBC2)
+ (%set-attr-odbc-version henv $SQL_OV_ODBC3)
henv))
(SQLAllocStmt hdbc hstmt-ptr)
(deref-pointer hstmt-ptr '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)
(#.$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)))
(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
(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))
(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)
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"))
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)