From a7e38685365a6cf067290843c0ed168b6fb545e9 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 13 Apr 2004 22:01:16 +0000 Subject: [PATCH] r9003: odbc updates --- db-odbc/odbc-api.lisp | 94 ++------------- db-odbc/odbc-dbi.lisp | 233 +++++++++++++++----------------------- db-odbc/odbc-package.lisp | 4 +- db-odbc/odbc-sql.lisp | 20 ++++ 4 files changed, 122 insertions(+), 229 deletions(-) diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index 1775b31..1d48bca 100644 --- a/db-odbc/odbc-api.lisp +++ b/db-odbc/odbc-api.lisp @@ -24,7 +24,7 @@ (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))) @@ -36,6 +36,13 @@ (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 @@ -65,7 +72,7 @@ (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 @@ -140,88 +147,6 @@ (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 @@ -942,3 +867,4 @@ (get-slot-value ptr 'sql-c-timestamp 'minute) (get-slot-value ptr 'sql-c-timestamp 'hour) 0 0 0)) + diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp index 421b720..6d62f3d 100644 --- a/db-odbc/odbc-dbi.lisp +++ b/db-odbc/odbc-dbi.lisp @@ -48,12 +48,79 @@ (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.")) @@ -64,7 +131,6 @@ (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) @@ -88,131 +154,10 @@ (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)) @@ -239,7 +184,7 @@ (%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 @@ -255,7 +200,7 @@ (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 @@ -266,8 +211,8 @@ (%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) @@ -338,7 +283,7 @@ (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))) @@ -356,7 +301,7 @@ ;;(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 @@ -374,7 +319,7 @@ 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 @@ -408,7 +353,7 @@ This makes the functions db-execute-command and db-query thread safe." (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) @@ -423,7 +368,7 @@ This makes the functions db-execute-command and db-query thread safe." (%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) @@ -483,7 +428,7 @@ This makes the functions db-execute-command and db-query thread safe." (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) @@ -515,12 +460,12 @@ This makes the functions db-execute-command and db-query thread safe." 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) @@ -564,7 +509,7 @@ This makes the functions db-execute-command and db-query thread safe." ;; 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))) @@ -642,14 +587,14 @@ This makes the functions db-execute-command and db-query thread safe." ;; 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) diff --git a/db-odbc/odbc-package.lisp b/db-odbc/odbc-package.lisp index cd40c00..ce96084 100644 --- a/db-odbc/odbc-package.lisp +++ b/db-odbc/odbc-package.lisp @@ -33,9 +33,9 @@ #:%rollback #:%sql-fetch #:%sql-cancel + #:db-connect #:%new-db-connection-handle #:%new-environment-handle - #:%sql-driver-connect #:%sql-connect #:disable-autocommit #:enable-autocommit @@ -59,6 +59,8 @@ #:%new-statement-handle #:%sql-exec-direct #:%put-str + #:result-columns-count + #:sql-to-c-type ) (:documentation "This is the low-level interface ODBC.")) diff --git a/db-odbc/odbc-sql.lisp b/db-odbc/odbc-sql.lisp index bcde3fc..a92e6fe 100644 --- a/db-odbc/odbc-sql.lisp +++ b/db-odbc/odbc-sql.lisp @@ -52,6 +52,26 @@ :errno nil :error "Connection failed"))))) +#+nil +(defun store-type-of-connected-database (db) + (let* ((odbc-db (odbc-db db)) + (server-name (get-odbc-info odbc-db odbc::$SQL_SERVER_NAME)) + (dbms-name (get-odbc-info odbc-db odbc::$SQL_DBMS_NAME)) + (type + ;; need SERVER-NAME and DBMS-NAME because many drivers mix this up + (cond + ((or (search "postgresql" server-name :test #'char-equal) + (search "postgresql" dbms-name :test #'char-equal)) + :postgresql) + ((or (search "mysql" server-name :test #'char-equal) + (search "mysql" dbms-name :test #'char-equal)) + :mysql) + ((or (search "oracle" server-name :test #'char-equal) + (search "oracle" dbms-name :test #'char-equal)) + :oracle)))) + (setf (database-type db) type))) + + (defmethod database-disconnect ((database odbc-database)) (odbc-dbi:disconnect (database-odbc-conn database)) (setf (database-odbc-conn database) nil) -- 2.34.1