(defvar *trace-sql* nil)
(defun %null-ptr ()
- (allocate-foreign-object :pointer-void))
+ (make-null-pointer :byte))
(defmacro %put-str (ptr string &optional max-length)
(let ((size (gensym)))
(setf (deref-array ,ptr '(:array :unsigned-char) i) (char ,string i)))
(setf (deref-array ,ptr '(:array :unsigned-char) ,size) 0))))
+(defun %cstring-into-vector (ptr vector offset size-in-bytes)
+ (dotimes (i size-in-bytes)
+ (setf (aref vector offset)
+ (deref-array ptr '(:array :unsigned-char) i))
+ (incf offset))
+ offset)
+
(defun handle-error (henv hdbc hstmt)
(with-foreign-objects ((sql-state '(:array :unsigned-char 256))
(error-message '(:array :unsigned-char
(defmacro with-error-handling ((&key henv hdbc hstmt (print-info t))
odbc-call &body body)
- (let ((result-code (gensym)))
+ (let ((result-code (gensym "RC-")))
`(let ((,result-code ,odbc-call))
(case ,result-code
(#.$SQL_SUCCESS
(SQLConnect hdbc server-ptr $SQL_NTS uid-ptr
$SQL_NTS pwd-ptr $SQL_NTS))))
-;;; SQLDriverConnect
-;;; [991115 CStacy@Pilgrim.COM]
-;;;
-;;; The CONNX ODBC driver can bring up a nice GUI prompt for the User-ID
-;;; and password, so that applications don't have to supply their own.
-;;;
-;;; That is not desirable for non-interactive applications, such as
-;;; web servers, so they should always supply complete login info
-;;; to SQLConnect. But the driver won't bring up a GUI anyway
-;;; unless the SQL_QUIET_MODE is set to an HWND (nonzero).
-;;; (CONNX version 6 did not have the GUI "Integrated Login" feature,
-;;; and in version 7, it was broken such that the GUI always came up.)
-;;;
-;;; Connx version 8 respects to that connection option, so the first
-;;; thing I tried was just setting it. I hacked the DB-CONNECT ODBC
-;;; method with this:
-;;; (without-error-handling
-;;; (SQLSetConnectOption hdbc $SQL_QUIET_MODE hwnd))
-;;; but that didn't work -- no GUI ever comes up from SQLConnect.
-;;; That may be a bug in the CONNX driver.
-;;;
-;;; In the end, the luser tech support person at CONNX Integrated Solutions
-;;; gave me the hint that if I were using VB, I should give it a string
-;;; like "DSN=CONNX8SAMPLES32, prompt=2". There's no ODBC API that wants
-;;; a string like that, but SQLDriverConnect does take an attribute-value-list
-;;; connection string (including driver-defined attributes). Reading the SDK
-;;; header files, I find that it also takes an argument that is 2 if you want
-;;; the driver to use a GUI and prompt the user. Eureka!
-;;;
-;;; If the user specified a DSN, we use SQL_DRIVER_COMPLETE and let the
-;;; Driver Manager find the appropriate driver. (Otherwise, aside from
-;;; the gratuitous prompt about the driver, the CONNX driver would also
-;;; prompting for the DSN and the Data Dictionary (CDD file).
-
-;; cstacy
-(defun odbc-connection-string (connection-string db-name user-id password)
- ;; Merge the specified attributes into a usable connection-string.
- (multiple-value-bind (dsn uid pwd other-attr-vals)
- (odbc-parse-connection-string connection-string)
- (setq db-name (or db-name dsn)
- user-id (or user-id uid)
- password (or password pwd)
- connection-string
- (format nil "DSN=~A~:[~;~:*;UID=~A~]~:[~;~:*;PWD=~A~]~:[~;~:*;~A~]"
- db-name user-id password other-attr-vals))
- (values
- connection-string
- db-name
- user-id
- password)))
-
-;; cstacy
-(defun odbc-parse-connection-string (connection-string)
- (flet ((parse (key)
- (let ((beg (search key connection-string :test #'equal)))
- (when beg
- (subseq connection-string
- (+ beg (length key))
- (position #\; connection-string :start beg))))))
- (let ((db-name (parse "DSN="))
- (user-id (parse "UID="))
- (password (parse "PWD=")))
- (values db-name user-id password nil))))
-
-(defun %sql-driver-connect (henv hdbc hwnd connection-string completion-option)
- (let ((completion-option
- (ecase completion-option
- (:complete $SQL_DRIVER_COMPLETE)
- (:required $SQL_DRIVER_COMPLETE_REQUIRED)
- (:prompt $SQL_DRIVER_PROMPT)
- (:noprompt $SQL_DRIVER_NOPROMPT))))
- (with-cstring (connection-str-ptr connection-string)
- (with-foreign-objects
- ((complete-connection-str-ptr '(:array :unsigned-char 1024))
- (length-ptr :short))
- (with-error-handling
- (:henv henv :hdbc hdbc)
- (SQLDriverConnect hdbc hwnd ; (%null-ptr) ; no window
- connection-str-ptr $SQL_NTS
- complete-connection-str-ptr 1024
- length-ptr completion-option))
- (print (convert-from-foreign-string complete-connection-str-ptr))))))
(defun %disconnect (hdbc)
(with-error-handling
(get-slot-value ptr 'sql-c-timestamp 'minute)
(get-slot-value ptr 'sql-c-timestamp 'hour)
0 0 0))
+
(in-package #:odbc-dbi)
-(defun connect (&key user password data-source-name)
- (warn "Not implemented.")
- nil)
+;;; SQL Interface
+
+(defclass odbc-db ()
+ (;; 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)
+ (type :initform nil :initarg :db-type :reader db-type)
+ (connected-p :initform nil :accessor db-connected-p)
+ ;; not used yet
+ (count :initform 0 :initarg :count :accessor db-count)
+ ;; not used yet
+ (total-count :initform 0 :allocation :class :accessor db-total-count)
+ ;; the use of this slot is deprecated; it will be removed when dtf works without it.
+ (query :initform nil :accessor db-query-object)
+ ;; resource of (active and inactive) query objects
+ (queries :initform () :accessor db-queries)))
+
+(defclass query ()
+ ((hstmt :initform nil :initarg :hstmt :accessor hstmt) ; = cursor??
+ (column-count :initform nil :accessor column-count)
+ (column-names :initform (make-array 0 :element-type 'string :adjustable t :fill-pointer t)
+ :accessor column-names)
+ (column-c-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
+ :accessor column-c-types)
+ (column-sql-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
+ :accessor column-sql-types)
+ (column-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t)
+ :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)
+ (column-scales :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
+ :accessor column-scales)
+ (column-nullables-p :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
+ :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)
+ ;; 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
+ (database :initarg :database :reader query-database)
+ (active-p :initform nil :initarg :active-p :accessor query-active-p))
+ (:documentation
+ "Stores query information, like SQL query string/expression and database to run
+the query against." ))
+
+(defun connect (&key data-source-name user password (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)
+ ;; FIXME: Check if connected
+ (when (/= (get-odbc-info db odbc::$SQL_TXN_CAPABLE) odbc::$SQL_TC_NONE)
+ (if autocommit
+ (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)))))
+ (%disconnect hdbc)))
-(defun disconnect (conn)
- (warn "Not implemented."))
(defun sql (expr &key db result-types row-count column-names)
(warn "Not implemented."))
(defun fetch-row (result-set error-eof eof-value)
(warn "Not implemented."))
-
(defclass odbc-query (query)
((hstmt :initform nil :initarg :hstmt :accessor hstmt) ; = cursor??
(column-count :initform nil :accessor column-count)
(parameter-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t)
:accessor parameter-ptrs)))
-(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))
+(defmethod db-commit ((database odbc-db))
(%commit (henv database) (hdbc database)))
-(defmethod db-rollback ((database odbc-database))
+(defmethod db-rollback ((database odbc-db))
(%rollback (henv database) (hdbc database)))
(defmethod db-cancel-query ((query odbc-query))
(%initialize-query query)
(setf active-p t)))))
-;; one for odbc-database is missing
+;; one for odbc-db is missing
(defmethod terminate ((query odbc-query))
;;(format tb::*local-output* "~%*** terminated: ~s" query)
(with-slots (hstmt) query
(loop for out-len-ptr across column-out-len-ptrs
when out-len-ptr do (uffi:free-foreign-object out-len-ptr))))
-(defmethod db-open-query ((database odbc-database) query-expression
+(defmethod db-open-query ((database odbc-db) query-expression
&key arglen col-positions
&allow-other-keys)
(db-open-query (get-free-query database) query-expression
(%db-execute query query-expression)
(%initialize-query query arglen col-positions))
-(defmethod db-fetch-query-results ((database odbc-database) &optional count flatp)
- (db-fetch-query-results (odbc::db-query-object database) count flatp))
+(defmethod db-fetch-query-results ((database odbc-db) &optional count flatp)
+ (db-fetch-query-results (db-query-object database) count flatp))
(defmethod db-fetch-query-results ((query odbc-query) &optional count flatp)
(when (query-active-p query)
(defmacro without-interrupts (&body body)
`(pcl::without-interrupts ,@body))
-(defmethod db-query ((database odbc-database) query-expression &optional flatp)
+(defmethod db-query ((database odbc-db) query-expression &optional flatp)
(let ((free-query
;; make it thread safe
(get-free-query database)))
;;(format tb::*local-output* "~%query closed: ~s" free-query)
)))
-(defmethod %db-execute ((database odbc-database) sql-expression &key &allow-other-keys)
+(defmethod %db-execute ((database odbc-db) sql-expression &key &allow-other-keys)
(%db-execute (get-free-query database) sql-expression))
;; C. Stacy's idea
query)))
;; reuse inactive queries
-(defmethod get-free-query ((database odbc-database))
+(defmethod get-free-query ((database odbc-db))
"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
(push new-query queries)
new-query))))
-(defmethod db-execute-command ((database odbc-database) sql-string)
+(defmethod db-execute-command ((database odbc-db) sql-string)
(db-execute-command (get-free-query database) sql-string))
(defmethod db-execute-command ((query odbc-query) sql-string)
(%sql-exec-direct sql-string hstmt henv hdbc)
(db-close-query query)))))
-(defmethod %initialize-query ((database odbc-database) &optional arglen col-positions)
+(defmethod %initialize-query ((database odbc-db) &optional arglen col-positions)
(%initialize-query (db-query-object database) arglen col-positions))
(defmethod %initialize-query ((query odbc-query) &optional arglen col-positions)
(setf (query-active-p query) nil)))
query)
-(defmethod %read-query-data ((database odbc-database) ignore-columns)
+(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)
nil)))))
t))))
-(defmethod db-map-query ((database odbc-database) type function query-exp)
+(defmethod db-map-query ((database odbc-db) type function query-exp)
(db-map-query (get-free-query database) type function query-exp))
(defmethod db-map-query ((query odbc-query) type function query-exp)
(declare (ignore type)) ; preliminary. Do a type coersion here
- (%db-execute query (odbc::sql-string query-exp))
+ (%db-execute query (sql-expression query-exp))
(unwind-protect
(progn
(%initialize-query query)
;; prepared queries
-(defmethod db-prepare-statement ((database odbc-database) sql
+(defmethod db-prepare-statement ((database odbc-db) sql
&key parameter-table parameter-columns)
(with-slots (hdbc) database
(let ((query (get-free-query database)))
;; database inquiery functions
-(defmethod db-describe-columns ((database odbc-database)
+(defmethod db-describe-columns ((database odbc-db)
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
;; more readable?
-(defmethod get-odbc-info ((database odbc-database) info-type)
+(defmethod get-odbc-info ((database odbc-db) info-type)
(with-slots (hdbc info) database
(or (gethash info-type info)
(setf (gethash info-type info)
projects / clsql.git / commitdiff