X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=db-odbc%2Fodbc-dbi.lisp;h=90cea24f1e8049c863ed0e883c6033322ea1f4cb;hp=6723a1a6d280702bff950c5d4d1fb378a9174012;hb=9fe9142259cca16202f35f66cbb35419752dd54d;hpb=e567409d9fff3f7231c2a0bb69b345e19de2b246 diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp index 6723a1a..90cea24 100644 --- a/db-odbc/odbc-dbi.lisp +++ b/db-odbc/odbc-dbi.lisp @@ -7,8 +7,6 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Create: April 2004 ;;;; -;;;; $Id$ -;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software @@ -67,6 +65,8 @@ parameter-columns)) (defgeneric get-odbc-info (src info-type)) +(defvar *reuse-query-objects* t) + ;;; SQL Interface @@ -104,7 +104,7 @@ :accessor data-ptrs) (column-out-len-ptrs :initform (make-array 0 :adjustable t :fill-pointer t) :accessor column-out-len-ptrs) - (column-precisions :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) + (column-precisions :initform (make-array 0 :element-type 'integer :adjustable t :fill-pointer t) :accessor column-precisions) (column-scales :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) :accessor column-scales) @@ -147,13 +147,11 @@ the query against." )) db)) (defun disconnect (database) + "This is set in the generic-odbc-database disconnect-fn slot so xref fails + but this does get called on generic ODBC connections " (with-slots (hdbc queries) database (dolist (query queries) - (if (query-active-p query) - (with-slots (hstmt) query - (when hstmt - (%free-statement hstmt :drop) - (setf hstmt nil))))) + (db-close-query query :drop-p T)) (when (db-hstmt database) (%free-statement (db-hstmt database) :drop)) (%disconnect hdbc))) @@ -209,22 +207,28 @@ the query against." )) (coerce (column-names query) 'list)))) (db-close-query query)))) -(defun list-table-indexes (table &key db unique hstmt) +(defun list-table-indexes (table &key db unique hstmt + &aux (table + (princ-to-string + (clsql-sys::unescaped-database-identifier table)))) (declare (ignore hstmt)) (let ((query (get-free-query db))) (unwind-protect - (progn - (with-slots (hstmt) query - (unless hstmt - (setf hstmt (%new-statement-handle (hdbc db)))) - (%table-statistics table hstmt :unique unique) - (%initialize-query query nil nil) - (values - (db-fetch-query-results query) - (coerce (column-names query) 'list)))) + (progn + (with-slots (hstmt) query + (unless hstmt + (setf hstmt (%new-statement-handle (hdbc db)))) + (%table-statistics table hstmt :unique unique) + (%initialize-query query nil nil) + (values + (db-fetch-query-results query) + (coerce (column-names query) 'list)))) (db-close-query query)))) -(defun list-all-table-columns (table &key db hstmt) +(defun list-all-table-columns (table &key db hstmt + &aux (table + (princ-to-string + (clsql-sys::unescaped-database-identifier table)))) (declare (ignore hstmt)) (db-describe-columns db nil nil table nil)) ;; use nil rather than "" for unspecified values @@ -271,20 +275,22 @@ the query against." )) (setf active-p t))))) ;; one for odbc-db is missing +;; TODO: Seems to be uncalled (defmethod terminate ((query odbc-query)) ;;(format tb::*local-output* "~%*** terminated: ~s" query) - (with-slots (hstmt) query - (when hstmt - ;(%free-statement hstmt :drop) - (uffi:free-foreign-object hstmt)) ;; ?? - (%dispose-column-ptrs query))) + (db-close-query query)) (defun %dispose-column-ptrs (query) + "frees memory allocated for query object column-data and column-data-length" (with-slots (column-data-ptrs column-out-len-ptrs hstmt) query (loop for data-ptr across column-data-ptrs - when data-ptr do (uffi:free-foreign-object data-ptr)) - (loop for out-len-ptr across column-out-len-ptrs - when out-len-ptr do (uffi:free-foreign-object out-len-ptr)))) + for out-len-ptr across column-out-len-ptrs + when data-ptr + do (uffi:free-foreign-object data-ptr) + when out-len-ptr + do (uffi:free-foreign-object out-len-ptr)) + (setf (fill-pointer column-data-ptrs) 0 + (fill-pointer column-out-len-ptrs) 0))) (defmethod db-open-query ((database odbc-db) query-expression &key arglen col-positions result-types width @@ -328,7 +334,7 @@ the query against." )) (cond ((< 0 precision (query-width query)) (read-data data-ptr c-type sql-type out-len-ptr result-type)) ((zerop (get-cast-long out-len-ptr)) - nil) + nil) (t (read-data-in-chunks hstmt j data-ptr c-type sql-type out-len-ptr result-type)))))))) @@ -367,32 +373,31 @@ the query against." )) "get-free-query finds or makes a nonactive query object, and then sets it to active. This makes the functions db-execute-command and db-query thread safe." (with-slots (queries hdbc) database - (or (clsql-sys:without-interrupts - (let ((inactive-query (find-if (lambda (query) - (not (query-active-p query))) - queries))) - (when inactive-query - (with-slots (column-count column-names column-c-types - width hstmt - column-sql-types column-data-ptrs - column-out-len-ptrs column-precisions - column-scales column-nullables-p) - inactive-query - ;;(print column-data-ptrs tb::*local-output*) - ;;(%dispose-column-ptrs inactive-query) - (setf column-count 0 - width +max-precision+ - ;; KMR hstmt (%new-statement-handle hdbc) - (fill-pointer column-names) 0 - (fill-pointer column-c-types) 0 - (fill-pointer column-sql-types) 0 - (fill-pointer column-data-ptrs) 0 - (fill-pointer column-out-len-ptrs) 0 - (fill-pointer column-precisions) 0 - (fill-pointer column-scales) 0 - (fill-pointer column-nullables-p) 0)) - (setf (query-active-p inactive-query) t)) - inactive-query)) + (or (and *reuse-query-objects* + (clsql-sys:without-interrupts + (let ((inactive-query (find-if (lambda (query) + (not (query-active-p query))) + queries))) + (when inactive-query + (with-slots (column-count column-names column-c-types + width hstmt + column-sql-types column-data-ptrs + column-out-len-ptrs column-precisions + column-scales column-nullables-p) + inactive-query + (setf column-count 0 + width +max-precision+ + ;; KMR hstmt (%new-statement-handle hdbc) + (fill-pointer column-names) 0 + (fill-pointer column-c-types) 0 + (fill-pointer column-sql-types) 0 + (fill-pointer column-data-ptrs) 0 + (fill-pointer column-out-len-ptrs) 0 + (fill-pointer column-precisions) 0 + (fill-pointer column-scales) 0 + (fill-pointer column-nullables-p) 0)) + (setf (query-active-p inactive-query) t)) + inactive-query))) (let ((new-query (make-instance 'odbc-query :database database ;;(clone-database database) @@ -451,50 +456,51 @@ This makes the functions db-execute-command and db-query thread safe." ;; get column information (initialize-column col-nr)))) + ;; TODO: move this into the above loop (setf computed-result-types (make-array column-count)) (dotimes (i column-count) (setf (aref computed-result-types i) - (cond - ((consp result-types) - (nth i result-types)) - ((eq result-types :auto) - (if (eq (aref column-sql-types i) odbc::$SQL_BIGINT) - :number - (case (aref column-c-types i) - (#.odbc::$SQL_C_SLONG :int) - (#.odbc::$SQL_C_DOUBLE :double) - (#.odbc::$SQL_C_FLOAT :float) - (#.odbc::$SQL_C_SSHORT :short) - (#.odbc::$SQL_C_STINYINT :short) - (#.odbc::$SQL_BIGINT :short) - (t t)))) - (t - t))))) + (cond + ((consp result-types) + (nth i result-types)) + ((eq result-types :auto) + (case (aref column-c-types i) + (#.odbc::$SQL_C_SLONG :int) + (#.odbc::$SQL_C_DOUBLE :double) + (#.odbc::$SQL_C_FLOAT :float) + (#.odbc::$SQL_C_SSHORT :short) + (#.odbc::$SQL_C_STINYINT :short) + (#.odbc::$SQL_C_SBIGINT #.odbc::$ODBC-BIG-TYPE) + (#.odbc::$SQL_C_TYPE_TIMESTAMP :time) + (#.odbc::$SQL_C_CHAR ;; TODO: Read this as rational instead of double + (or (case (aref column-sql-types i) + ((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL) :double)) + T)) + + (t t))) + (t t))))) query) -(defun db-close-query (query &key drop-p) +(defun db-close-query (query &key (drop-p (not *reuse-query-objects*))) (with-slots (hstmt column-count column-names column-c-types column-sql-types - column-data-ptrs column-out-len-ptrs column-precisions - column-scales column-nullables-p) query - (let ((count (fill-pointer column-data-ptrs))) - (when (not (zerop count)) - (dotimes (col-nr count) - (let ((data-ptr (aref column-data-ptrs col-nr)) - (out-len-ptr (aref column-out-len-ptrs col-nr))) - (declare (ignorable data-ptr out-len-ptr)) - ;; free-statment :unbind frees these - #+ignore (when data-ptr (uffi:free-foreign-object data-ptr)) - #+ignore (when out-len-ptr (uffi:free-foreign-object out-len-ptr))))) - (cond ((null hstmt) - nil) - (drop-p - (%free-statement hstmt :drop) - (setf hstmt nil)) - (t - (%free-statement hstmt :unbind) - (%free-statement hstmt :reset) - (%free-statement hstmt :close))) - (setf (query-active-p query) nil))) + column-data-ptrs column-out-len-ptrs column-precisions + column-scales column-nullables-p database) query + (%dispose-column-ptrs query) + (cond ((null hstmt) nil) + (drop-p + (%free-statement hstmt :drop) + ;; dont free with uffi/ this is a double free and crashes everything + ;; (uffi:free-foreign-object hstmt) + (setf hstmt nil)) + (t + (%free-statement hstmt :unbind) + (%free-statement hstmt :reset) + (%free-statement hstmt :close))) + (setf (query-active-p query) nil) + (when drop-p + (clsql-sys:without-interrupts + (with-slots (queries) database + (setf queries (remove query queries)))))) query) (defmethod %read-query-data ((database odbc-db) ignore-columns) @@ -564,7 +570,8 @@ This makes the functions db-execute-command and db-query thread safe." (defun sql-to-lisp-type (sql-type) (ecase sql-type ((#.odbc::$SQL_CHAR #.odbc::$SQL_VARCHAR #.odbc::$SQL_LONGVARCHAR) :string) - ((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL #.odbc::$SQL_BIGINT) :string) ; ?? + ((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL) :string) ; ?? + (#.odbc::$SQL_BIGINT #.odbc::$ODBC-BIG-TYPE) (#.odbc::$SQL_INTEGER #.odbc::$ODBC-LONG-TYPE) (#.odbc::$SQL_SMALLINT :short) ((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) #.odbc::$ODBC-LONG-TYPE) @@ -575,6 +582,7 @@ This makes the functions db-execute-command and db-query thread safe." ;;((#.odbc::$SQL_BINARY #.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) odbc::$SQL_C_BINARY) ; ?? (#.odbc::$SQL_TINYINT :short) ;;(#.odbc::$SQL_BIT odbc::$SQL_C_BIT) ; ?? + (#.odbc::$SQL_BIT :short) ((#.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) :binary) )) @@ -586,7 +594,8 @@ This makes the functions db-execute-command and db-query thread safe." (let ((query (get-free-query database))) (with-slots (hstmt) query (unless hstmt (setf hstmt (%new-statement-handle hdbc)))) - (db-prepare-statement query sql parameter-table parameter-columns)))) + (db-prepare-statement + query sql :parameter-table parameter-table :parameter-columns parameter-columns)))) (defmethod db-prepare-statement ((query odbc-query) (sql string) &key parameter-table parameter-columns) @@ -609,15 +618,18 @@ This makes the functions db-execute-command and db-query thread safe." (defun %db-bind-execute (query &rest parameters) + "Only used from db-map-bind-query + parameters are released in %reset-query + " (with-slots (hstmt parameter-data-ptrs) query (loop for parameter in parameters with data-ptr and size and parameter-string do (setf parameter-string (if (stringp parameter) - parameter - (write-to-string parameter)) - size (length parameter-string) + parameter + (write-to-string parameter)) + size (length parameter-string) data-ptr (uffi:allocate-foreign-string (1+ size))) (vector-push-extend data-ptr parameter-data-ptrs) @@ -639,9 +651,12 @@ This makes the functions db-execute-command and db-query thread safe." (defun %db-reset-query (query) + "Only used from db-map-bind-query + parameters are allocated in %db-bind-execute + " (with-slots (hstmt parameter-data-ptrs) query (prog1 - (db-fetch-query-results query nil) + (db-fetch-query-results query nil) (%free-statement hstmt :reset) ;; but _not_ :unbind ! (%free-statement hstmt :close) (dotimes (param-nr (fill-pointer parameter-data-ptrs))