X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=db-odbc%2Fodbc-api.lisp;h=33734bc993450096052fbe1b240587c834d1ac1d;hb=fd2493718d0e1114fcbe3dd578dab658ea383e81;hp=a320d7e3f561543d87314f5469b698de2de48dbe;hpb=a6576bcf62dd1e710085ec74089d0730d599001b;p=clsql.git diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index a320d7e..33734bc 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. @@ -27,8 +27,8 @@ May be locally bound to something else if a certain type is necessary.") (defvar *time-conversion-function* (lambda (universal-time &optional fraction) (declare (ignore fraction)) - (clsql-base:format-time - nil (clsql-base:utime->time universal-time) + (clsql-sys:format-time + nil (clsql-sys:utime->time universal-time) :format :iso) #+ignore universal-time) @@ -44,8 +44,10 @@ 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) @@ -113,22 +115,35 @@ as possible second argument) to the desired representation of date/time/timestam (progn ,result-code ,@body)) (#.$SQL_INVALID_HANDLE (error - 'clsql-base:clsql-odbc-error - :odbc-message "Invalid handle")) + 'clsql-sys:sql-database-error + :message "ODBC: Invalid handle")) (#.$SQL_STILL_EXECUTING (error - 'clsql-base: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-base: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 + ;; has for negative numbers (otherwise + (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:sql-database-error + :message error-message + :secondary-error-id sql-state)) + #+ignore (progn ,result-code ,@body)))))) (defun %new-environment-handle () @@ -136,9 +151,9 @@ 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)) @@ -149,9 +164,10 @@ as possible second argument) to the desired representation of date/time/timestam (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) @@ -182,6 +198,20 @@ as possible second argument) to the desired representation of date/time/timestam (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 @@ -233,13 +263,13 @@ as possible second argument) to the desired representation of date/time/timestam (defun %new-statement-handle (hdbc) (let ((statement-handle - (with-foreign-object (hstmt-ptr 'sql-handle) + (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) @@ -544,7 +574,7 @@ as possible second argument) to the desired representation of date/time/timestam (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_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) @@ -553,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)) @@ -629,18 +662,17 @@ as possible second argument) to the desired representation of date/time/timestam (#.$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 (let ((*read-base* 10)) (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 @@ -690,9 +722,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)) @@ -743,7 +775,8 @@ as possible second argument) to the desired representation of date/time/timestam (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) @@ -829,60 +862,63 @@ 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) - (declare (type long-ptr-type out-len-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))