;;;; 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
;;;;
#: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
(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 ()
;;; 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
((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)))))
(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 ""))
+ (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)))
+ (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))
;;; 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)))
(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))
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
(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)))
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
+ (or (clsql-sys:without-interrupts
(let ((inactive-query (find-if (lambda (query)
(not (query-active-p query)))
queries)))
;;(%dispose-column-ptrs inactive-query)
(setf column-count 0
width +max-precision+
- hstmt (%new-statement-handle hdbc)
+ ;; KMR hstmt (%new-statement-handle hdbc)
(fill-pointer column-names) 0
(fill-pointer column-c-types) 0
(fill-pointer column-sql-types) 0
;; 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 sql-type column-sql-types)
(#.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
(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
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))
;; 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
(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_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) ; ??
;; 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)
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
(%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)
;; 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)))
(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)))
collect data-source+description
do (setf direction :next))
(%sql-free-environment henv))))
-
-; EOF
projects / clsql.git / blobdiff