- (enable-autocommit (hdbc db))
- (disable-autocommit (hdbc db)))))
- db)
-
-;; cstacy
-(defgeneric driver-connect (db-type &key hwnd connection-string
- completion-mode
- db-name user-id password
- &allow-other-keys))
-
-;; cstacy
-(defmethod driver-connect ((db-type (eql :odbc)) &key hwnd connection-string
- (completion-mode :complete)
- db-name user-id password)
- (multiple-value-bind (connection-string db-name user-id password)
- (odbc-connection-string connection-string db-name user-id password)
- (let ((db (make-instance 'odbc-database
- :db-type :odbc
- :db-name db-name
- :user-id user-id
- :password password)))
- (unless (henv db) ;; has class allocation!
- (setf (henv db) (%new-environment-handle))) ;SQLAllocEnv
- (setf (hdbc db) (%new-db-connection-handle (henv db))) ;SQLAllocConnect
- (cond ((null hwnd)
- (setq hwnd (%null-ptr)))
- #+(and :lispworks (not :unix))
- ((eq hwnd t)
- (setq hwnd (capi-library::representation-handle
- (capi:representation
- (ww::find-topmost-window nil nil)))))
- #+(and :lispworks (not :unix))
- ((eq hwnd :podium)
- (setq hwnd (capi-win32-lib::r-top-level-interface-hwnd win32::*main-representation*)))
- ((not (integerp hwnd))
- (error "HWND is not NIL, T, :PODIUM, or an integer")))
- ;; if connection cannot be established, we drop out here.
- (driver-connect db
- :hwnd hwnd
- :connection-string connection-string
- :completion-mode completion-mode))))
-
-;; cstacy
-(defmethod driver-connect ((db odbc-database) &key hwnd connection-string completion-mode
- &allow-other-keys)
- (let ((completion (%sql-driver-connect
- (henv db) (hdbc db) hwnd connection-string completion-mode)))
- (multiple-value-bind (dsn uid pwd)
- (odbc-parse-connection-string completion)
- (flet ((non-string-null (x) (and x (not (string= x "")) x)))
- (setf (odbc::db-name db) (or (non-string-null (odbc::db-name db)) dsn))
- (setf (odbc::db-user-id db) (or (non-string-null (odbc::db-user-id db)) uid))
- (setf (odbc::db-password db) (or (non-string-null (odbc::db-password db)) pwd)))))
- db)
-
-(defmethod db-disconnect ((database odbc-database))
- (with-slots (hdbc queries odbc::connected-p) database
- (when odbc::connected-p
- (dolist (query queries)
- (if (query-active-p query)
- (with-slots (hstmt) query
- (when hstmt
- (%free-statement hstmt :drop)
- (setf hstmt nil)))))
- (%disconnect hdbc)
- #+kmr-nil
- (let ((reset-default-db-p (eq *default-database* database)))
- (setf *connected-databases* (delete database *connected-databases*)
- odbc::connected-p nil)
- (when reset-default-db-p
- (setf *default-database* (car *connected-databases*)))))))
-
-(defmethod db-commit ((database odbc-database))
+ (enable-autocommit (hdbc db))
+ (disable-autocommit (hdbc db))))
+ db))
+
+(defun disconnect (database)
+ (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)))))
+ (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)
+ (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)))
+ (t
+ (multiple-value-bind (data col-names)
+ (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))))))
+
+(defun fetch-row (query &optional (eof-errorp t) eof-value)
+ (multiple-value-bind (row query count) (db-fetch-query-results query 1)
+ (cond
+ ((zerop count)
+ (close-query query)
+ (when eof-errorp
+ (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))
+
+(defun list-all-database-tables (&key db 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))))
+ (%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)
+ (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 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))
+ (warn "rr-sql not implemented."))
+
+;;; Mid-level interface
+
+(defun db-commit (database)