X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=db-odbc%2Fodbc-dbi.lisp;h=90cea24f1e8049c863ed0e883c6033322ea1f4cb;hp=f9e8493f55a7a78ad762344aa543628b93ac220a;hb=906d7a71b35ee1cd6d281623694bc90ced22c339;hpb=db9892632e6eb7869aea7a94c16b523a82de1501 diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp index f9e8493..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: odbc-sql.lisp 8983 2004-04-12 21:16:48Z kevin $ -;;;; ;;;; 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 @@ -40,7 +38,7 @@ #:run-prepared-sql #:set-autocommit #:sql - + #:*auto-trim-strings* #:*default-database* #:*default-odbc-external-format* @@ -50,6 +48,26 @@ (in-package #:odbc-dbi) +(defgeneric terminate (src)) +(defgeneric db-open-query (src query-expression + &key arglen col-positions result-types width + &allow-other-keys)) +(defgeneric db-fetch-query-results (src &optional count)) +(defgeneric %db-execute (src sql-expression &key &allow-other-keys)) +(defgeneric db-execute-command (src sql-string)) + +(defgeneric %initialize-query (src arglen col-positions + &key result-types width)) + +(defgeneric %read-query-data (src ignore-columns)) +(defgeneric db-map-query (src type function query-exp &key result-types)) +(defgeneric db-prepare-statement (src sql &key parameter-table + parameter-columns)) +(defgeneric get-odbc-info (src info-type)) + +(defvar *reuse-query-objects* t) + + ;;; SQL Interface (defclass odbc-db () @@ -77,24 +95,24 @@ (computed-result-types :initform nil :initarg :computed-result-types :accessor computed-result-types) (column-count :initform nil :accessor column-count) (column-names :initform (make-array 0 :element-type 'string :adjustable t :fill-pointer t) - :accessor column-names) + :accessor column-names) (column-c-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) - :accessor column-c-types) + :accessor column-c-types) (column-sql-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) - :accessor column-sql-types) + :accessor column-sql-types) (column-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t) - :accessor data-ptrs) + :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) - :accessor column-precisions) + :accessor column-out-len-ptrs) + (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) + :accessor column-scales) (column-nullables-p :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) - :accessor column-nullables-p) + :accessor column-nullables-p) ;;(parameter-count :initform 0 :accessor parameter-count) (parameter-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t) - :accessor parameter-ptrs) + :accessor parameter-ptrs) ;; a query string or a query expression object (sql-expression :initform nil :initarg :sql-expression :accessor sql-expression) ;; database object the query is to be run against @@ -106,51 +124,58 @@ the query against." )) ;;; AODBC Compatible interface -(defun connect (&key data-source-name user password (autocommit t)) +(defun connect (&key data-source-name user password connection-string completion window-handle (autocommit t)) (let ((db (make-instance 'odbc-db))) (unless (henv db) ;; has class allocation! (setf (henv db) (%new-environment-handle))) (setf (hdbc db) (%new-db-connection-handle (henv db))) - (%sql-connect (hdbc db) data-source-name user password) + (if connection-string + (%sql-driver-connect (hdbc db) + connection-string + (ecase completion + (:no-prompt odbc::$SQL_DRIVER_NOPROMPT) + (:complete odbc::$SQL_DRIVER_COMPLETE) + (:prompt odbc::$SQL_DRIVER_PROMPT) + (:complete-required odbc::$SQL_DRIVER_COMPLETE_REQUIRED)) + window-handle) + (%sql-connect (hdbc db) data-source-name user password)) #+ignore (setf (db-hstmt db) (%new-statement-handle (hdbc db))) (when (/= (get-odbc-info db odbc::$SQL_TXN_CAPABLE) odbc::$SQL_TC_NONE) (if autocommit - (enable-autocommit (hdbc db)) - (disable-autocommit (hdbc db)))) + (enable-autocommit (hdbc db)) + (disable-autocommit (hdbc db)))) 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))) -(defun sql (expr &key db result-types row-count (column-names t) query - hstmt width) +(defun sql (expr &key db result-types row-count (column-names t) query + hstmt width) (declare (ignore hstmt)) (cond (query (let ((q (db-open-query db expr :result-types result-types :width width))) (if column-names - (values q (column-names q)) - q))) + (values q (column-names q)) + q))) (t (multiple-value-bind (data col-names) - (db-query db expr :result-types result-types :width width) + (db-query db expr :result-types result-types :width width) (cond - (row-count - (if (consp data) (length data) data)) - (column-names - (values data col-names)) - (t - data)))))) + (row-count + (if (consp data) (length data) data)) + (column-names + (values data col-names)) + (t + data)))))) (defun fetch-row (query &optional (eof-errorp t) eof-value) (multiple-value-bind (row query count) (db-fetch-query-results query 1) @@ -158,11 +183,12 @@ the query against." )) ((zerop count) (close-query query) (when eof-errorp - (error 'clsql-odbc-error :odbc-message "Ran out of data in fetch-row")) + (error 'clsql:sql-database-data-error + :message "ODBC: Ran out of data in fetch-row")) eof-value) (t (car row))))) - + (defun close-query (query) (db-close-query query)) @@ -171,33 +197,40 @@ the query against." )) (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)))) - (%list-tables hstmt) - (%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)))) + (%list-tables hstmt) + (%initialize-query query nil nil) + (values + (db-fetch-query-results query) + (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 "" "" table "")) + (db-describe-columns db nil nil table nil)) ;; use nil rather than "" for unspecified values (defun list-all-data-sources () (let ((db (make-instance 'odbc-db))) @@ -211,13 +244,13 @@ the query against." )) ;;; Mid-level interface -(defmethod db-commit ((database odbc-db)) +(defun db-commit (database) (%commit (henv database) (hdbc database))) -(defmethod db-rollback ((database odbc-db)) +(defun db-rollback (database) (%rollback (henv database) (hdbc database))) -(defmethod db-cancel-query ((query odbc-query)) +(defun db-cancel-query (query) (with-slots (hstmt) query (%sql-cancel hstmt) (setf (query-active-p query) nil))) @@ -228,13 +261,13 @@ the query against." )) (:henv (henv ,*default-database*) :hdbc (hdbc ,*default-database*)) ,@body)) -(defmethod initialize-instance :after ((query odbc-query) +(defmethod initialize-instance :after ((query odbc-query) &key sql henv hdbc &allow-other-keys) (when sql (let ((hstmt (%new-statement-handle hdbc))) (%sql-exec-direct sql hstmt henv hdbc) - (with-slots (column-count - column-names column-c-types column-sql-types column-data-ptrs + (with-slots (column-count + column-names column-c-types column-sql-types column-data-ptrs column-out-len-ptrs column-precisions column-scales column-nullables-p active-p) query (setf (hstmt query) hstmt) @@ -242,83 +275,85 @@ 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)) -(defmethod %dispose-column-ptrs ((query odbc-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 - &allow-other-keys) + &key arglen col-positions result-types width + &allow-other-keys) (db-open-query (get-free-query database) query-expression :arglen arglen :col-positions col-positions - :result-types result-types - :width (if width width (db-width database)))) + :result-types result-types + :width (if width width (db-width database)))) (defmethod db-open-query ((query odbc-query) query-expression - &key arglen col-positions result-types width - &allow-other-keys) + &key arglen col-positions result-types width + &allow-other-keys) (%db-execute query query-expression) (%initialize-query query arglen col-positions :result-types result-types - :width width)) + :width width)) (defmethod db-fetch-query-results ((database odbc-db) &optional count) (db-fetch-query-results (db-query-object database) count)) (defmethod db-fetch-query-results ((query odbc-query) &optional count) (when (query-active-p query) - (with-slots (column-count column-data-ptrs column-c-types column-sql-types - column-out-len-ptrs column-precisions hstmt computed-result-types) - query + (with-slots (column-count column-data-ptrs column-c-types column-sql-types + column-out-len-ptrs column-precisions hstmt computed-result-types) + query (let* ((rows-fetched 0) - (rows - (loop for i from 0 - until (or (and count (= i count)) - (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND)) - collect - (loop for result-type across computed-result-types - for data-ptr across column-data-ptrs - for c-type across column-c-types - for sql-type across column-sql-types - for out-len-ptr across column-out-len-ptrs - for precision across column-precisions - for j from 0 ; column count is zero based in lisp - collect - (progn - (incf rows-fetched) - (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) - (t - (read-data-in-chunks hstmt j data-ptr c-type sql-type - out-len-ptr result-type)))))))) - (values rows query rows-fetched))))) - -(defmethod db-query ((database odbc-db) query-expression &key result-types width) + (rows + (loop for i from 0 + until (or (and count (= i count)) + (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND)) + collect + (loop for result-type across computed-result-types + for data-ptr across column-data-ptrs + for c-type across column-c-types + for sql-type across column-sql-types + for out-len-ptr across column-out-len-ptrs + for precision across column-precisions + for j from 0 ; column count is zero based in lisp + collect + (progn + (incf rows-fetched) + (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) + (t + (read-data-in-chunks hstmt j data-ptr c-type sql-type + out-len-ptr result-type)))))))) + (values rows query rows-fetched))))) + +(defun db-query (database query-expression &key result-types width) (let ((free-query (get-free-query database))) (setf (sql-expression free-query) query-expression) (unwind-protect (progn (%db-execute free-query query-expression) (%initialize-query free-query nil nil :result-types result-types :width width) - (if (plusp (column-count free-query)) ;; KMR: Added check for commands that don't return columns - (values - (db-fetch-query-results free-query nil) - (column-names free-query)) - (values - (result-rows-count (hstmt free-query)) - nil))) + (if (plusp (column-count free-query)) ;; KMR: Added check for commands that don't return columns + (values + (db-fetch-query-results free-query nil) + (map 'list #'identity (column-names free-query))) + (values + (result-rows-count (hstmt free-query)) + nil))) (db-close-query free-query) ))) @@ -328,42 +363,41 @@ the query against." )) (defmethod %db-execute ((query odbc-query) sql-expression &key &allow-other-keys) (with-slots (henv hdbc) (odbc::query-database query) (with-slots (hstmt) query - (unless hstmt (setf hstmt (%new-statement-handle hdbc))) + (unless hstmt (setf hstmt (%new-statement-handle hdbc))) (setf (sql-expression query) sql-expression) (%sql-exec-direct sql-expression hstmt henv hdbc) query))) ;; reuse inactive queries -(defmethod get-free-query ((database odbc-db)) +(defun get-free-query (database) "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-base-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) @@ -377,22 +411,22 @@ This makes the functions db-execute-command and db-query thread safe." (defmethod db-execute-command ((query odbc-query) sql-string) (with-slots (hstmt database) query (with-slots (henv hdbc) database - (unless hstmt (setf hstmt (%new-statement-handle hdbc))) - (unwind-protect + (unless hstmt (setf hstmt (%new-statement-handle hdbc))) + (unwind-protect (%sql-exec-direct sql-string hstmt henv hdbc) (db-close-query query))))) (defmethod %initialize-query ((database odbc-db) arglen col-positions &key result-types width) (%initialize-query (db-query-object database) arglen col-positions - :result-types result-types - :width (if width width (db-width database)))) + :result-types result-types + :width (if width width (db-width database)))) (defmethod %initialize-query ((query odbc-query) arglen col-positions &key result-types width) (with-slots (hstmt computed-result-types 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 + column-scales column-nullables-p) + query (setf column-count (if arglen (min arglen (result-columns-count hstmt)) (result-columns-count hstmt))) @@ -404,9 +438,10 @@ This makes the functions db-execute-command and db-query thread safe." ;; allocate space to bind result rows to (multiple-value-bind (c-type data-ptr out-len-ptr size long-p) (%allocate-bindings sql-type precision) - (unless long-p ;; if long-p we fetch in chunks with %sql-get-data + (if long-p ;; if long-p we fetch in chunks with %sql-get-data but must ensure that out_len_ptr is non zero + (setf (uffi:deref-pointer out-len-ptr #.odbc::$ODBC-LONG-TYPE) #.odbc::$SQL_NO_TOTAL) (%bind-column hstmt col-nr c-type data-ptr (1+ size) out-len-ptr)) - (vector-push-extend name column-names) + (vector-push-extend name column-names) (vector-push-extend sql-type column-sql-types) (vector-push-extend (sql-to-c-type sql-type) column-c-types) (vector-push-extend precision column-precisions) @@ -420,70 +455,73 @@ This makes the functions db-execute-command and db-query thread safe." (dotimes (col-nr column-count) ;; 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_BIGINT :short) - (t t)))) - (t - t))))) + (setf (aref computed-result-types i) + (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) -(defmethod db-close-query ((query odbc-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))) - ;; 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) (%read-query-data (db-query-object database) ignore-columns)) (defmethod %read-query-data ((query odbc-query) ignore-columns) - (with-slots (hstmt column-count column-c-types column-sql-types - column-data-ptrs column-out-len-ptrs column-precisions - computed-result-types) + (with-slots (hstmt column-count column-c-types column-sql-types + column-data-ptrs column-out-len-ptrs column-precisions + computed-result-types) query - (unless (= (SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND) + (unless (= (odbc::SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND) (values - (loop for col-nr from 0 to (- column-count + (loop for col-nr from 0 to (- column-count (if (eq ignore-columns :last) 2 1)) - for result-type across computed-result-types - collect + for result-type across computed-result-types + collect (let ((precision (aref column-precisions col-nr)) (sql-type (aref column-sql-types col-nr))) (cond ((or (< 0 precision (query-width query)) (and (zerop precision) (not (find sql-type '($SQL_C_CHAR))))) - (read-data (aref column-data-ptrs col-nr) + (read-data (aref column-data-ptrs col-nr) (aref column-c-types col-nr) sql-type (aref column-out-len-ptrs col-nr) @@ -492,7 +530,7 @@ This makes the functions db-execute-command and db-query thread safe." *null*) (t (read-data-in-chunks hstmt col-nr - (aref column-data-ptrs col-nr) + (aref column-data-ptrs col-nr) (aref column-c-types col-nr) (aref column-sql-types col-nr) (aref column-out-len-ptrs col-nr) @@ -515,8 +553,8 @@ This makes the functions db-execute-command and db-query thread safe." ;; dispose of memory and set query inactive or get rid of it (db-close-query query))) -(defmethod db-map-bind-query ((query odbc-query) type function - &rest parameters) +(defun db-map-bind-query (query type function + &rest parameters) (declare (ignore type)) ; preliminary. Do a type coersion here (unwind-protect (progn @@ -532,17 +570,19 @@ 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_INTEGER :long) + ((#.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) :long) - (#.odbc::$SQL_REAL :long) - (#.odbc::$SQL_DATE 'sql-c-date) - (#.odbc::$SQL_TIME 'sql-c-time) - (#.odbc::$SQL_TIMESTAMP 'sql-c-timestamp) + ((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) #.odbc::$ODBC-LONG-TYPE) + (#.odbc::$SQL_REAL #.odbc::$ODBC-LONG-TYPE) + ((#.odbc::$SQL_DATE #.odbc::$SQL_TYPE_DATE) 'sql-c-date) + ((#.odbc::$SQL_TIME #.odbc::$SQL_TYPE_TIME) 'sql-c-time) + ((#.odbc::$SQL_TIMESTAMP #.odbc::$SQL_TYPE_TIMESTAMP) 'sql-c-timestamp) ;;((#.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) )) @@ -551,10 +591,11 @@ This makes the functions db-execute-command and db-query thread safe." (defmethod db-prepare-statement ((database odbc-db) sql &key parameter-table parameter-columns) (with-slots (hdbc) database - (let ((query (get-free-query database))) + (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) @@ -562,7 +603,9 @@ This makes the functions db-execute-command and db-query thread safe." ;; support SQLDescribeParam. To do: put code in here for drivers that do ;; support it. (unless (string-equal sql "insert" :end1 6) - (error "Only insert expressions are supported in literal ODBC: '~a'." sql)) + (error 'clsql:sql-database-error + (format nil + "Only insert expressions are supported in literal ODBC: '~a'." sql))) (%db-execute query (format nil "select ~{~a~^,~} from ~a where 0 = 1" (or parameter-columns '("*")) parameter-table)) (%initialize-query query nil nil) @@ -574,24 +617,27 @@ This makes the functions db-execute-command and db-query thread safe." query) -(defmethod %db-bind-execute ((query odbc-query) &rest parameters) +(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) - data-ptr + 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) - (%sql-bind-parameter + (%sql-bind-parameter hstmt (1- (fill-pointer parameter-data-ptrs)) odbc::$SQL_PARAM_INPUT odbc::$SQL_C_CHAR ; (aref column-c-types parameter-count) odbc::$SQL_CHAR ; sql-type - (query-width query) ;precision ; this should be the actual precision! + (query-width query) ;precision ; this should be the actual precision! ;; scale 0 ;; should be calculated for odbc::$SQL_DECIMAL, ;;$SQL_NUMERIC and odbc::$SQL_TIMESTAMP @@ -604,10 +650,13 @@ This makes the functions db-execute-command and db-query thread safe." (%sql-execute hstmt))) -(defmethod %db-reset-query ((query odbc-query)) +(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)) @@ -625,12 +674,12 @@ This makes the functions db-execute-command and db-query thread safe." ;; database inquiery functions -(defmethod db-describe-columns ((database odbc-db) - table-qualifier table-owner table-name column-name) +(defun db-describe-columns (database table-qualifier table-owner + table-name column-name) (with-slots (hdbc) database (%describe-columns hdbc table-qualifier table-owner table-name column-name))) -;; should translate info-type integers to keywords in order to make this +;; should translate info-type integers to keywords in order to make this ;; more readable? (defmethod get-odbc-info ((database odbc-db) info-type) (with-slots (hdbc info) database @@ -641,17 +690,17 @@ This makes the functions db-execute-command and db-query thread safe." (defmethod get-odbc-info ((query odbc-query) info-type) (get-odbc-info (odbc::query-database query) info-type)) -;; driver inquiery +;; driver inquiry +;; How does this differ from list-data-sources? +(defgeneric db-data-sources (db-type)) (defmethod db-data-sources ((db-type (eql :odbc))) "Returns a list of (data-source description) - pairs" (let ((henv (%new-environment-handle))) (unwind-protect (loop with direction = :first - for data-source+description + for data-source+description = (multiple-value-list (%sql-data-sources henv :direction direction)) while (car data-source+description) collect data-source+description do (setf direction :next)) (%sql-free-environment henv)))) - -; EOF