X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=db-odbc%2Fodbc-dbi.lisp;h=634a43e2601f101cc9b19e51d6aea0be108925a5;hp=08a8df693d32f82df2e436be631b7ec6891abe45;hb=5148be446aee32ec705beac3fbba35f499df4fd4;hpb=d0f147d0e7d942b379bd7cd472f26b00c33916bc diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp index 08a8df6..634a43e 100644 --- a/db-odbc/odbc-dbi.lisp +++ b/db-odbc/odbc-dbi.lisp @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Create: April 2004 ;;;; -;;;; $Id: odbc-sql.lisp 8983 2004-04-12 21:16:48Z kevin $ +;;;; $Id$ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -30,8 +30,10 @@ #:disconnect #:end-transaction #:fetch-row + #:list-all-data-sources #:list-all-database-tables #:list-all-table-columns + #:list-table-indexes #:loop-over-results #:prepare-sql #:rr-sql @@ -48,6 +50,24 @@ (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)) + + ;;; SQL Interface (defclass odbc-db () @@ -110,7 +130,7 @@ the query against." )) (setf (henv db) (%new-environment-handle))) (setf (hdbc db) (%new-db-connection-handle (henv db))) (%sql-connect (hdbc db) data-source-name user password) - (setf (db-hstmt db) (%new-statement-handle (hdbc db))) + #+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)) @@ -125,7 +145,8 @@ the query against." )) (when hstmt (%free-statement hstmt :drop) (setf hstmt nil))))) - (%free-statement (db-hstmt database) :drop) + (when (db-hstmt database) + (%free-statement (db-hstmt database) :drop)) (%disconnect hdbc))) @@ -155,7 +176,8 @@ 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))))) @@ -178,23 +200,44 @@ the query against." )) (coerce (column-names query) 'list)))) (db-close-query query)))) +(defun list-table-indexes (table &key db unique hstmt) + (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)))) + (db-close-query query)))) + (defun list-all-table-columns (table &key db hstmt) (declare (ignore hstmt)) (db-describe-columns db "" "" table "")) +(defun list-all-data-sources () + (let ((db (make-instance 'odbc-db))) + (unless (henv db) ;; has class allocation! + (setf (henv db) (%new-environment-handle))) + (%list-data-sources (henv db)))) + (defun rr-sql (hstmt sql-statement &key db) (declare (ignore hstmt sql-statement db)) (warn "rr-sql not implemented.")) ;;; 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))) @@ -227,7 +270,7 @@ the query against." )) (uffi:free-foreign-object hstmt)) ;; ?? (%dispose-column-ptrs query))) -(defmethod %dispose-column-ptrs ((query odbc-query)) +(defun %dispose-column-ptrs (query) (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)) @@ -282,7 +325,7 @@ the query against." )) out-len-ptr result-type)))))))) (values rows query rows-fetched))))) -(defmethod db-query ((database odbc-db) query-expression &key result-types width) +(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 @@ -292,7 +335,7 @@ the query against." )) (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)) + (map 'list #'identity (column-names free-query))) (values (result-rows-count (hstmt free-query)) nil))) @@ -311,17 +354,17 @@ the query against." )) 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) database - (or (clsql-base-sys:without-interrupts + (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 + width hstmt column-sql-types column-data-ptrs column-out-len-ptrs column-precisions column-scales column-nullables-p) @@ -330,6 +373,7 @@ This makes the functions db-execute-command and db-query thread safe." ;;(%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 @@ -411,13 +455,14 @@ This makes the functions db-execute-command and db-query thread safe." (#.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))))) + t))))) query) -(defmethod db-close-query ((query odbc-query) &key drop-p) +(defun db-close-query (query &key drop-p) (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 @@ -426,8 +471,10 @@ This makes the functions db-execute-command and db-query thread safe." (dotimes (col-nr count) (let ((data-ptr (aref column-data-ptrs col-nr)) (out-len-ptr (aref column-out-len-ptrs col-nr))) - (when data-ptr (uffi:free-foreign-object data-ptr)) ; we *did* allocate them - (when out-len-ptr (uffi:free-foreign-object out-len-ptr))))) + (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 @@ -448,7 +495,7 @@ This makes the functions db-execute-command and db-query thread safe." 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 (if (eq ignore-columns :last) 2 1)) @@ -490,8 +537,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 @@ -508,10 +555,10 @@ This makes the functions db-execute-command and db-query thread safe." (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_INTEGER #.odbc::$ODBC-LONG-TYPE) (#.odbc::$SQL_SMALLINT :short) - ((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) :long) - (#.odbc::$SQL_REAL :long) + ((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) #.odbc::$ODBC-LONG-TYPE) + (#.odbc::$SQL_REAL #.odbc::$ODBC-LONG-TYPE) (#.odbc::$SQL_DATE 'sql-c-date) (#.odbc::$SQL_TIME 'sql-c-time) (#.odbc::$SQL_TIMESTAMP 'sql-c-timestamp) @@ -537,7 +584,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) @@ -549,7 +598,7 @@ 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) (with-slots (hstmt parameter-data-ptrs) query (loop for parameter in parameters with data-ptr and size and parameter-string @@ -579,7 +628,7 @@ 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) (with-slots (hstmt parameter-data-ptrs) query (prog1 (db-fetch-query-results query nil) @@ -600,8 +649,8 @@ 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))) @@ -616,7 +665,9 @@ 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))) @@ -628,5 +679,3 @@ This makes the functions db-execute-command and db-query thread safe." collect data-source+description do (setf direction :next)) (%sql-free-environment henv)))) - -; EOF