-(defclass odbc-database (database)
- (;; any reason to have more than one henv?
- (henv :initform nil :allocation :class :initarg :henv :accessor henv)
- (hdbc :initform nil :initarg :hdbc :accessor hdbc)
- ;; info returned from SQLGetInfo
- (info :initform (make-hash-table) :reader db-info))
- #+cormanlisp (:metaclass cl::class-slot-class))
-
-;; use this method if the db object does not exist yet
-
-;; cstacy
-(defparameter *odbc-driver-connect-p* nil)
-
-;; cstacy
-(defmethod db-connect ((db-type (eql :odbc)) db-name user-id password autocommit)
- (if *odbc-driver-connect-p*
- (driver-connect db-type :db-name db-name :user-id user-id :password password)
- ;; Else just use SQLConnect (old way).
- (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)))
- (setf (hdbc db) (%new-db-connection-handle (henv db)))
- ;; if connection cannot be established, we drop out here.
- (db-connect db db-name user-id password autocommit))))
-
-;; cstacy
-(defmethod db-connect ((db odbc-database) db-name user-id password autocommit)
- (if *odbc-driver-connect-p*
- (driver-connect db :db-name db-name :user-id user-id :password password)
- ;; Else just use SQLConnect (old way).
- (%sql-connect (hdbc db) db-name user-id password))
- ;; If we got this far without erring out, the database was successfully connected.
- (setf (odbc::db-connected-p db) t)
- (let ((server-name (get-odbc-info db odbc::$SQL_SERVER_NAME))
- (dbms-name (get-odbc-info db odbc::$SQL_DBMS_NAME))
- (txn-capable-p (/= (get-odbc-info db odbc::$SQL_TXN_CAPABLE) odbc::$SQL_TC_NONE)))
- ;; need SERVER-NAME and DBMS-NAME because many drivers mix this up
- (flet ((db-type-p (db-name)
- (or (search db-name server-name :test #'char-equal)
- (search db-name dbms-name :test #'char-equal))))
- (cond ((db-type-p "oracle") (change-class db 'oracle-database))
- ((db-type-p "access") (change-class db 'access-database))
- ((db-type-p "mysql") (change-class db 'mysql-database))
- (t nil)))
- (when txn-capable-p ; has transaction support
- (if autocommit
- (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))