From: Kevin M. Rosenberg Date: Tue, 13 Apr 2004 20:20:28 +0000 (+0000) Subject: r9001: Initial port to UFFI of SQL-ODBC X-Git-Tag: v3.8.6~633 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=44152655aacc033b0a544aca9f91700177d22a03 r9001: Initial port to UFFI of SQL-ODBC --- diff --git a/COPYING.SQL-ODBC b/COPYING.SQL-ODBC new file mode 100644 index 0000000..b77a944 --- /dev/null +++ b/COPYING.SQL-ODBC @@ -0,0 +1,21 @@ +;;; SQL/ODBC module for MCL, CMUCL, LispWorks, ACL and CormanLisp +;;; Version 0.9 +;;; Copyright (C) Paul Meurer 1999-2001 All rights reserved. +;;; paul.meurer@hit.uib.no +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted, so long as the following +;;; conditions are met: +;;; o This copyright notice is included intact. +;;; o No fees or compensation are charged for use, copies, or +;;; access to this software. You may charge a nominal +;;; distribution fee for the physical act of transferring a +;;; copy, but you may not charge for the program itself. +;;; o You are allowed to use this software as part of a commercial +;;; software package, provided that its functionality significantly +;;; exceeds the functionality of this software, and that the use of +;;; this software is explicitly mentioned in your documentation. +;;; +;;; This software is made available AS IS, and no warranty is made about +;;; the software or its performance. + diff --git a/ChangeLog b/ChangeLog index 1bbbb26..799abd3 100644 --- a/ChangeLog +++ b/ChangeLog @@ -4,7 +4,9 @@ expansion of WITH-TRANSACTIONS [Time Howe] * db-sqlite/sqlite-sql.lisp: Support memory database in database-probe [Ng Pheng Siong] - + * db-odbc/*.lisp: Initial port to UFFI of SQL-ODBC. + The DBI layer is not finished. + 12 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.6.11 * sql/objects.lisp: add :root-class functionality for diff --git a/clsql-odbc.asd b/clsql-odbc.asd index d3e728d..6da2c6e 100644 --- a/clsql-odbc.asd +++ b/clsql-odbc.asd @@ -20,7 +20,7 @@ (in-package #:clsql-odbc-system) #+(or allegro lispworks cmu sbcl openmcl mcl scl) -(defsystem :clsql-odbc +(defsystem clsql-odbc :name "clsql-odbc" :author "Kevin M. Rosenberg " :maintainer "Kevin M. Rosenberg " @@ -34,7 +34,9 @@ :components ((:file "odbc-package") (:file "odbc-loader" :depends-on ("odbc-package")) - (:file "odbc-api" :depends-on ("odbc-loader")) + (:file "odbc-constants" :depends-on ("odbc-loader")) + (:file "odbc-ff-interface" :depends-on ("odbc-loader")) + (:file "odbc-api" :depends-on ("odbc-ff-interface" "odbc-constants")) (:file "odbc-dbi" :depends-on ("odbc-api")) (:file "odbc-sql" :depends-on ("odbc-dbi")))))) diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index 717d9cf..1775b31 100644 --- a/db-odbc/odbc-api.lisp +++ b/db-odbc/odbc-api.lisp @@ -1,15 +1,15 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: odbc -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: odbc-api.lisp -;;;; Purpose: Low-level Odbc interface using UFFI -;;;; Author: Kevin M. Rosenberg based on -;;;; Created: April 2004 +;;;; Name: odbc-ff-interface.lisp +;;;; Purpose: Function definitions for UFFI interface to ODBC +;;;; Author: Kevin M. Rosenberg, Paul Meurer ;;;; -;;;; $Id: odbc-api.lisp 8811 2004-04-02 20:45:48Z kevin $ +;;;; $Id: odbc-package.lisp 7061 2003-09-07 06:34:45Z kevin $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2004 by Kevin M. Rosenberg +;;;; and Copyright (C) Paul Meurer 1999 - 2001. All rights reserved. ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser GNU Public License @@ -18,3 +18,927 @@ (in-package #:odbc) +(defvar *null* (make-null-pointer :byte)) +(defvar *binary-format* :unsigned-byte-vector) +(defvar *time-conversion-function* 'identity) +(defvar *trace-sql* nil) + +(defun %null-ptr () + (allocate-foreign-object :pointer-void)) + +(defmacro %put-str (ptr string &optional max-length) + (let ((size (gensym))) + `(let ((,size (length ,string))) + (when (and ,max-length (> ,size ,max-length)) + (error "string \"~a\" of length ~d is longer than max-length: ~d" + ,string ,size ,max-length)) + (dotimes (i ,size) + (setf (deref-array ,ptr '(:array :unsigned-char) i) (char ,string i))) + (setf (deref-array ,ptr '(:array :unsigned-char) ,size) 0)))) + +(defun handle-error (henv hdbc hstmt) + (with-foreign-objects ((sql-state '(:array :unsigned-char 256)) + (error-message '(:array :unsigned-char + #.$SQL_MAX_MESSAGE_LENGTH)) + (error-code :long) + (msg-length :short)) + (SQLError henv hdbc hstmt sql-state + error-code error-message + $SQL_MAX_MESSAGE_LENGTH msg-length) + (values + (convert-from-foreign-string error-message) + (convert-from-foreign-string sql-state) + (deref-pointer msg-length :short) + (deref-pointer error-code :long)))) + +; test this: return a keyword for efficiency +(defun sql-state (henv hdbc hstmt) + (with-foreign-objects ((sql-state '(:array :unsigned-char 256)) + (error-message '(:array :unsigned-char + #.$SQL_MAX_MESSAGE_LENGTH)) + (error-code :long) + (msg-length :short)) + (SQLError henv hdbc hstmt sql-state error-code + error-message $SQL_MAX_MESSAGE_LENGTH msg-length) + (convert-from-foreign-string sql-state) ;(%cstring-to-keyword sql-state) + )) + +(defmacro with-error-handling ((&key henv hdbc hstmt (print-info t)) + odbc-call &body body) + (let ((result-code (gensym))) + `(let ((,result-code ,odbc-call)) + (case ,result-code + (#.$SQL_SUCCESS + (progn ,result-code ,@body)) + (#.$SQL_SUCCESS_WITH_INFO + (when ,print-info + (multiple-value-bind (error-message sql-state) + (handle-error (or ,henv (%null-ptr)) + (or ,hdbc (%null-ptr)) + (or ,hstmt (%null-ptr))) + (warn "[ODBC info] ~a state: ~a" + ,result-code error-message + sql-state))) + (progn ,result-code ,@body)) + (#.$SQL_INVALID_HANDLE + (error "[ODBC error] Invalid handle")) + (#.$SQL_STILL_EXECUTING + (error "[ODBC error] Still executing")) + (#.$SQL_ERROR + (multiple-value-bind (error-message sql-state) + (handle-error (or ,henv (%null-ptr)) + (or ,hdbc (%null-ptr)) + (or ,hstmt (%null-ptr))) + (error "[ODBC error] ~a; state: ~a" error-message sql-state))) + (otherwise + (progn ,result-code ,@body)))))) + +(defun %new-environment-handle () + (with-foreign-object (phenv 'sql-handle-ptr) + (with-error-handling + () + (SQLAllocEnv phenv) + (deref-pointer phenv 'sql-handle-ptr)))) + +(defun %sql-free-environment (henv) + (with-error-handling + (:henv henv) + (SQLFreeEnv henv))) + +(defun %new-db-connection-handle (henv) + (with-foreign-object (phdbc 'sql-handle-ptr) + (with-error-handling + (:henv henv) + (SQLAllocConnect henv phdbc) + (deref-pointer phdbc 'sql-handle-ptr)))) + +(defun %free-statement (hstmt option) + (with-error-handling + (:hstmt hstmt) + (SQLFreeStmt + hstmt + (ecase option + (:drop $SQL_DROP) + (:close $SQL_CLOSE) + (:unbind $SQL_UNBIND) + (:reset $SQL_RESET_PARAMS))))) + +(defmacro with-statement-handle ((hstmt hdbc) &body body) + `(let ((,hstmt (%new-statement-handle ,hdbc))) + (unwind-protect + (progn ,@body) + (%free-statement ,hstmt :drop)))) + +;; functional interface + +(defun %sql-connect (hdbc server uid pwd) + (with-cstrings ((server-ptr server) + (uid-ptr uid) + (pwd-ptr pwd)) + (with-error-handling + (:hdbc hdbc) + (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 + (:hdbc hdbc) + (SQLDisconnect hdbc))) + +(defun %commit (henv hdbc) + (with-error-handling + (:henv henv :hdbc hdbc) + (SQLTransact + henv hdbc $SQL_COMMIT))) + +(defun %rollback (henv hdbc) + (with-error-handling + (:henv henv :hdbc hdbc) + (SQLTransact + henv hdbc $SQL_ROLLBACK))) + +; col-nr is zero-based in Lisp +; col-nr = :bookmark retrieves a bookmark. +(defun %bind-column (hstmt column-nr c-type data-ptr precision out-len-ptr) + (with-error-handling + (:hstmt hstmt) + (SQLBindCol hstmt + (if (eq column-nr :bookmark) 0 (1+ column-nr)) + c-type data-ptr precision out-len-ptr))) + +; parameter-nr is zero-based in Lisp +(defun %sql-bind-parameter (hstmt parameter-nr parameter-type c-type + sql-type precision scale data-ptr + max-value out-len-ptr) + (with-error-handling + (:hstmt hstmt) + (SQLBindParameter hstmt (1+ parameter-nr) + parameter-type ;$SQL_PARAM_INPUT + c-type ;$SQL_C_CHAR + sql-type ;$SQL_VARCHAR + precision ;(1- (length str)) + scale ;0 + data-ptr + max-value + out-len-ptr ;#.(%null-ptr) + ))) + +(defun %sql-fetch (hstmt) + (with-error-handling + (:hstmt hstmt) + (SQLFetch hstmt))) + +(defun %new-statement-handle (hdbc) + (with-foreign-object (hstmt-ptr 'sql-handle-ptr) + (with-error-handling + (:hdbc hdbc) + (SQLAllocStmt hdbc hstmt-ptr) + (deref-pointer hstmt-ptr 'sql-handle-ptr)))) + +(defun %sql-get-info (hdbc info-type) + (ecase info-type + ;; those return string + ((#.$SQL_ACCESSIBLE_PROCEDURES + #.$SQL_ACCESSIBLE_TABLES + #.$SQL_COLUMN_ALIAS + #.$SQL_DATA_SOURCE_NAME + #.$SQL_DATA_SOURCE_READ_ONLY + #.$SQL_DBMS_NAME + #.$SQL_DBMS_VER + #.$SQL_DRIVER_NAME + #.$SQL_DRIVER_ODBC_VER + #.$SQL_DRIVER_VER + #.$SQL_EXPRESSIONS_IN_ORDERBY + #.$SQL_IDENTIFIER_QUOTE_CHAR + #.$SQL_KEYWORDS + #.$SQL_LIKE_ESCAPE_CLAUSE + #.$SQL_MAX_ROW_SIZE_INCLUDES_LONG + #.$SQL_MULT_RESULT_SETS + #.$SQL_MULTIPLE_ACTIVE_TXN + #.$SQL_NEED_LONG_DATA_LEN + #.$SQL_ODBC_SQL_OPT_IEF + #.$SQL_ODBC_VER + #.$SQL_ORDER_BY_COLUMNS_IN_SELECT + #.$SQL_OUTER_JOINS + #.$SQL_OWNER_TERM + #.$SQL_PROCEDURE_TERM + #.$SQL_PROCEDURES + #.$SQL_QUALIFIER_NAME_SEPARATOR + #.$SQL_QUALIFIER_TERM + #.$SQL_ROW_UPDATES + #.$SQL_SEARCH_PATTERN_ESCAPE + #.$SQL_SERVER_NAME + #.$SQL_SPECIAL_CHARACTERS + #.$SQL_TABLE_TERM + #.$SQL_USER_NAME) + (with-foreign-objects ((info-ptr '(:array :unsigned-char 1024)) + (info-length-ptr :short)) + (with-error-handling + (:hdbc hdbc) + #-pcl + (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr) + #+pcl + (SQLGetInfo-Str hdbc info-type info-ptr 1023 info-length-ptr) + (convert-from-foreign-string info-ptr)))) + ;; those returning a word + ((#.$SQL_ACTIVE_CONNECTIONS + #.$SQL_ACTIVE_STATEMENTS + #.$SQL_CONCAT_NULL_BEHAVIOR + #.$SQL_CORRELATION_NAME + #.$SQL_CURSOR_COMMIT_BEHAVIOR + #.$SQL_CURSOR_ROLLBACK_BEHAVIOR + #.$SQL_MAX_COLUMN_NAME_LEN + #.$SQL_MAX_COLUMNS_IN_GROUP_BY + #.$SQL_MAX_COLUMNS_IN_INDEX + #.$SQL_MAX_COLUMNS_IN_ORDER_BY + #.$SQL_MAX_COLUMNS_IN_SELECT + #.$SQL_MAX_COLUMNS_IN_TABLE + #.$SQL_MAX_CURSOR_NAME_LEN + #.$SQL_MAX_OWNER_NAME_LEN + #.$SQL_MAX_PROCEDURE_NAME_LEN + #.$SQL_MAX_QUALIFIER_NAME_LEN + #.$SQL_MAX_TABLE_NAME_LEN + #.$SQL_MAX_TABLES_IN_SELECT + #.$SQL_MAX_USER_NAME_LEN + #.$SQL_NON_NULLABLE_COLUMNS + #.$SQL_NULL_COLLATION + #.$SQL_ODBC_API_CONFORMANCE + #.$SQL_ODBC_SAG_CLI_CONFORMANCE + #.$SQL_ODBC_SQL_CONFORMANCE + #.$SQL_QUALIFIER_LOCATION + #.$SQL_QUOTED_IDENTIFIER_CASE + #.$SQL_TXN_CAPABLE) + (with-foreign-objects ((info-ptr :short) + (info-length-ptr :short)) + (with-error-handling + (:hdbc hdbc) + (SQLGetInfo hdbc + info-type + info-ptr + 255 + info-length-ptr) + (deref-pointer info-ptr :short))) + ) + ;; those returning a long bitmask + ((#.$SQL_ALTER_TABLE + #.$SQL_BOOKMARK_PERSISTENCE + #.$SQL_CONVERT_BIGINT + #.$SQL_CONVERT_BINARY + #.$SQL_CONVERT_BIT + #.$SQL_CONVERT_CHAR + #.$SQL_CONVERT_DATE + #.$SQL_CONVERT_DECIMAL + #.$SQL_CONVERT_DOUBLE + #.$SQL_CONVERT_FLOAT + #.$SQL_CONVERT_INTEGER + #.$SQL_CONVERT_LONGVARCHAR + #.$SQL_CONVERT_NUMERIC + #.$SQL_CONVERT_REAL + #.$SQL_CONVERT_SMALLINT + #.$SQL_CONVERT_TIME + #.$SQL_CONVERT_TIMESTAMP + #.$SQL_CONVERT_TINYINT + #.$SQL_CONVERT_VARBINARY + #.$SQL_CONVERT_VARCHAR + #.$SQL_CONVERT_LONGVARBINARY + #.$SQL_CONVERT_FUNCTIONS + #.$SQL_FETCH_DIRECTION + #.$SQL_FILE_USAGE + #.$SQL_GETDATA_EXTENSIONS + #.$SQL_LOCK_TYPES + #.$SQL_MAX_INDEX_SIZE + #.$SQL_MAX_ROW_SIZE + #.$SQL_MAX_STATEMENT_LEN + #.$SQL_NUMERIC_FUNCTIONS + #.$SQL_OWNER_USAGE + #.$SQL_POS_OPERATIONS + #.$SQL_POSITIONED_STATEMENTS + #.$SQL_QUALIFIER_USAGE + #.$SQL_SCROLL_CONCURRENCY + #.$SQL_SCROLL_OPTIONS + #.$SQL_STATIC_SENSITIVITY + #.$SQL_STRING_FUNCTIONS + #.$SQL_SUBQUERIES + #.$SQL_SYSTEM_FUNCTIONS + #.$SQL_TIMEDATE_ADD_INTERVALS + #.$SQL_TIMEDATE_DIFF_INTERVALS + #.$SQL_TIMEDATE_FUNCTIONS + #.$SQL_TXN_ISOLATION_OPTION + #.$SQL_UNION) + (with-foreign-objects ((info-ptr :long) + (info-length-ptr :short)) + (with-error-handling + (:hdbc hdbc) + (SQLGetInfo hdbc + info-type + info-ptr + 255 + info-length-ptr) + (deref-pointer info-ptr :long))) + ) + ;; those returning a long integer + ((#.$SQL_DEFAULT_TXN_ISOLATION + #.$SQL_DRIVER_HDBC + #.$SQL_DRIVER_HENV + #.$SQL_DRIVER_HLIB + #.$SQL_DRIVER_HSTMT + #.$SQL_GROUP_BY + #.$SQL_IDENTIFIER_CASE + #.$SQL_MAX_BINARY_LITERAL_LEN + #.$SQL_MAX_CHAR_LITERAL_LEN + #.$SQL_ACTIVE_ENVIRONMENTS + ) + (with-foreign-objects ((info-ptr :long) + (info-length-ptr :short)) + (with-error-handling + (:hdbc hdbc) + (SQLGetInfo hdbc info-type info-ptr 255 info-length-ptr) + (deref-pointer info-ptr :long)))))) + +(defun %sql-exec-direct (sql hstmt henv hdbc) + (with-cstring (sql-ptr sql) + (with-error-handling + (:hstmt hstmt :henv henv :hdbc hdbc) + (SQLExecDirect hstmt sql-ptr $SQL_NTS)))) + +(defun %sql-cancel (hstmt) + (with-error-handling + (:hstmt hstmt) + (SQLCancel hstmt))) + +(defun %sql-execute (hstmt) + (with-error-handling + (:hstmt hstmt) + (SQLExecute hstmt))) + +(defun result-columns-count (hstmt) + (with-foreign-objects ((columns-nr-ptr :short)) + (with-error-handling (:hstmt hstmt) + (SQLNumResultCols hstmt columns-nr-ptr) + (deref-pointer columns-nr-ptr :short)))) + +(defun result-rows-count (hstmt) + (with-foreign-objects ((row-count-ptr :long)) + (with-error-handling (:hstmt hstmt) + (SQLRowCount hstmt row-count-ptr) + (deref-pointer row-count-ptr :long)))) + +;; column counting is 1-based +(defun %describe-column (hstmt column-nr) + (with-foreign-objects ((column-name-ptr '(:array :unsigned-char 256)) + (column-name-length-ptr :short) + (column-sql-type-ptr :short) + (column-precision-ptr :long) + (column-scale-ptr :short) + (column-nullable-p-ptr :short)) + (with-error-handling (:hstmt hstmt) + (SQLDescribeCol hstmt column-nr column-name-ptr 256 + column-name-length-ptr + column-sql-type-ptr + column-precision-ptr + column-scale-ptr + column-nullable-p-ptr) + (values + (convert-from-foreign-string column-name-ptr) + (deref-pointer column-sql-type-ptr :short) + (deref-pointer column-precision-ptr :long) + (deref-pointer column-scale-ptr :short) + (deref-pointer column-nullable-p-ptr :short))))) + +;; parameter counting is 1-based +(defun %describe-parameter (hstmt parameter-nr) + (with-foreign-objects ((column-sql-type-ptr :short) + (column-precision-ptr :long) + (column-scale-ptr :short) + (column-nullable-p-ptr :short)) + (with-error-handling + (:hstmt hstmt) + (SQLDescribeParam hstmt parameter-nr + column-sql-type-ptr + column-precision-ptr + column-scale-ptr + column-nullable-p-ptr) + (values + (deref-pointer column-sql-type-ptr :short) + (deref-pointer column-precision-ptr :long) + (deref-pointer column-scale-ptr :short) + (deref-pointer column-nullable-p-ptr :short))))) + +(defun %column-attributes (hstmt column-nr descriptor-type) + (with-foreign-objects ((descriptor-info-ptr '(:array :unsigned-char 256)) + (descriptor-length-ptr :short) + (numeric-descriptor-ptr :long)) + (with-error-handling + (:hstmt hstmt) + (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr 256 + descriptor-length-ptr + numeric-descriptor-ptr) + (values + (convert-from-foreign-string descriptor-info-ptr) + (deref-pointer numeric-descriptor-ptr :long))))) + +(defun %prepare-describe-columns (hstmt table-qualifier table-owner + table-name column-name) + (with-cstrings ((table-qualifier-ptr table-qualifier) + (table-owner-ptr table-owner) + (table-name-ptr table-name) + (column-name-ptr column-name)) + (with-error-handling + (:hstmt hstmt) + (SQLColumns hstmt + table-qualifier-ptr (length table-qualifier) + table-owner-ptr (length table-owner) + table-name-ptr (length table-name) + column-name-ptr (length column-name))))) + +(defun %describe-columns (hdbc table-qualifier table-owner + table-name column-name) + (with-statement-handle (hstmt hdbc) + (%prepare-describe-columns hstmt table-qualifier table-owner + table-name column-name) + (fetch-all-rows hstmt))) + +(defun %sql-data-sources (henv &key (direction :first)) + (with-foreign-objects + ((name-ptr '(:array :unsigned-char #.(1+ $SQL_MAX_DSN_LENGTH))) + (name-length-ptr :short) + (description-ptr '(:array :unsigned-char 1024)) + (description-length-ptr :short)) + (let ((res (with-error-handling + (:henv henv) + (SQLDataSources henv + (ecase direction + (:first $SQL_FETCH_FIRST) + (:next $SQL_FETCH_NEXT)) + name-ptr + (1+ $SQL_MAX_DSN_LENGTH) + name-length-ptr + description-ptr + 1024 + description-length-ptr)))) + (unless (= res $SQL_NO_DATA_FOUND) + (values (convert-from-foreign-string name-ptr) + (convert-from-foreign-string description-ptr)))))) + +(defun sql-to-c-type (sql-type) + (ecase sql-type + ((#.$SQL_CHAR #.$SQL_VARCHAR #.$SQL_LONGVARCHAR + #.$SQL_NUMERIC #.$SQL_DECIMAL #.$SQL_BIGINT -8 -9) $SQL_C_CHAR) + (#.$SQL_INTEGER $SQL_C_SLONG) + (#.$SQL_SMALLINT $SQL_C_SSHORT) + ((#.$SQL_FLOAT #.$SQL_DOUBLE) $SQL_C_DOUBLE) + (#.$SQL_REAL $SQL_C_FLOAT) + (#.$SQL_DATE $SQL_C_DATE) + (#.$SQL_TIME $SQL_C_TIME) + (#.$SQL_TIMESTAMP $SQL_C_TIMESTAMP) + ((#.$SQL_BINARY #.$SQL_VARBINARY #.$SQL_LONGVARBINARY) $SQL_C_BINARY) + (#.$SQL_TINYINT $SQL_C_STINYINT) + (#.$SQL_BIT $SQL_C_BIT))) + +(defun get-cast-byte (ptr) + (declare (type long-ptr-type out-len-ptr)) + (with-cast-pointer (casted ptr '(* :byte)) + (deref-pointer casted :byte))) + +(defun get-cast-short (ptr) + (declare (type long-ptr-type out-len-ptr)) + (with-cast-pointer (casted ptr '(* :short)) + (deref-pointer casted :short))) + +(defun get-cast-int (ptr) + (declare (type long-ptr-type out-len-ptr)) + (with-cast-pointer (casted ptr '(* :int)) + (deref-pointer casted :int))) + +(defun get-cast-long (ptr) + (declare (type long-ptr-type out-len-ptr)) + (with-cast-pointer (casted ptr '(* :long)) + (deref-pointer casted :long))) + +(defun get-cast-single-float (ptr) + (declare (type long-ptr-type out-len-ptr)) + (with-cast-pointer (casted ptr '(* :float)) + (deref-pointer casted :float))) + +(defun get-cast-double-float (ptr) + (declare (type long-ptr-type out-len-ptr)) + (with-cast-pointer (casted ptr '(* :double)) + (deref-pointer casted :double))) + +(defun get-cast-foreign-string (ptr) + (declare (type long-ptr-type out-len-ptr)) + (with-cast-pointer (casted ptr '(* :unsigned-char)) + (convert-from-foreign-string casted))) + +(defun get-cast-binary (ptr len format) + "FORMAT is one of :unsigned-byte-vector, :bit-vector (:string, :hex-string)" + (with-cast-pointer (casted ptr '(* :byte)) + (ecase format + (:unsigned-byte-vector + (let ((vector (make-array len :element-type '(unsigned-byte 8)))) + (dotimes (i len) + (setf (aref vector i) + (deref-array casted '(:array :byte) i))) + vector)) + (:bit-vector + (let ((vector (make-array (ash len 3) :element-type 'bit))) + (dotimes (i len) + (let ((byte (deref-array casted '(:array :byte) i))) + (dotimes (j 8) + (setf (bit vector (+ (ash i 3) j)) (logand (ash byte (- j 7)) 1))))) + vector))))) + + +(defun read-data (data-ptr c-type sql-type out-len-ptr convert-to-string-p) + (declare (type long-ptr-type out-len-ptr)) + (let ((out-len (deref-pointer out-len-ptr :long))) + (cond ((= out-len $SQL_NULL_DATA) + *null*) + ;; obsolete? + (convert-to-string-p + (convert-from-foreign-string data-ptr)) + (t + (case sql-type + ;; SQL extended datatypes + (#.$SQL_TINYINT (get-cast-short data-ptr)) + (#.$SQL_C_STINYINT (get-cast-short data-ptr)) ;; ? + (#.$SQL_C_SSHORT (get-cast-short data-ptr)) ;; ? + (#.$SQL_SMALLINT (deref-pointer data-ptr :short)) ; ?? + (#.$SQL_INTEGER (deref-pointer data-ptr :long)) + (#.$SQL_DECIMAL + (let ((*read-base* 10)) + (read-from-string (get-cast-foreign-string data-ptr)))) + (t + (case c-type + (#.$SQL_C_DATE + (funcall *time-conversion-function* (date-to-universal-time data-ptr))) + (#.$SQL_C_TIME + (multiple-value-bind (universal-time frac) (time-to-universal-time data-ptr) + (funcall *time-conversion-function* universal-time frac))) + (#.$SQL_C_TIMESTAMP + (multiple-value-bind (universal-time frac) (timestamp-to-universal-time data-ptr) + (funcall *time-conversion-function* universal-time frac))) + (#.$SQL_INTEGER + (get-cast-int data-ptr)) + (#.$SQL_C_FLOAT + (get-cast-single-float data-ptr)) + (#.$SQL_C_DOUBLE + (get-cast-double-float data-ptr)) + (#.$SQL_C_SLONG + (get-cast-long data-ptr)) + #+lispworks + (#.$SQL_C_BIT ; encountered only in Access + (get-cast-byte data-ptr)) + (#.$SQL_C_BINARY + (get-cast-binary data-ptr out-len *binary-format*)) + ((#.$SQL_C_SSHORT #.$SQL_C_STINYINT) ; LMH short ints + (get-cast-short data-ptr)) ; LMH + #+ignore + (#.$SQL_C_CHAR + (code-char (get-cast-short data-ptr))) + (t + (convert-from-foreign-string data-ptr))))))))) + +;; which value is appropriate? +(defparameter +max-precision+ + #+mcl 512 + #-mcl 4001) + +(defvar *break-on-unknown-data-type* t) + +;; C. Stacy's idea to factor this out +;; "Make it easy to add new datatypes by making new subroutine %ALLOCATE-BINDINGS, +;; so that I don't have to remember to make changes in more than one place. +;; Just keep it in synch with READ-DATA." +(defun %allocate-bindings (sql-type precision) + (let* ((c-type (sql-to-c-type sql-type)) + (size (if (zerop precision) + +max-precision+ ;; if the precision cannot be determined + (min precision +max-precision+))) + (long-p (= size +max-precision+)) + (data-ptr + (case c-type ;; add more? + (#.$SQL_C_SLONG (uffi:allocate-foreign-object :long)) + (#.$SQL_C_DOUBLE (uffi:allocate-foreign-object :double)) + (#.$SQL_C_DATE (allocate-foreign-object 'sql-c-date)) + (#.$SQL_C_TIME (allocate-foreign-object 'sql-c-time)) + (#.$SQL_C_TIMESTAMP (allocate-foreign-object 'sql-c-timestamp)) + #+lispworks(#.$SQL_C_FLOAT (uffi:allocate-foreign-object :float)) + (#.$SQL_C_BIT (uffi:allocate-foreign-object :boolean)) + (#.$SQL_C_STINYINT (uffi:allocate-foreign-object :byte)) + (#.$SQL_C_SSHORT (uffi:allocate-foreign-object :short)) + (#.$SQL_C_CHAR (uffi:allocate-foreign-string (1+ size))) + (#.$SQL_C_BINARY (uffi:allocate-foreign-string (1+ (* 2 size)))) + (t + ;; Maybe should signal a restartable condition for this? + (when *break-on-unknown-data-type* + (break "SQL type is ~A, precision ~D, size ~D, C type is ~A" + sql-type precision size c-type)) + (uffi:allocate-foreign-object :ptr (1+ size))))) + (out-len-ptr (uffi:allocate-foreign-object :long))) + (values c-type data-ptr out-len-ptr size long-p))) + +(defun fetch-all-rows (hstmt &key free-option flatp) + (let ((column-count (result-columns-count hstmt))) + (unless (zerop column-count) + (let ((names (make-array column-count :element-type 'string)) + (sql-types (make-array column-count :element-type 'fixnum)) + (c-types (make-array column-count :element-type 'fixnum)) + (precisions (make-array column-count :element-type 'fixnum)) + (data-ptrs (make-array column-count :initial-element nil)) + (out-len-ptrs (make-array column-count :initial-element nil)) + (scales (make-array column-count :element-type 'fixnum)) + (nullables-p (make-array column-count :element-type 'fixnum))) + (unwind-protect + (values + (progn + (dotimes (col-nr column-count) + ;; get column information + (multiple-value-bind (name sql-type precision scale nullable-p) + (%describe-column hstmt (1+ col-nr)) + ;; allocate space to bind result rows to + (multiple-value-bind (c-type data-ptr out-len-ptr) + (%allocate-bindings sql-type precision) + (%bind-column hstmt col-nr c-type data-ptr (1+ precision) out-len-ptr) + (setf (svref names col-nr) name + (aref sql-types col-nr) sql-type + (aref c-types col-nr) (sql-to-c-type sql-type) + (aref precisions col-nr) (if (zerop precision) nil precision) + (aref scales col-nr) scale + (aref nullables-p col-nr) nullable-p + (aref data-ptrs col-nr) data-ptr + (aref out-len-ptrs col-nr) out-len-ptr)))) + ;; the main loop + (prog1 + (cond (flatp + (when (> column-count 1) + (error "If more than one column is to be fetched, flatp has to be nil.")) + (loop until (= (%sql-fetch hstmt) $SQL_NO_DATA_FOUND) + collect + (read-data (aref data-ptrs 0) + (aref c-types 0) + (aref sql-types 0) + (aref out-len-ptrs 0) + nil))) + (t + (loop until (= (%sql-fetch hstmt) $SQL_NO_DATA_FOUND) + collect + (loop for col-nr from 0 to (1- column-count) + collect + (read-data (aref data-ptrs col-nr) + (aref c-types col-nr) + (aref sql-types col-nr) + (aref out-len-ptrs col-nr) + nil))))))) + names) + ;; dispose of memory etc + (when free-option (%free-statement hstmt free-option)) + (dotimes (col-nr column-count) + (let ((data-ptr (aref data-ptrs col-nr)) + (out-len-ptr (aref out-len-ptrs col-nr))) + (when data-ptr (free-foreign-object data-ptr)) ; we *did* allocate them + (when out-len-ptr (free-foreign-object out-len-ptr))))))))) + +;; to do: factor out common parts, put the sceleton (the obligatory macro part) +;; of %do-fetch into sql package (has been done) + +(defun %sql-prepare (hstmt sql) + (with-cstring (sql-ptr sql) + (with-error-handling (:hstmt hstmt) + (SQLPrepare hstmt sql-ptr $SQL_NTS)))) + +;; depending on option, we return a long int or a string; string not implemented +(defun get-connection-option (hdbc option) + (with-foreign-objects ((param-ptr :long #+ignore #.(1+ $SQL_MAX_OPTION_STRING_LENGTH))) + (with-error-handling (:hdbc hdbc) + (SQLGetConnectOption hdbc option param-ptr) + (deref-pointer param-ptr :long)))) + +(defun set-connection-option (hdbc option param) + (with-error-handling (:hdbc hdbc) + (SQLSetConnectOption hdbc option param))) + +(defun disable-autocommit (hdbc) + (set-connection-option hdbc $SQL_AUTOCOMMIT $SQL_AUTOCOMMIT_OFF)) + +(defun enable-autocommit (hdbc) + (set-connection-option hdbc $SQL_AUTOCOMMIT $SQL_AUTOCOMMIT_ON)) + +(defun %sql-set-pos (hstmt row option lock) + (with-error-handling + (:hstmt hstmt) + (SQLSetPos hstmt row option lock))) + +(defun %sql-extended-fetch (hstmt fetch-type row) + (with-foreign-objects ((row-count-ptr :unsigned-long) + (row-status-ptr :short)) + (with-error-handling (:hstmt hstmt) + (SQLExtendedFetch hstmt fetch-type row row-count-ptr + row-status-ptr) + (values (deref-pointer row-count-ptr :unsigned-long) + (deref-pointer row-status-ptr :short))))) + +; column-nr is zero-based +(defun %sql-get-data (hstmt column-nr c-type data-ptr precision out-len-ptr) + (with-error-handling + (:hstmt hstmt :print-info nil) + (SQLGetData hstmt (if (eq column-nr :bookmark) 0 (1+ column-nr)) + c-type data-ptr precision out-len-ptr))) + +(defun %sql-param-data (hstmt param-ptr) + (with-error-handling (:hstmt hstmt :print-info t) ;; nil + (SQLParamData hstmt param-ptr))) + +(defun %sql-put-data (hstmt data-ptr size) + (with-error-handling + (:hstmt hstmt :print-info t) ;; nil + (SQLPutData hstmt data-ptr size))) + +(defconstant $sql-data-truncated (intern "01004" :keyword)) + +(defun read-data-in-chunks (hstmt column-nr data-ptr c-type sql-type + out-len-ptr convert-to-string-p) + (declare (ignore convert-to-string-p) ; prelimianary + (type long-ptr-type out-len-ptr)) + (let* ((res (%sql-get-data hstmt column-nr c-type data-ptr + +max-precision+ out-len-ptr)) + (out-len (deref-pointer out-len-ptr :long)) + (offset 0)) + (case out-len + (#.$SQL_NULL_DATA + (return-from read-data-in-chunks *null*)) + (#.$SQL_NO_TOTAL ;; don't know how long it is going to be + (let ((str (make-array 0 :element-type 'character :adjustable t))) + (loop do (if (= c-type #.$SQL_CHAR) + (let ((data-length (foreign-string-length data-ptr))) + (adjust-array str (+ offset data-length) + :initial-element #\?) + (setf offset (%cstring-into-vector + data-ptr str + offset + data-length))) + (error "wrong type. preliminary.")) + while (and (= res $SQL_SUCCESS_WITH_INFO) + (equal (sql-state (%null-ptr) (%null-ptr) hstmt) + "01004")) + do (setf res (%sql-get-data hstmt column-nr c-type data-ptr + +max-precision+ out-len-ptr))) + (setf str (coerce str 'string)) + (if (= sql-type $SQL_DECIMAL) + (let ((*read-base* 10)) + (read-from-string str)) + str))) + (otherwise + (let ((str (make-string out-len))) + (loop do (if (= c-type #.$SQL_CHAR) + (setf offset (%cstring-into-vector ;string + data-ptr str + offset + (min out-len (1- +max-precision+)))) + (error "wrong type. preliminary.")) + while + (and (= res $SQL_SUCCESS_WITH_INFO) + #+ingore(eq (sql-state (%null-ptr) (%null-ptr) hstmt) + $sql-data-truncated) + (equal (sql-state (%null-ptr) (%null-ptr) hstmt) + "01004")) + do (setf res (%sql-get-data hstmt column-nr c-type data-ptr + +max-precision+ out-len-ptr) + out-len (deref-pointer out-len-ptr :long))) + (if (= sql-type $SQL_DECIMAL) + (let ((*read-base* 10)) + (read-from-string str)) + str)))))) + +(defun timestamp-to-universal-time (ptr) + (values + (encode-universal-time + (get-slot-value ptr 'sql-c-timestamp 'second) + (get-slot-value ptr 'sql-c-timestamp 'minute) + (get-slot-value ptr 'sql-c-timestamp 'hour) + (get-slot-value ptr 'sql-c-timestamp 'day) + (get-slot-value ptr 'sql-c-timestamp 'month) + (get-slot-value ptr 'sql-c-timestamp 'year)) + (get-slot-value ptr 'sql-c-timestamp 'fraction))) + +(defun universal-time-to-timestamp (time &optional (fraction 0)) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time time) + (with-foreign-object (ptr 'sql-c-timestamp) + (setf (get-slot-value ptr 'sql-c-timestamp 'second) sec + (get-slot-value ptr 'sql-c-timestamp 'minute) min + (get-slot-value ptr 'sql-c-timestamp 'hour) hour + (get-slot-value ptr 'sql-c-timestamp 'day) day + (get-slot-value ptr 'sql-c-timestamp 'month) month + (get-slot-value ptr 'sql-c-timestamp 'year) year + (get-slot-value ptr 'sql-c-timestamp 'fraction) fraction) + ptr))) + +(defun %put-timestamp (ptr time &optional (fraction 0)) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time time) + (setf (get-slot-value ptr 'sql-c-timestamp 'second) sec + (get-slot-value ptr 'sql-c-timestamp 'minute) min + (get-slot-value ptr 'sql-c-timestamp 'hour) hour + (get-slot-value ptr 'sql-c-timestamp 'day) day + (get-slot-value ptr 'sql-c-timestamp 'month) month + (get-slot-value ptr 'sql-c-timestamp 'year) year + (get-slot-value ptr 'sql-c-timestamp 'fraction) fraction) + ptr)) + +(defun date-to-universal-time (ptr) + (encode-universal-time + 0 0 0 + (get-slot-value ptr 'sql-c-timestamp 'day) + (get-slot-value ptr 'sql-c-timestamp 'month) + (get-slot-value ptr 'sql-c-timestamp 'year))) + +(defun time-to-universal-time (ptr) + (encode-universal-time + (get-slot-value ptr 'sql-c-timestamp 'second) + (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-constants.lisp b/db-odbc/odbc-constants.lisp new file mode 100644 index 0000000..91b09c8 --- /dev/null +++ b/db-odbc/odbc-constants.lisp @@ -0,0 +1,950 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: odbc -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: odbc-constants.lisp +;;;; Purpose: Constants for UFFI interface to ODBC +;;;; Authors: Paul Meurer and Kevin M. Rosenberg +;;;; +;;;; $Id: odbc-package.lisp 7061 2003-09-07 06:34:45Z kevin $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004 by Kevin M. Rosenberg +;;;; and Copyright (C) Paul Meurer 1999 - 2001. All rights reserved. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:odbc) + +(defconstant $ODBCVER #x0210) + +;; generally useful constants +(defconstant $SQL_SPEC_MAJOR 2) ;; Major version of specification +(defconstant $SQL_SPEC_MINOR 10) ;; Minor version of specification +(defconstant $SQL_SPEC_STRING "02.10") ;; String constant for version +(defconstant $SQL_SQLSTATE_SIZE 5) ;; size of SQLSTATE +(defconstant $SQL_MAX_MESSAGE_LENGTH 512) ;; message buffer size +(defconstant $SQL_MAX_DSN_LENGTH 32) ;; maximum data source name size + +;; RETCODEs +(defconstant $SQL_INVALID_HANDLE -2) +(defconstant $SQL_ERROR -1) +(defconstant $SQL_SUCCESS 0) +(defconstant $SQL_SUCCESS_WITH_INFO 1) +(defconstant $SQL_NO_DATA_FOUND 100) + +;; Standard SQL datatypes, using ANSI type numbering +(defconstant $SQL_CHAR 1) +(defconstant $SQL_NUMERIC 2) +(defconstant $SQL_DECIMAL 3) +(defconstant $SQL_INTEGER 4) +(defconstant $SQL_SMALLINT 5) +(defconstant $SQL_FLOAT 6) +(defconstant $SQL_REAL 7) +(defconstant $SQL_DOUBLE 8) +(defconstant $SQL_VARCHAR 12) + +(defconstant $SQL_TYPE_MIN $SQL_CHAR) +(defconstant $SQL_TYPE_NULL 0) +(defconstant $SQL_TYPE_MAX $SQL_VARCHAR) + +;; C datatype to SQL datatype mapping SQL types + +(defconstant $SQL_C_CHAR $SQL_CHAR) ;; CHAR, VARCHAR, DECIMAL, NUMERIC +(defconstant $SQL_C_LONG $SQL_INTEGER) ;; INTEGER +(defconstant $SQL_C_SHORT $SQL_SMALLINT) ;; SMALLINT +(defconstant $SQL_C_FLOAT $SQL_REAL) ;; REAL +(defconstant $SQL_C_DOUBLE $SQL_DOUBLE) ;; FLOAT, DOUBLE +(defconstant $SQL_C_DEFAULT 99) + +;; NULL status constants. These are used in SQLColumns, SQLColAttributes, +;;SQLDescribeCol, SQLDescribeParam, and SQLSpecialColumns to describe the +;;nullablity of a column in a table. + +(defconstant $SQL_NO_NULLS 0) +(defconstant $SQL_NULLABLE 1) +(defconstant $SQL_NULLABLE_UNKNOWN 2) + +;; Special length values +(defconstant $SQL_NULL_DATA -1) +(defconstant $SQL_DATA_AT_EXEC -2) +(defconstant $SQL_NTS -3) + +;; SQLFreeStmt defines +(defconstant $SQL_CLOSE 0) +(defconstant $SQL_DROP 1) +(defconstant $SQL_UNBIND 2) +(defconstant $SQL_RESET_PARAMS 3) + +;; SQLTransact defines +(defconstant $SQL_COMMIT 0) +(defconstant $SQL_ROLLBACK 1) + +;; SQLColAttributes defines +(defconstant $SQL_COLUMN_COUNT 0) +(defconstant $SQL_COLUMN_NAME 1) +(defconstant $SQL_COLUMN_TYPE 2) +(defconstant $SQL_COLUMN_LENGTH 3) +(defconstant $SQL_COLUMN_PRECISION 4) +(defconstant $SQL_COLUMN_SCALE 5) +(defconstant $SQL_COLUMN_DISPLAY_SIZE 6) +(defconstant $SQL_COLUMN_NULLABLE 7) +(defconstant $SQL_COLUMN_UNSIGNED 8) +(defconstant $SQL_COLUMN_MONEY 9) +(defconstant $SQL_COLUMN_UPDATABLE 10) +(defconstant $SQL_COLUMN_AUTO_INCREMENT 11) +(defconstant $SQL_COLUMN_CASE_SENSITIVE 12) +(defconstant $SQL_COLUMN_SEARCHABLE 13) +(defconstant $SQL_COLUMN_TYPE_NAME 14) +(defconstant $SQL_COLUMN_TABLE_NAME 15) +(defconstant $SQL_COLUMN_OWNER_NAME 16) +(defconstant $SQL_COLUMN_QUALIFIER_NAME 17) +(defconstant $SQL_COLUMN_LABEL 18) +(defconstant $SQL_COLATT_OPT_MAX $SQL_COLUMN_LABEL) + +(defconstant $SQL_COLUMN_DRIVER_START 1000) + +(defconstant $SQL_COLATT_OPT_MIN $SQL_COLUMN_COUNT) + +;; SQLColAttributes subdefines for SQL_COLUMN_UPDATABLE +(defconstant $SQL_ATTR_READONLY 0) +(defconstant $SQL_ATTR_WRITE 1) +(defconstant $SQL_ATTR_READWRITE_UNKNOWN 2) + +;; SQLColAttributes subdefines for SQL_COLUMN_SEARCHABLE +;; These are also used by SQLGetInfo +(defconstant $SQL_UNSEARCHABLE 0) +(defconstant $SQL_LIKE_ONLY 1) +(defconstant $SQL_ALL_EXCEPT_LIKE 2) +(defconstant $SQL_SEARCHABLE 3) + +;; SQLError defines +(defconstant $SQL_NULL_HENV 0) +(defconstant $SQL_NULL_HDBC 0) +(defconstant $SQL_NULL_HSTMT 0) + +;; Defines for SQLGetFunctions +;; Core Functions +;; +(defconstant $SQL_API_SQLALLOCCONNECT 1) +(defconstant $SQL_API_SQLALLOCENV 2) +(defconstant $SQL_API_SQLALLOCSTMT 3) +(defconstant $SQL_API_SQLBINDCOL 4) +(defconstant $SQL_API_SQLCANCEL 5) +(defconstant $SQL_API_SQLCOLATTRIBUTES 6) +(defconstant $SQL_API_SQLCONNECT 7) +(defconstant $SQL_API_SQLDESCRIBECOL 8) +(defconstant $SQL_API_SQLDISCONNECT 9) +(defconstant $SQL_API_SQLERROR 10) +(defconstant $SQL_API_SQLEXECDIRECT 11) +(defconstant $SQL_API_SQLEXECUTE 12) +(defconstant $SQL_API_SQLFETCH 13) +(defconstant $SQL_API_SQLFREECONNECT 14) +(defconstant $SQL_API_SQLFREEENV 15) +(defconstant $SQL_API_SQLFREESTMT 16) +(defconstant $SQL_API_SQLGETCURSORNAME 17) +(defconstant $SQL_API_SQLNUMRESULTCOLS 18) +(defconstant $SQL_API_SQLPREPARE 19) +(defconstant $SQL_API_SQLROWCOUNT 20) +(defconstant $SQL_API_SQLSETCURSORNAME 21) +(defconstant $SQL_API_SQLSETPARAM 22) +(defconstant $SQL_API_SQLTRANSACT 23) +(defconstant $SQL_NUM_FUNCTIONS 23) +(defconstant $SQL_EXT_API_START 40) + +;; Level 1 Functions + +(defconstant $SQL_API_SQLCOLUMNS 40) +(defconstant $SQL_API_SQLDRIVERCONNECT 41) +(defconstant $SQL_API_SQLGETCONNECTOPTION 42) +(defconstant $SQL_API_SQLGETDATA 43) +(defconstant $SQL_API_SQLGETFUNCTIONS 44) +(defconstant $SQL_API_SQLGETINFO 45) +(defconstant $SQL_API_SQLGETSTMTOPTION 46) +(defconstant $SQL_API_SQLGETTYPEINFO 47) +(defconstant $SQL_API_SQLPARAMDATA 48) +(defconstant $SQL_API_SQLPUTDATA 49) +(defconstant $SQL_API_SQLSETCONNECTOPTION 50) +(defconstant $SQL_API_SQLSETSTMTOPTION 51) +(defconstant $SQL_API_SQLSPECIALCOLUMNS 52) +(defconstant $SQL_API_SQLSTATISTICS 53) +(defconstant $SQL_API_SQLTABLES 54) + +;; Level 2 Functions + +(defconstant $SQL_API_SQLBROWSECONNECT 55) +(defconstant $SQL_API_SQLCOLUMNPRIVILEGES 56) +(defconstant $SQL_API_SQLDATASOURCES 57) +(defconstant $SQL_API_SQLDESCRIBEPARAM 58) +(defconstant $SQL_API_SQLEXTENDEDFETCH 59) +(defconstant $SQL_API_SQLFOREIGNKEYS 60) +(defconstant $SQL_API_SQLMORERESULTS 61) +(defconstant $SQL_API_SQLNATIVESQL 62) +(defconstant $SQL_API_SQLNUMPARAMS 63) +(defconstant $SQL_API_SQLPARAMOPTIONS 64) +(defconstant $SQL_API_SQLPRIMARYKEYS 65) +(defconstant $SQL_API_SQLPROCEDURECOLUMNS 66) +(defconstant $SQL_API_SQLPROCEDURES 67) +(defconstant $SQL_API_SQLSETPOS 68) +(defconstant $SQL_API_SQLSETSCROLLOPTIONS 69) +(defconstant $SQL_API_SQLTABLEPRIVILEGES 70) + +;/* SDK 2.0 Additions */ +(defconstant $SQL_API_SQLDRIVERS 71) +(defconstant $SQL_API_SQLBINDPARAMETER 72) +(defconstant $SQL_EXT_API_LAST $SQL_API_SQLBINDPARAMETER) + +(defconstant $SQL_API_ALL_FUNCTIONS 0) + +(defconstant $SQL_NUM_EXTENSIONS (- $SQL_EXT_API_LAST $SQL_EXT_API_START -1)) +(defconstant $SQL_API_LOADBYORDINAL 199) + +;;; Defines for SQLGetInfo +(defconstant $SQL_INFO_FIRST 0) +(defconstant $SQL_ACTIVE_CONNECTIONS 0) +(defconstant $SQL_ACTIVE_STATEMENTS 1) +(defconstant $SQL_DATA_SOURCE_NAME 2) +(defconstant $SQL_DRIVER_HDBC 3) +(defconstant $SQL_DRIVER_HENV 4) +(defconstant $SQL_DRIVER_HSTMT 5) +(defconstant $SQL_DRIVER_NAME 6) +(defconstant $SQL_DRIVER_VER 7) +(defconstant $SQL_FETCH_DIRECTION 8) +(defconstant $SQL_ODBC_API_CONFORMANCE 9) +(defconstant $SQL_ODBC_VER 10) +(defconstant $SQL_ROW_UPDATES 11) +(defconstant $SQL_ODBC_SAG_CLI_CONFORMANCE 12) +(defconstant $SQL_SERVER_NAME 13) +(defconstant $SQL_SEARCH_PATTERN_ESCAPE 14) +(defconstant $SQL_ODBC_SQL_CONFORMANCE 15) + +(defconstant $SQL_DBMS_NAME 17) +(defconstant $SQL_DBMS_VER 18) + +(defconstant $SQL_ACCESSIBLE_TABLES 19) +(defconstant $SQL_ACCESSIBLE_PROCEDURES 20) +(defconstant $SQL_PROCEDURES 21) +(defconstant $SQL_CONCAT_NULL_BEHAVIOR 22) +(defconstant $SQL_CURSOR_COMMIT_BEHAVIOR 23) +(defconstant $SQL_CURSOR_ROLLBACK_BEHAVIOR 24) +(defconstant $SQL_DATA_SOURCE_READ_ONLY 25) +(defconstant $SQL_DEFAULT_TXN_ISOLATION 26) +(defconstant $SQL_EXPRESSIONS_IN_ORDERBY 27) +(defconstant $SQL_IDENTIFIER_CASE 28) +(defconstant $SQL_IDENTIFIER_QUOTE_CHAR 29) +(defconstant $SQL_MAX_COLUMN_NAME_LEN 30) +(defconstant $SQL_MAX_CURSOR_NAME_LEN 31) +(defconstant $SQL_MAX_OWNER_NAME_LEN 32) +(defconstant $SQL_MAX_PROCEDURE_NAME_LEN 33) +(defconstant $SQL_MAX_QUALIFIER_NAME_LEN 34) +(defconstant $SQL_MAX_TABLE_NAME_LEN 35) +(defconstant $SQL_MULT_RESULT_SETS 36) +(defconstant $SQL_MULTIPLE_ACTIVE_TXN 37) +(defconstant $SQL_OUTER_JOINS 38) +(defconstant $SQL_OWNER_TERM 39) +(defconstant $SQL_PROCEDURE_TERM 40) +(defconstant $SQL_QUALIFIER_NAME_SEPARATOR 41) +(defconstant $SQL_QUALIFIER_TERM 42) +(defconstant $SQL_SCROLL_CONCURRENCY 43) +(defconstant $SQL_SCROLL_OPTIONS 44) +(defconstant $SQL_TABLE_TERM 45) +(defconstant $SQL_TXN_CAPABLE 46) +(defconstant $SQL_USER_NAME 47) + +(defconstant $SQL_CONVERT_FUNCTIONS 48) +(defconstant $SQL_NUMERIC_FUNCTIONS 49) +(defconstant $SQL_STRING_FUNCTIONS 50) +(defconstant $SQL_SYSTEM_FUNCTIONS 51) +(defconstant $SQL_TIMEDATE_FUNCTIONS 52) + +(defconstant $SQL_CONVERT_BIGINT 53) +(defconstant $SQL_CONVERT_BINARY 54) +(defconstant $SQL_CONVERT_BIT 55) +(defconstant $SQL_CONVERT_CHAR 56) +(defconstant $SQL_CONVERT_DATE 57) +(defconstant $SQL_CONVERT_DECIMAL 58) +(defconstant $SQL_CONVERT_DOUBLE 59) +(defconstant $SQL_CONVERT_FLOAT 60) +(defconstant $SQL_CONVERT_INTEGER 61) +(defconstant $SQL_CONVERT_LONGVARCHAR 62) +(defconstant $SQL_CONVERT_NUMERIC 63) +(defconstant $SQL_CONVERT_REAL 64) +(defconstant $SQL_CONVERT_SMALLINT 65) +(defconstant $SQL_CONVERT_TIME 66) +(defconstant $SQL_CONVERT_TIMESTAMP 67) +(defconstant $SQL_CONVERT_TINYINT 68) +(defconstant $SQL_CONVERT_VARBINARY 69) +(defconstant $SQL_CONVERT_VARCHAR 70) +(defconstant $SQL_CONVERT_LONGVARBINARY 71) + +(defconstant $SQL_TXN_ISOLATION_OPTION 72) +(defconstant $SQL_ODBC_SQL_OPT_IEF 73) + +;;; ODBC SDK 1.0 Additions +(defconstant $SQL_CORRELATION_NAME 74) +(defconstant $SQL_NON_NULLABLE_COLUMNS 75) + +;;; ODBC SDK 2.0 Additions +(defconstant $SQL_DRIVER_HLIB 76) +(defconstant $SQL_DRIVER_ODBC_VER 77) +(defconstant $SQL_LOCK_TYPES 78) +(defconstant $SQL_POS_OPERATIONS 79) +(defconstant $SQL_POSITIONED_STATEMENTS 80) +(defconstant $SQL_GETDATA_EXTENSIONS 81) +(defconstant $SQL_BOOKMARK_PERSISTENCE 82) +(defconstant $SQL_STATIC_SENSITIVITY 83) +(defconstant $SQL_FILE_USAGE 84) +(defconstant $SQL_NULL_COLLATION 85) +(defconstant $SQL_ALTER_TABLE 86) +(defconstant $SQL_COLUMN_ALIAS 87) +(defconstant $SQL_GROUP_BY 88) +(defconstant $SQL_KEYWORDS 89) +(defconstant $SQL_ORDER_BY_COLUMNS_IN_SELECT 90) +(defconstant $SQL_OWNER_USAGE 91) +(defconstant $SQL_QUALIFIER_USAGE 92) +(defconstant $SQL_QUOTED_IDENTIFIER_CASE 93) +(defconstant $SQL_SPECIAL_CHARACTERS 94) +(defconstant $SQL_SUBQUERIES 95) +(defconstant $SQL_UNION 96) +(defconstant $SQL_MAX_COLUMNS_IN_GROUP_BY 97) +(defconstant $SQL_MAX_COLUMNS_IN_INDEX 98) +(defconstant $SQL_MAX_COLUMNS_IN_ORDER_BY 99) +(defconstant $SQL_MAX_COLUMNS_IN_SELECT 100) +(defconstant $SQL_MAX_COLUMNS_IN_TABLE 101) +(defconstant $SQL_MAX_INDEX_SIZE 102) +(defconstant $SQL_MAX_ROW_SIZE_INCLUDES_LONG 103) +(defconstant $SQL_MAX_ROW_SIZE 104) +(defconstant $SQL_MAX_STATEMENT_LEN 105) +(defconstant $SQL_MAX_TABLES_IN_SELECT 106) +(defconstant $SQL_MAX_USER_NAME_LEN 107) +(defconstant $SQL_MAX_CHAR_LITERAL_LEN 108) +(defconstant $SQL_TIMEDATE_ADD_INTERVALS 109) +(defconstant $SQL_TIMEDATE_DIFF_INTERVALS 110) +(defconstant $SQL_NEED_LONG_DATA_LEN 111) +(defconstant $SQL_MAX_BINARY_LITERAL_LEN 112) +(defconstant $SQL_LIKE_ESCAPE_CLAUSE 113) +(defconstant $SQL_QUALIFIER_LOCATION 114) +(defconstant $SQL_ACTIVE_ENVIRONMENTS 116) + +#| + +/*** ODBC SDK 2.01 Additions ***/) +(defconstant $SQL_OJ_CAPABILITIES 65003 ;; Temp value until ODBC 3.0 + +(defconstant $SQL_INFO_LAST SQL_QUALIFIER_LOCATION +) +(defconstant $SQL_INFO_DRIVER_START 1000 + +;; SQL_CONVERT_* return value bitmasks +) +(defconstant $SQL_CVT_CHAR #x00000001L) +(defconstant $SQL_CVT_NUMERIC #x00000002L) +(defconstant $SQL_CVT_DECIMAL #x00000004L) +(defconstant $SQL_CVT_INTEGER #x00000008L) +(defconstant $SQL_CVT_SMALLINT #x00000010L) +(defconstant $SQL_CVT_FLOAT #x00000020L) +(defconstant $SQL_CVT_REAL #x00000040L) +(defconstant $SQL_CVT_DOUBLE #x00000080L) +(defconstant $SQL_CVT_VARCHAR #x00000100L) +(defconstant $SQL_CVT_LONGVARCHAR #x00000200L) +(defconstant $SQL_CVT_BINARY #x00000400L) +(defconstant $SQL_CVT_VARBINARY #x00000800L) +(defconstant $SQL_CVT_BIT #x00001000L) +(defconstant $SQL_CVT_TINYINT #x00002000L) +(defconstant $SQL_CVT_BIGINT #x00004000L) +(defconstant $SQL_CVT_DATE #x00008000L) +(defconstant $SQL_CVT_TIME #x00010000L) +(defconstant $SQL_CVT_TIMESTAMP #x00020000L) +(defconstant $SQL_CVT_LONGVARBINARY #x00040000L) + +;; SQL_CONVERT_FUNCTIONS functions) +(defconstant $SQL_FN_CVT_CONVERT #x00000001L) + +;; SQL_STRING_FUNCTIONS functions + +(defconstant $SQL_FN_STR_CONCAT #x00000001L) +(defconstant $SQL_FN_STR_INSERT #x00000002L) +(defconstant $SQL_FN_STR_LEFT #x00000004L) +(defconstant $SQL_FN_STR_LTRIM #x00000008L) +(defconstant $SQL_FN_STR_LENGTH #x00000010L) +(defconstant $SQL_FN_STR_LOCATE #x00000020L) +(defconstant $SQL_FN_STR_LCASE #x00000040L) +(defconstant $SQL_FN_STR_REPEAT #x00000080L) +(defconstant $SQL_FN_STR_REPLACE #x00000100L) +(defconstant $SQL_FN_STR_RIGHT #x00000200L) +(defconstant $SQL_FN_STR_RTRIM #x00000400L) +(defconstant $SQL_FN_STR_SUBSTRING #x00000800L) +(defconstant $SQL_FN_STR_UCASE #x00001000L) +(defconstant $SQL_FN_STR_ASCII #x00002000L) +(defconstant $SQL_FN_STR_CHAR #x00004000L +(defconstant $SQL_FN_STR_DIFFERENCE #x00008000L) +(defconstant $SQL_FN_STR_LOCATE_2 #x00010000L) +(defconstant $SQL_FN_STR_SOUNDEX #x00020000L) +(defconstant $SQL_FN_STR_SPACE #x00040000L + +;; SQL_NUMERIC_FUNCTIONS functions +) +(defconstant $SQL_FN_NUM_ABS #x00000001L) +(defconstant $SQL_FN_NUM_ACOS #x00000002L) +(defconstant $SQL_FN_NUM_ASIN #x00000004L) +(defconstant $SQL_FN_NUM_ATAN #x00000008L) +(defconstant $SQL_FN_NUM_ATAN2 #x00000010L) +(defconstant $SQL_FN_NUM_CEILING #x00000020L) +(defconstant $SQL_FN_NUM_COS #x00000040L) +(defconstant $SQL_FN_NUM_COT #x00000080L) +(defconstant $SQL_FN_NUM_EXP #x00000100L) +(defconstant $SQL_FN_NUM_FLOOR #x00000200L) +(defconstant $SQL_FN_NUM_LOG #x00000400L) +(defconstant $SQL_FN_NUM_MOD #x00000800L) +(defconstant $SQL_FN_NUM_SIGN #x00001000L) +(defconstant $SQL_FN_NUM_SIN #x00002000L) +(defconstant $SQL_FN_NUM_SQRT #x00004000L) +(defconstant $SQL_FN_NUM_TAN #x00008000L) +(defconstant $SQL_FN_NUM_PI #x00010000L) +(defconstant $SQL_FN_NUM_RAND #x00020000L +(defconstant $SQL_FN_NUM_DEGREES #x00040000L) +(defconstant $SQL_FN_NUM_LOG10 #x00080000L) +(defconstant $SQL_FN_NUM_POWER #x00100000L) +(defconstant $SQL_FN_NUM_RADIANS #x00200000L) +(defconstant $SQL_FN_NUM_ROUND #x00400000L) +(defconstant $SQL_FN_NUM_TRUNCATE #x00800000L + +;; SQL_TIMEDATE_FUNCTIONS functions +) +(defconstant $SQL_FN_TD_NOW #x00000001L) +(defconstant $SQL_FN_TD_CURDATE #x00000002L) +(defconstant $SQL_FN_TD_DAYOFMONTH #x00000004L) +(defconstant $SQL_FN_TD_DAYOFWEEK #x00000008L) +(defconstant $SQL_FN_TD_DAYOFYEAR #x00000010L) +(defconstant $SQL_FN_TD_MONTH #x00000020L) +(defconstant $SQL_FN_TD_QUARTER #x00000040L) +(defconstant $SQL_FN_TD_WEEK #x00000080L) +(defconstant $SQL_FN_TD_YEAR #x00000100L) +(defconstant $SQL_FN_TD_CURTIME #x00000200L) +(defconstant $SQL_FN_TD_HOUR #x00000400L) +(defconstant $SQL_FN_TD_MINUTE #x00000800L) +(defconstant $SQL_FN_TD_SECOND #x00001000L +(defconstant $SQL_FN_TD_TIMESTAMPADD #x00002000L) +(defconstant $SQL_FN_TD_TIMESTAMPDIFF #x00004000L) +(defconstant $SQL_FN_TD_DAYNAME #x00008000L) +(defconstant $SQL_FN_TD_MONTHNAME #x00010000L + +;; SQL_SYSTEM_FUNCTIONS functions +) +(defconstant $SQL_FN_SYS_USERNAME #x00000001L) +(defconstant $SQL_FN_SYS_DBNAME #x00000002L) +(defconstant $SQL_FN_SYS_IFNULL #x00000004L + +;; SQL_TIMEDATE_ADD_INTERVALS and SQL_TIMEDATE_DIFF_INTERVALS functions + +(defconstant $SQL_FN_TSI_FRAC_SECOND #x00000001L) +(defconstant $SQL_FN_TSI_SECOND #x00000002L) +(defconstant $SQL_FN_TSI_MINUTE #x00000004L) +(defconstant $SQL_FN_TSI_HOUR #x00000008L) +(defconstant $SQL_FN_TSI_DAY #x00000010L) +(defconstant $SQL_FN_TSI_WEEK #x00000020L) +(defconstant $SQL_FN_TSI_MONTH #x00000040L) +(defconstant $SQL_FN_TSI_QUARTER #x00000080L) +(defconstant $SQL_FN_TSI_YEAR #x00000100L + +;; SQL_ODBC_API_CONFORMANCE values +) +(defconstant $SQL_OAC_NONE #x0000) +(defconstant $SQL_OAC_LEVEL1 #x0001) +(defconstant $SQL_OAC_LEVEL2 #x0002 + +;; SQL_ODBC_SAG_CLI_CONFORMANCE values +) +(defconstant $SQL_OSCC_NOT_COMPLIANT #x0000) +(defconstant $SQL_OSCC_COMPLIANT #x0001 + +;; SQL_ODBC_SQL_CONFORMANCE values +) +(defconstant $SQL_OSC_MINIMUM #x0000) +(defconstant $SQL_OSC_CORE #x0001) +(defconstant $SQL_OSC_EXTENDED #x0002 + +;; SQL_CONCAT_NULL_BEHAVIOR values +) +(defconstant $SQL_CB_NULL #x0000) +(defconstant $SQL_CB_NON_NULL #x0001 + +;; SQL_CURSOR_COMMIT_BEHAVIOR and SQL_CURSOR_ROLLBACK_BEHAVIOR values +) +(defconstant $SQL_CB_DELETE #x0000) +(defconstant $SQL_CB_CLOSE #x0001) +(defconstant $SQL_CB_PRESERVE #x0002 + +;; SQL_IDENTIFIER_CASE values +) +(defconstant $SQL_IC_UPPER #x0001) +(defconstant $SQL_IC_LOWER #x0002) +(defconstant $SQL_IC_SENSITIVE #x0003) +(defconstant $SQL_IC_MIXED #x0004 + +;; SQL_TXN_CAPABLE values +|# + +(defconstant $SQL_TC_NONE 0) +(defconstant $SQL_TC_DML 1) +(defconstant $SQL_TC_ALL 2) + +(defconstant $SQL_TC_DDL_COMMIT 3) +(defconstant $SQL_TC_DDL_IGNORE 4) + +;; SQL_SCROLL_OPTIONS masks + + +(defconstant $SQL_SO_FORWARD_ONLY #x00000001) +(defconstant $SQL_SO_KEYSET_DRIVEN #x00000002) +(defconstant $SQL_SO_DYNAMIC #x00000004) +(defconstant $SQL_SO_MIXED #x00000008) +(defconstant $SQL_SO_STATIC #x00000010) + +;; SQL_SCROLL_CONCURRENCY masks + +(defconstant $SQL_SCCO_READ_ONLY #x00000001) +(defconstant $SQL_SCCO_LOCK #x00000002) +(defconstant $SQL_SCCO_OPT_ROWVER #x00000004) +(defconstant $SQL_SCCO_OPT_VALUES #x00000008) + +;; SQL_FETCH_DIRECTION masks + +(defconstant $SQL_FD_FETCH_NEXT #x00000001) +(defconstant $SQL_FD_FETCH_FIRST #x00000002) +(defconstant $SQL_FD_FETCH_LAST #x00000004) +(defconstant $SQL_FD_FETCH_PRIOR #x00000008) +(defconstant $SQL_FD_FETCH_ABSOLUTE #x00000010) +(defconstant $SQL_FD_FETCH_RELATIVE #x00000020) +(defconstant $SQL_FD_FETCH_RESUME #x00000040) +(defconstant $SQL_FD_FETCH_BOOKMARK #x00000080) + +#| +;; SQL_TXN_ISOLATION_OPTION masks +) +(defconstant $SQL_TXN_READ_UNCOMMITTED #x00000001L) +(defconstant $SQL_TXN_READ_COMMITTED #x00000002L) +(defconstant $SQL_TXN_REPEATABLE_READ #x00000004L) +(defconstant $SQL_TXN_SERIALIZABLE #x00000008L) +(defconstant $SQL_TXN_VERSIONING #x00000010L + +;; SQL_CORRELATION_NAME values +) +(defconstant $SQL_CN_NONE #x0000) +(defconstant $SQL_CN_DIFFERENT #x0001) +(defconstant $SQL_CN_ANY #x0002 + +;; SQL_NON_NULLABLE_COLUMNS values +) +(defconstant $SQL_NNC_NULL #x0000) +(defconstant $SQL_NNC_NON_NULL #x0001 + +;; SQL_NULL_COLLATION values + ) +(defconstant $SQL_NC_HIGH #x0000) +(defconstant $SQL_NC_LOW #x0001) +(defconstant $SQL_NC_START #x0002) +(defconstant $SQL_NC_END #x0004 + +;; SQL_FILE_USAGE values +) +(defconstant $SQL_FILE_NOT_SUPPORTED #x0000) +(defconstant $SQL_FILE_TABLE #x0001) +(defconstant $SQL_FILE_QUALIFIER #x0002 + +;; SQL_GETDATA_EXTENSIONS values +) +(defconstant $SQL_GD_ANY_COLUMN #x00000001L) +(defconstant $SQL_GD_ANY_ORDER #x00000002L) +(defconstant $SQL_GD_BLOCK #x00000004L) +(defconstant $SQL_GD_BOUND #x00000008L + +;; SQL_ALTER_TABLE values +) +(defconstant $SQL_AT_ADD_COLUMN #x00000001L) +(defconstant $SQL_AT_DROP_COLUMN #x00000002L + +;; SQL_POSITIONED_STATEMENTS masks +) +(defconstant $SQL_PS_POSITIONED_DELETE #x00000001L) +(defconstant $SQL_PS_POSITIONED_UPDATE #x00000002L) +(defconstant $SQL_PS_SELECT_FOR_UPDATE #x00000004L + +;; SQL_GROUP_BY values +) +(defconstant $SQL_GB_NOT_SUPPORTED #x0000) +(defconstant $SQL_GB_GROUP_BY_EQUALS_SELECT #x0001) +(defconstant $SQL_GB_GROUP_BY_CONTAINS_SELECT #x0002) +(defconstant $SQL_GB_NO_RELATION #x0003 + +;; SQL_OWNER_USAGE masks +) +(defconstant $SQL_OU_DML_STATEMENTS #x00000001L) +(defconstant $SQL_OU_PROCEDURE_INVOCATION #x00000002L) +(defconstant $SQL_OU_TABLE_DEFINITION #x00000004L) +(defconstant $SQL_OU_INDEX_DEFINITION #x00000008L) +(defconstant $SQL_OU_PRIVILEGE_DEFINITION #x00000010L + +;; SQL_QUALIFIER_USAGE masks +) +(defconstant $SQL_QU_DML_STATEMENTS #x00000001L) +(defconstant $SQL_QU_PROCEDURE_INVOCATION #x00000002L) +(defconstant $SQL_QU_TABLE_DEFINITION #x00000004L) +(defconstant $SQL_QU_INDEX_DEFINITION #x00000008L) +(defconstant $SQL_QU_PRIVILEGE_DEFINITION #x00000010L + +;; SQL_SUBQUERIES masks +) +(defconstant $SQL_SQ_COMPARISON #x00000001L) +(defconstant $SQL_SQ_EXISTS #x00000002L) +(defconstant $SQL_SQ_IN #x00000004L) +(defconstant $SQL_SQ_QUANTIFIED #x00000008L) +(defconstant $SQL_SQ_CORRELATED_SUBQUERIES #x00000010L + +;; SQL_UNION masks +) +(defconstant $SQL_U_UNION #x00000001L) +(defconstant $SQL_U_UNION_ALL #x00000002L + +;; SQL_BOOKMARK_PERSISTENCE values +) +(defconstant $SQL_BP_CLOSE #x00000001L) +(defconstant $SQL_BP_DELETE #x00000002L) +(defconstant $SQL_BP_DROP #x00000004L) +(defconstant $SQL_BP_TRANSACTION #x00000008L) +(defconstant $SQL_BP_UPDATE #x00000010L) +(defconstant $SQL_BP_OTHER_HSTMT #x00000020L) +(defconstant $SQL_BP_SCROLL #x00000040L + +;; SQL_STATIC_SENSITIVITY values +) +(defconstant $SQL_SS_ADDITIONS #x00000001L) +(defconstant $SQL_SS_DELETIONS #x00000002L) +(defconstant $SQL_SS_UPDATES #x00000004L + +;; SQL_LOCK_TYPESL masks +) +(defconstant $SQL_LCK_NO_CHANGE #x00000001L) +(defconstant $SQL_LCK_EXCLUSIVE #x00000002L) +(defconstant $SQL_LCK_UNLOCK #x00000004L + +;; SQL_POS_OPERATIONS masks +|# + +(defconstant $SQL_POS_POSITION 1) ;; #x00000001L +(defconstant $SQL_POS_REFRESH 2) ;; #x00000002L +(defconstant $SQL_POS_UPDATE 4) ;; #x00000004L +(defconstant $SQL_POS_DELETE 8) ;; #x00000008L +(defconstant $SQL_POS_ADD 16) ;; #x00000010L + +#| +;; SQL_QUALIFIER_LOCATION values +) +(defconstant $SQL_QL_START #x0001L) +(defconstant $SQL_QL_END #x0002L + +;; SQL_OJ_CAPABILITIES values + +(defconstant $SQL_OJ_LEFT #x00000001L) +(defconstant $SQL_OJ_RIGHT #x00000002L) +(defconstant $SQL_OJ_FULL #x00000004L) +(defconstant $SQL_OJ_NESTED #x00000008L) +(defconstant $SQL_OJ_NOT_ORDERED #x00000010L) +(defconstant $SQL_OJ_INNER #x00000020L) +(defconstant $SQL_OJ_ALL_COMPARISON_OPS #x00000040L + +;; options for SQLGetStmtOption/SQLSetStmtOption) +(defconstant $SQL_QUERY_TIMEOUT 0) +(defconstant $SQL_MAX_ROWS 1) +(defconstant $SQL_NOSCAN 2) +(defconstant $SQL_MAX_LENGTH 3) +(defconstant $SQL_ASYNC_ENABLE 4) +(defconstant $SQL_BIND_TYPE 5 +(defconstant $SQL_CURSOR_TYPE 6) +(defconstant $SQL_CONCURRENCY 7) +(defconstant $SQL_KEYSET_SIZE 8) +(defconstant $SQL_ROWSET_SIZE 9) +(defconstant $SQL_SIMULATE_CURSOR 10) +(defconstant $SQL_RETRIEVE_DATA 11) +(defconstant $SQL_USE_BOOKMARKS 12) +(defconstant $SQL_GET_BOOKMARK 13 /* GetStmtOption Only) +(defconstant $SQL_ROW_NUMBER 14 /* GetStmtOption Only) +; #if (ODBCVER >= #x0200)) +(defconstant $SQL_STMT_OPT_MAX SQL_ROW_NUMBER +;; #else) +(defconstant $SQL_STMT_OPT_MAX SQL_BIND_TYPE +;; #endif ;; ODBCVER >= #x0200 +) +(defconstant $SQL_STMT_OPT_MIN SQL_QUERY_TIMEOUT + + +;; SQL_QUERY_TIMEOUT options) +(defconstant $SQL_QUERY_TIMEOUT_DEFAULT 0UL + +;; SQL_MAX_ROWS options) +(defconstant $SQL_MAX_ROWS_DEFAULT 0UL + +;; SQL_NOSCAN options) +(defconstant $SQL_NOSCAN_OFF 0UL /* 1.0 FALSE) +(defconstant $SQL_NOSCAN_ON 1UL /* 1.0 TRUE) +(defconstant $SQL_NOSCAN_DEFAULT SQL_NOSCAN_OFF + +;; SQL_MAX_LENGTH options) +(defconstant $SQL_MAX_LENGTH_DEFAULT 0UL + +;; SQL_ASYNC_ENABLE options) +(defconstant $SQL_ASYNC_ENABLE_OFF 0UL) +(defconstant $SQL_ASYNC_ENABLE_ON 1UL) +(defconstant $SQL_ASYNC_ENABLE_DEFAULT SQL_ASYNC_ENABLE_OFF + +;; SQL_BIND_TYPE options) +(defconstant $SQL_BIND_BY_COLUMN 0UL) +(defconstant $SQL_BIND_TYPE_DEFAULT SQL_BIND_BY_COLUMN ;; Default value + +;; SQL_CONCURRENCY options) +(defconstant $SQL_CONCUR_READ_ONLY 1) +(defconstant $SQL_CONCUR_LOCK 2) +(defconstant $SQL_CONCUR_ROWVER 3) +(defconstant $SQL_CONCUR_VALUES 4) +(defconstant $SQL_CONCUR_DEFAULT SQL_CONCUR_READ_ONLY ;; Default value + +;; SQL_CURSOR_TYPE options) +(defconstant $SQL_CURSOR_FORWARD_ONLY 0UL) +(defconstant $SQL_CURSOR_KEYSET_DRIVEN 1UL) +(defconstant $SQL_CURSOR_DYNAMIC 2UL) +(defconstant $SQL_CURSOR_STATIC 3UL) +(defconstant $SQL_CURSOR_TYPE_DEFAULT SQL_CURSOR_FORWARD_ONLY ;; Default value + +;; SQL_ROWSET_SIZE options) +(defconstant $SQL_ROWSET_SIZE_DEFAULT 1UL + +;; SQL_KEYSET_SIZE options) +(defconstant $SQL_KEYSET_SIZE_DEFAULT 0UL + +;; SQL_SIMULATE_CURSOR options) +(defconstant $SQL_SC_NON_UNIQUE 0UL) +(defconstant $SQL_SC_TRY_UNIQUE 1UL) +(defconstant $SQL_SC_UNIQUE 2UL + +;; SQL_RETRIEVE_DATA options) +(defconstant $SQL_RD_OFF 0UL) +(defconstant $SQL_RD_ON 1UL) +(defconstant $SQL_RD_DEFAULT SQL_RD_ON + +;; SQL_USE_BOOKMARKS options) +(defconstant $SQL_UB_OFF 0UL) +(defconstant $SQL_UB_ON 1UL) +(defconstant $SQL_UB_DEFAULT SQL_UB_OFF + + +|# + +;; options for SQLSetConnectOption/SQLGetConnectOption) +(defconstant $SQL_ACCESS_MODE 101) +(defconstant $SQL_AUTOCOMMIT 102) +(defconstant $SQL_LOGIN_TIMEOUT 103) +(defconstant $SQL_OPT_TRACE 104) +(defconstant $SQL_OPT_TRACEFILE 105) +(defconstant $SQL_TRANSLATE_DLL 106) +(defconstant $SQL_TRANSLATE_OPTION 107) +(defconstant $SQL_TXN_ISOLATION 108) +(defconstant $SQL_CURRENT_QUALIFIER 109) +(defconstant $SQL_ODBC_CURSORS 110) +(defconstant $SQL_QUIET_MODE 111) +(defconstant $SQL_PACKET_SIZE 112) +(defconstant $SQL_CONN_OPT_MAX $SQL_PACKET_SIZE) +(defconstant $SQL_CONNECT_OPT_DRVR_START 1000) + +;;#define SQL_CONN_OPT_MIN SQL_ACCESS_MODE + +;; SQL_ACCESS_MODE options +(defconstant $SQL_MODE_READ_WRITE 0) ; 0UL +(defconstant $SQL_MODE_READ_ONLY 1) ; 1UL +(defconstant $SQL_MODE_DEFAULT $SQL_MODE_READ_WRITE) + +;; SQL_AUTOCOMMIT options) +(defconstant $SQL_AUTOCOMMIT_OFF 0) ;0UL +(defconstant $SQL_AUTOCOMMIT_ON 1) ;1UL +(defconstant $SQL_AUTOCOMMIT_DEFAULT $SQL_AUTOCOMMIT_ON) + +;; SQL_LOGIN_TIMEOUT options) +(defconstant $SQL_LOGIN_TIMEOUT_DEFAULT 15) ; 15UL + +;; SQL_OPT_TRACE options) +(defconstant $SQL_OPT_TRACE_OFF 0) ; 0UL +(defconstant $SQL_OPT_TRACE_ON 1) ; 1UL +(defconstant $SQL_OPT_TRACE_DEFAULT $SQL_OPT_TRACE_OFF) +; #ifndef SQL_OPT_TRACE_FILE_DEFAULT +; (defconstant $SQL_OPT_TRACE_FILE_DEFAULT "\\SQL.LOG" +;; #endif + +(defconstant $SQL_CUR_USE_IF_NEEDED 0) ; 0UL +(defconstant $SQL_CUR_USE_ODBC 1) ; 1UL +(defconstant $SQL_CUR_USE_DRIVER 2) ; 2UL +(defconstant $SQL_CUR_DEFAULT $SQL_CUR_USE_DRIVER) + +#| +;; Column types and scopes in SQLSpecialColumns. ) +(defconstant $SQL_BEST_ROWID 1) +(defconstant $SQL_ROWVER 2) +) +(defconstant $SQL_SCOPE_CURROW 0) +(defconstant $SQL_SCOPE_TRANSACTION 1) +(defconstant $SQL_SCOPE_SESSION 2 + +;; Defines for SQLSetPos) +(defconstant $SQL_ENTIRE_ROWSET 0 +|# + +;; Operations in SQLSetPos + +(defconstant $SQL_POSITION 0) ;; 1.0 FALSE +(defconstant $SQL_REFRESH 1) ;; 1.0 TRUE +; #if (ODBCVER >= #x0200)) +(defconstant $SQL_UPDATE 2) +(defconstant $SQL_DELETE 3) +(defconstant $SQL_ADD 4) + +;; Lock options in SQLSetPos) +(defconstant $SQL_LOCK_NO_CHANGE 0) ;; 1.0 FALSE +(defconstant $SQL_LOCK_EXCLUSIVE 1) ;; 1.0 TRUE +(defconstant $SQL_LOCK_UNLOCK 2) + +;; SQLBindParameter extensions +(defconstant $SQL_DEFAULT_PARAM -5) +(defconstant $SQL_IGNORE -6) +(defconstant $SQL_LEN_DATA_AT_EXEC_OFFSET -100) +;(defconstant $SQL_LEN_DATA_AT_EXEC(length) (-length+SQL_LEN_DATA_AT_EXEC_OFFSET) + +;; Special return values for SQLGetData +(defconstant $SQL_NO_TOTAL -4) + +#| +;; Macros for SQLSetPos) +(defconstant $SQL_POSITION_TO(hstmt,irow) SQLSetPos(hstmt,irow,SQL_POSITION,SQL_LOCK_NO_CHANGE)) +(defconstant $SQL_LOCK_RECORD(hstmt,irow,fLock) SQLSetPos(hstmt,irow,SQL_POSITION,fLock)) +(defconstant $SQL_REFRESH_RECORD(hstmt,irow,fLock) SQLSetPos(hstmt,irow,SQL_REFRESH,fLock)) +(defconstant $SQL_UPDATE_RECORD(hstmt,irow) SQLSetPos(hstmt,irow,SQL_UPDATE,SQL_LOCK_NO_CHANGE)) +(defconstant $SQL_DELETE_RECORD(hstmt,irow) SQLSetPos(hstmt,irow,SQL_DELETE,SQL_LOCK_NO_CHANGE)) +(defconstant $SQL_ADD_RECORD(hstmt,irow) SQLSetPos(hstmt,irow,SQL_ADD,SQL_LOCK_NO_CHANGE) + +; #ifndef RC_INVOKED + +/* This define is too large for RC) +(defconstant $SQL_ODBC_KEYWORDS \ +"ABSOLUTE,ACTION,ADA,ADD,ALL,ALLOCATE,ALTER,AND,ANY,ARE,AS,"\ +"ASC,ASSERTION,AT,AUTHORIZATION,AVG,"\ +"BEGIN,BETWEEN,BIT,BIT_LENGTH,BOTH,BY,CASCADE,CASCADED,CASE,CAST,CATALOG,"\ +"CHAR,CHAR_LENGTH,CHARACTER,CHARACTER_LENGTH,CHECK,CLOSE,COALESCE,"\ +"COBOL,COLLATE,COLLATION,COLUMN,COMMIT,CONNECT,CONNECTION,CONSTRAINT,"\ +"CONSTRAINTS,CONTINUE,CONVERT,CORRESPONDING,COUNT,CREATE,CROSS,CURRENT,"\ +"CURRENT_DATE,CURRENT_TIME,CURRENT_TIMESTAMP,CURRENT_USER,CURSOR,"\ +"DATE,DAY,DEALLOCATE,DEC,DECIMAL,DECLARE,DEFAULT,DEFERRABLE,"\ +"DEFERRED,DELETE,DESC,DESCRIBE,DESCRIPTOR,DIAGNOSTICS,DISCONNECT,"\ +"DISTINCT,DOMAIN,DOUBLE,DROP,"\ +"ELSE,END,END-EXEC,ESCAPE,EXCEPT,EXCEPTION,EXEC,EXECUTE,"\ +"EXISTS,EXTERNAL,EXTRACT,"\ +"FALSE,FETCH,FIRST,FLOAT,FOR,FOREIGN,FORTRAN,FOUND,FROM,FULL,"\ +"GET,GLOBAL,GO,GOTO,GRANT,GROUP,HAVING,HOUR,"\ +"IDENTITY,IMMEDIATE,IN,INCLUDE,INDEX,INDICATOR,INITIALLY,INNER,"\ +"INPUT,INSENSITIVE,INSERT,INTEGER,INTERSECT,INTERVAL,INTO,IS,ISOLATION,"\ +"JOIN,KEY,LANGUAGE,LAST,LEADING,LEFT,LEVEL,LIKE,LOCAL,LOWER,"\ +"MATCH,MAX,MIN,MINUTE,MODULE,MONTH,MUMPS,"\ +"NAMES,NATIONAL,NATURAL,NCHAR,NEXT,NO,NONE,NOT,NULL,NULLIF,NUMERIC,"\ +"OCTET_LENGTH,OF,ON,ONLY,OPEN,OPTION,OR,ORDER,OUTER,OUTPUT,OVERLAPS,"\ +"PAD,PARTIAL,PASCAL,PLI,POSITION,PRECISION,PREPARE,PRESERVE,"\ +"PRIMARY,PRIOR,PRIVILEGES,PROCEDURE,PUBLIC,"\ +"REFERENCES,RELATIVE,RESTRICT,REVOKE,RIGHT,ROLLBACK,ROWS,"\ +"SCHEMA,SCROLL,SECOND,SECTION,SELECT,SEQUENCE,SESSION,SESSION_USER,SET,SIZE,"\ +"SMALLINT,SOME,SPACE,SQL,SQLCA,SQLCODE,SQLERROR,SQLSTATE,SQLWARNING,"\ +"SUBSTRING,SUM,SYSTEM_USER,"\ +"TABLE,TEMPORARY,THEN,TIME,TIMESTAMP,TIMEZONE_HOUR,TIMEZONE_MINUTE,"\ +"TO,TRAILING,TRANSACTION,TRANSLATE,TRANSLATION,TRIM,TRUE,"\ +"UNION,UNIQUE,UNKNOWN,UPDATE,UPPER,USAGE,USER,USING,"\ +"VALUE,VALUES,VARCHAR,VARYING,VIEW,WHEN,WHENEVER,WHERE,WITH,WORK,YEAR") +|# + +(defconstant $SQL_PARAM_TYPE_UNKNOWN 0) +(defconstant $SQL_PARAM_INPUT 1) +(defconstant $SQL_PARAM_INPUT_OUTPUT 2) +(defconstant $SQL_RESULT_COL 3) +(defconstant $SQL_PARAM_OUTPUT 4) +(defconstant $SQL_RETURN_VALUE 5) + + +;; Defines used by both Level 1 and Level 2 functions + +;; generally useful constants +(defconstant $SQL_MAX_OPTION_STRING_LENGTH 256) + +;; Additional return codes) +(defconstant $SQL_STILL_EXECUTING 2) +(defconstant $SQL_NEED_DATA 99) + +;; SQL extended datatypes) +(defconstant $SQL_DATE 9) +(defconstant $SQL_TIME 10) +(defconstant $SQL_TIMESTAMP 11) +(defconstant $SQL_LONGVARCHAR -1) +(defconstant $SQL_BINARY -2) +(defconstant $SQL_VARBINARY -3) +(defconstant $SQL_LONGVARBINARY -4) +(defconstant $SQL_BIGINT -5) +(defconstant $SQL_TINYINT -6) +(defconstant $SQL_BIT -7) + +(defconstant $SQL_INTERVAL_YEAR -80) +(defconstant $SQL_INTERVAL_MONTH -81) +(defconstant $SQL_INTERVAL_YEAR_TO_MONTH -82) +(defconstant $SQL_INTERVAL_DAY -83) +(defconstant $SQL_INTERVAL_HOUR -84) +(defconstant $SQL_INTERVAL_MINUTE -85) +(defconstant $SQL_INTERVAL_SECOND -86) +(defconstant $SQL_INTERVAL_DAY_TO_HOUR -87) +(defconstant $SQL_INTERVAL_DAY_TO_MINUTE -88) +(defconstant $SQL_INTERVAL_DAY_TO_SECOND -89) +(defconstant $SQL_INTERVAL_HOUR_TO_MINUTE -90) +(defconstant $SQL_INTERVAL_HOUR_TO_SECOND -91) +(defconstant $SQL_INTERVAL_MINUTE_TO_SECOND -92) +(defconstant $SQL_UNICODE -95) +(defconstant $SQL_TYPE_DRIVER_START $SQL_INTERVAL_YEAR) +(defconstant $SQL_TYPE_DRIVER_END $SQL_UNICODE) + + +(defconstant $SQL_SIGNED_OFFSET -20) +(defconstant $SQL_UNSIGNED_OFFSET -22) + +;; C datatype to SQL datatype mapping +(defconstant $SQL_C_DATE $SQL_DATE) +(defconstant $SQL_C_TIME $SQL_TIME) +(defconstant $SQL_C_TIMESTAMP $SQL_TIMESTAMP) +(defconstant $SQL_C_BINARY $SQL_BINARY) +(defconstant $SQL_C_BIT $SQL_BIT) +(defconstant $SQL_C_TINYINT $SQL_TINYINT) +(defconstant $SQL_C_SLONG (+ $SQL_C_LONG $SQL_SIGNED_OFFSET)) ;; SIGNED INTEGER +(defconstant $SQL_C_SSHORT (+ $SQL_C_SHORT $SQL_SIGNED_OFFSET)) ;; SIGNED SMALLINT +(defconstant $SQL_C_STINYINT (+ $SQL_TINYINT $SQL_SIGNED_OFFSET)) ;; SIGNED TINYINT +(defconstant $SQL_C_ULONG (+ $SQL_C_LONG $SQL_UNSIGNED_OFFSET)) ;; UNSIGNED INTEGER +(defconstant $SQL_C_USHORT (+ $SQL_C_SHORT $SQL_UNSIGNED_OFFSET)) ;; UNSIGNED SMALLINT +(defconstant $SQL_C_UTINYINT (+ $SQL_TINYINT $SQL_UNSIGNED_OFFSET)) ;;UNSIGNED TINYINT +(defconstant $SQL_C_BOOKMARK $SQL_C_ULONG) ;; BOOKMARK + +;; Options for SQLDriverConnect +(defconstant $SQL_DRIVER_NOPROMPT 0) +(defconstant $SQL_DRIVER_COMPLETE 1) +(defconstant $SQL_DRIVER_PROMPT 2) +(defconstant $SQL_DRIVER_COMPLETE_REQUIRED 3) + +;; Level 2 Functions + +;; SQLExtendedFetch "fFetchType" values +(defconstant $SQL_FETCH_NEXT 1) +(defconstant $SQL_FETCH_FIRST 2) +(defconstant $SQL_FETCH_LAST 3) +(defconstant $SQL_FETCH_PRIOR 4) +(defconstant $SQL_FETCH_ABSOLUTE 5) +(defconstant $SQL_FETCH_RELATIVE 6) +(defconstant $SQL_FETCH_BOOKMARK 8) + diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp index 6b11714..421b720 100644 --- a/db-odbc/odbc-dbi.lisp +++ b/db-odbc/odbc-dbi.lisp @@ -44,7 +44,7 @@ #:*default-odbc-external-format* #:*null-value* ) - (:documentation "This is the mid-level interface ODBC."))) + (:documentation "This is the mid-level interface ODBC.")) (in-package #:odbc-dbi) @@ -55,10 +55,7 @@ (defun disconnect (conn) (warn "Not implemented.")) -(defun query (expr &key db result-types row-count column-names) - (warn "Not implemented.")) - -(defun execute (expr conn) +(defun sql (expr &key db result-types row-count column-names) (warn "Not implemented.")) (defun close-query (result-set) @@ -66,3 +63,612 @@ (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) + (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))) + +(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)) + (%commit (henv database) (hdbc database))) + +(defmethod db-rollback ((database odbc-database)) + (%rollback (henv database) (hdbc database))) + +(defmethod db-cancel-query ((query odbc-query)) + (with-slots (hstmt) query + (%sql-cancel hstmt) + (setf (query-active-p query) nil))) + +#+simple-version +(defmacro with-transaction (&body body) + `(%with-transaction + (:henv (henv ,*default-database*) :hdbc (hdbc ,*default-database*)) + ,@body)) + +(defmethod initialize-instance :after ((query odbc-query) + &key sql henv hdbc &allow-other-keys) + (when sql + (let ((hstmt (%new-statement-handle hdbc))) + (%sql-exec-direct sql hstmt henv hdbc) + (with-slots (column-count + column-names column-c-types column-sql-types column-data-ptrs + column-out-len-ptrs column-precisions column-scales + column-nullables-p active-p) query + (setf (hstmt query) hstmt) + (%initialize-query query) + (setf active-p t))))) + +;; one for odbc-database is missing +(defmethod terminate ((query odbc-query)) + ;;(format tb::*local-output* "~%*** terminated: ~s" query) + (with-slots (hstmt) query + (when hstmt + ;(%free-statement hstmt :drop) + (uffi:free-foreign-object hstmt)) ;; ?? + (%dispose-column-ptrs query))) + +(defmethod %dispose-column-ptrs ((query odbc-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)) + (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 + &key arglen col-positions + &allow-other-keys) + (db-open-query (get-free-query database) query-expression + :arglen arglen :col-positions col-positions)) + +(defmethod db-open-query ((query odbc-query) query-expression + &key arglen col-positions &allow-other-keys) + (%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 ((query odbc-query) &optional count flatp) + (when (query-active-p query) + (let (#+ignore(no-data nil)) + (with-slots (column-count column-data-ptrs column-c-types column-sql-types + column-out-len-ptrs column-precisions hstmt) + query + (values + (cond (flatp + (when (> column-count 1) + (error "If more than one column is to be fetched, flatp has to be nil.")) + (let ((data-ptr (aref column-data-ptrs 0)) + (c-type (aref column-c-types 0)) + (sql-type (aref column-sql-types 0)) + (out-len-ptr (aref column-out-len-ptrs 0)) + (precision (aref column-precisions 0))) + (loop for i from 0 + until (or (and count (= i count)) + ;;(setf no-data ;; not used??? + (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND)) + collect + (cond ((< 0 precision +max-precision+) + (read-data data-ptr c-type sql-type out-len-ptr nil)) + ((zerop (get-cast-long out-len-ptr)) + nil) + (t + (read-data-in-chunks hstmt 0 data-ptr c-type sql-type + out-len-ptr nil))) + #+ignore + (if (< 0 precision +max-precision+) ;(and precision (< precision +max-precision+)) + (read-data data-ptr c-type sql-type out-len-ptr nil) + (read-data-in-chunks hstmt 0 data-ptr c-type sql-type + out-len-ptr nil))))) + (t + (loop for i from 0 + until (or (and count (= i count)) + (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND)) + collect + (loop for data-ptr across column-data-ptrs + for c-type across column-c-types + for sql-type across column-sql-types + for out-len-ptr across column-out-len-ptrs + for precision across column-precisions + for j from 0 ; column count is zero based in lisp + collect + (cond ((< 0 precision +max-precision+) + (read-data data-ptr c-type sql-type out-len-ptr nil)) + ((zerop (get-cast-long out-len-ptr)) + nil) + (t + (read-data-in-chunks hstmt j data-ptr c-type sql-type + out-len-ptr nil))))))) + query))))) + +#+lispworks +(defmacro without-interrupts (&body body) + `(mp:without-preemption ,@body)) + +#+allegro +(defmacro without-interrupts (&body body) + `(mp:without-scheduling ,@body)) + +#+cormanlisp +(defmacro without-interrupts (&body body) + `(progn ,@body)) + +#+pcl +(defmacro without-interrupts (&body body) + `(pcl::without-interrupts ,@body)) + +(defmethod db-query ((database odbc-database) query-expression &optional flatp) + (let ((free-query + ;; make it thread safe + (get-free-query database))) + ;;(format tb::*local-output* "~%new query: ~s" free-query) + (setf (sql-expression free-query) query-expression) + (unwind-protect + (progn + (%db-execute free-query query-expression) + (%initialize-query free-query) + (values + (db-fetch-query-results free-query nil flatp) + ;; LMH return the column names as well + (column-names free-query))) + (db-close-query free-query) + ;;(format tb::*local-output* "~%query closed: ~s" free-query) + ))) + +(defmethod %db-execute ((database odbc-database) sql-expression &key &allow-other-keys) + (%db-execute (get-free-query database) sql-expression)) + +;; C. Stacy's idea +(defmethod %db-execute ((query odbc-query) sql-expression &key &allow-other-keys) + ;; cstacy + (when *trace-sql* + (format (if (streamp *trace-sql*) *trace-sql* *trace-output*) + "~&~A;~%" sql-expression)) + (with-slots (henv hdbc) (odbc::query-database query) + (with-slots (hstmt) query + (unless hstmt (setf hstmt (%new-statement-handle hdbc))) + ;;(print (list :new hstmt) tb::*local-output*) + (setf (sql-expression query) sql-expression) + (%sql-exec-direct sql-expression hstmt henv hdbc) + query))) + +;; reuse inactive queries +(defmethod get-free-query ((database odbc-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) database + (or (without-interrupts ;; not context switch allowed here + (let ((inactive-query (find-if (lambda (query) + (not (query-active-p query))) + queries))) + (when inactive-query + (with-slots (column-count column-names column-c-types + column-sql-types column-data-ptrs + column-out-len-ptrs column-precisions + column-scales column-nullables-p) + inactive-query + ;;(print column-data-ptrs tb::*local-output*) + ;;(%dispose-column-ptrs inactive-query) + (setf column-count 0 + (fill-pointer column-names) 0 + (fill-pointer column-c-types) 0 + (fill-pointer column-sql-types) 0 + (fill-pointer column-data-ptrs) 0 + (fill-pointer column-out-len-ptrs) 0 + (fill-pointer column-precisions) 0 + (fill-pointer column-scales) 0 + (fill-pointer column-nullables-p) 0)) + (setf (query-active-p inactive-query) t)) + inactive-query)) + (let ((new-query (make-instance 'odbc-query + :database database + ;;(clone-database database) + :active-p t))) + (push new-query queries) + new-query)))) + +(defmethod db-execute-command ((database odbc-database) sql-string) + (db-execute-command (get-free-query database) sql-string)) + +(defmethod db-execute-command ((query odbc-query) sql-string) + ;; cstacy + (when *trace-sql* + (format (if (streamp *trace-sql*) *trace-sql* *trace-output*) + "~&~A;~%" sql-string)) + (with-slots (hstmt database) query + (with-slots (henv hdbc) database + (unless hstmt (setf hstmt (%new-statement-handle hdbc))) + (unwind-protect + (%sql-exec-direct sql-string hstmt henv hdbc) + (db-close-query query))))) + +(defmethod %initialize-query ((database odbc-database) &optional arglen col-positions) + (%initialize-query (db-query-object database) arglen col-positions)) + +(defmethod %initialize-query ((query odbc-query) &optional arglen col-positions) + (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 + (setf column-count (if arglen + (min arglen (result-columns-count hstmt)) + (result-columns-count hstmt))) + ;;(format tb::*local-output* "~%column-count: ~d, col-positions: ~d" column-count col-positions) + (labels ((initialize-column (col-nr) + (multiple-value-bind (name sql-type precision scale nullable-p) + (%describe-column hstmt (1+ col-nr)) + ;; 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 + (%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) + (vector-push-extend (sql-to-c-type sql-type) column-c-types) + (vector-push-extend precision column-precisions) + (vector-push-extend scale column-scales) + (vector-push-extend nullable-p column-nullables-p) + (vector-push-extend data-ptr column-data-ptrs) + (vector-push-extend out-len-ptr column-out-len-ptrs))))) + (if col-positions + (dolist (col-nr col-positions) + (initialize-column col-nr)) + (dotimes (col-nr column-count) + ;; get column information + (initialize-column col-nr))))) + query) + +(defmethod db-close-query ((query odbc-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 + (let ((count (fill-pointer column-data-ptrs))) + (when (not (zerop count)) + (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))))) + (cond ((null hstmt) + nil) + (drop-p + (%free-statement hstmt :drop) + (setf hstmt nil)) + (t + (%free-statement hstmt :unbind) + (%free-statement hstmt :reset) + (%free-statement hstmt :close))) + (setf (query-active-p query) nil))) + query) + +(defmethod %read-query-data ((database odbc-database) ignore-columns) + (%read-query-data (db-query-object database) ignore-columns)) + +(defmethod %read-query-data ((query odbc-query) ignore-columns) + (with-slots (hstmt column-count column-c-types column-sql-types + column-data-ptrs column-out-len-ptrs column-precisions) + query + (unless (= (SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND) + (values + (loop for col-nr from 0 to (- column-count + (if (eq ignore-columns :last) 2 1)) + collect + (let ((precision (aref column-precisions col-nr)) + (sql-type (aref column-sql-types col-nr))) + (cond ((or (< 0 precision +max-precision+) + (and (zerop precision) (not (find sql-type '($SQL_C_CHAR))))) + (read-data (aref column-data-ptrs col-nr) + (aref column-c-types col-nr) + sql-type + (aref column-out-len-ptrs col-nr) + nil)) + ((zerop (get-cast-long (aref column-out-len-ptrs col-nr))) + *null*) + (t + (read-data-in-chunks hstmt col-nr + (aref column-data-ptrs col-nr) + (aref column-c-types col-nr) + (aref column-sql-types col-nr) + (aref column-out-len-ptrs col-nr) + nil))))) + t)))) + +(defmethod db-map-query ((database odbc-database) 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)) + (unwind-protect + (progn + (%initialize-query query) + ;; the main loop + (loop for data = (%read-query-data query nil) + while data + do (apply function data))) + ;; 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) + (declare (ignore type)) ; preliminary. Do a type coersion here + (unwind-protect + (progn + (apply #'%db-bind-execute query parameters) + ;; the main loop + (loop with data + while (setf data (%read-query-data query nil)) + do (apply function data))) + ;; dispose of memory and set query inactive or get rid of it + (%db-reset-query query))) + +;; does not always return exactly a lisp type... +(defun sql-to-lisp-type (sql-type) + (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_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_BINARY #.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) odbc::$SQL_C_BINARY) ; ?? + (#.odbc::$SQL_TINYINT :short) + ;;(#.odbc::$SQL_BIT odbc::$SQL_C_BIT) ; ?? + ((#.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) :binary) + )) + +;; prepared queries + +(defmethod db-prepare-statement ((database odbc-database) sql + &key parameter-table parameter-columns) + (with-slots (hdbc) database + (let ((query (get-free-query database))) + (with-slots (hstmt) query + (unless hstmt (setf hstmt (%new-statement-handle hdbc)))) + (db-prepare-statement query sql parameter-table parameter-columns)))) + +(defmethod db-prepare-statement ((query odbc-query) (sql string) + &key parameter-table parameter-columns) + ;; this is a workaround to get hold of the column types when the driver does not + ;; 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)) + (%db-execute query (format nil "select ~{~a~^,~} from ~a where 0 = 1" + (or parameter-columns '("*")) parameter-table)) + (%initialize-query query) + (with-slots (hstmt) query + (%free-statement hstmt :unbind) + (%free-statement hstmt :reset) + (setf (sql-expression query) sql) + (%sql-prepare hstmt sql)) + query) + + +(defmethod %db-bind-execute ((query odbc-query) &rest parameters) + (with-slots (hstmt parameter-data-ptrs) query + (loop for parameter in parameters + with data-ptr and size and parameter-string + do + (setf parameter-string + (if (stringp parameter) + parameter + (write-to-string parameter)) + size (length parameter-string) + data-ptr + (uffi:allocate-foreign-string (1+ size))) + (vector-push-extend data-ptr parameter-data-ptrs) + (%sql-bind-parameter + hstmt (1- (fill-pointer parameter-data-ptrs)) odbc::$SQL_PARAM_INPUT + odbc::$SQL_C_CHAR ; (aref column-c-types parameter-count) + odbc::$SQL_CHAR ; sql-type + +max-precision+ ;precision ; this should be the actual precision! + ;; scale + 0 ;; should be calculated for odbc::$SQL_DECIMAL, + ;;$SQL_NUMERIC and odbc::$SQL_TIMESTAMP + data-ptr ;; = rgbValue + 0 + ;; *pcbValue; + ;; change this for output and binary input! (see 3-32) + (%null-ptr)) + (%put-str data-ptr parameter-string size)) + (%sql-execute hstmt))) + + +(defmethod %db-reset-query ((query odbc-query)) + (with-slots (hstmt parameter-data-ptrs) query + (prog1 + (db-fetch-query-results query nil ; flatp + nil) + (%free-statement hstmt :reset) ;; but _not_ :unbind ! + (%free-statement hstmt :close) + (dotimes (param-nr (fill-pointer parameter-data-ptrs)) + (let ((data-ptr (aref parameter-data-ptrs param-nr))) + (when data-ptr (uffi:free-foreign-object data-ptr)))) + (setf (fill-pointer parameter-data-ptrs) 0)))) + +(defun data-parameter-ptr (hstmt) + (uffi:with-foreign-object (param-ptr (* :pointer-void)) + (let ((return-code (%sql-param-data hstmt param-ptr))) + ;;(format t "~%return-code from %sql-param-data: ~a~%" return-code) + (when (= return-code odbc::$SQL_NEED_DATA) + ;;(ffc::%pointer-to-address (%get-ptr param-ptr)) + (uffi:deref-pointer param-ptr :pointer-void))))) + +;; database inquiery functions + +(defmethod db-describe-columns ((database odbc-database) + 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) + (with-slots (hdbc info) database + (or (gethash info-type info) + (setf (gethash info-type info) + (%sql-get-info hdbc info-type))))) + +(defmethod get-odbc-info ((query odbc-query) info-type) + (get-odbc-info (odbc::query-database query) info-type)) + +;; driver inquiery +(defmethod db-data-sources ((db-type (eql :odbc))) + "Returns a list of (data-source description) - pairs" + (let ((henv (%new-environment-handle))) + (unwind-protect + (loop with direction = :first + for data-source+description + = (multiple-value-list (%sql-data-sources henv :direction direction)) + while (car data-source+description) + collect data-source+description + do (setf direction :next)) + (%sql-free-environment henv)))) + +; EOF diff --git a/db-odbc/odbc-ff-interface.lisp b/db-odbc/odbc-ff-interface.lisp new file mode 100644 index 0000000..48bbe1c --- /dev/null +++ b/db-odbc/odbc-ff-interface.lisp @@ -0,0 +1,349 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: odbc -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: odbc-ff-interface.lisp +;;;; Purpose: Function definitions for UFFI interface to ODBC +;;;; Author: Kevin M. Rosenberg +;;;; +;;;; $Id: odbc-package.lisp 7061 2003-09-07 06:34:45Z kevin $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004 by Kevin M. Rosenberg +;;;; and Copyright (C) Paul Meurer 1999 - 2001. All rights reserved. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:odbc) + +(def-foreign-type sql-handle (* :void)) +(def-foreign-type sql-handle-ptr (* sql-handle)) +(def-foreign-type string-ptr (* :void)) + +(def-type long-ptr-type '(* :long)) + + +(def-function "SQLAllocEnv" + ((*phenv sql-handle-ptr) ; HENV FAR *phenv + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLAllocConnect" + ((henv sql-handle) ; HENV henv + (*phdbc sql-handle-ptr) ; HDBC FAR *phdbc + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLConnect" + ((hdbc sql-handle) ; HDBC hdbc + (*szDSN string-ptr) ; UCHAR FAR *szDSN + (cbDSN :short) ; SWORD cbDSN + (*szUID string-ptr) ; UCHAR FAR *szUID + (cbUID :short) ; SWORD cbUID + (*szAuthStr string-ptr) ; UCHAR FAR *szAuthStr + (cbAuthStr :short) ; SWORD cbAuthStr + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLDriverConnect" + ((hdbc sql-handle) ; HDBC hdbc + (hwnd sql-handle) ; SQLHWND hwnd + (*szConnStrIn string-ptr) ; UCHAR FAR *szConnStrIn + (cbConnStrIn :short) ; SWORD cbConnStrIn + (*szConnStrOut string-ptr) ; UCHAR FAR *szConnStrOut + (cbConnStrOutMax :short) ; SWORD cbConnStrOutMax + (*pcbConnStrOut :pointer-void) ; SWORD FAR *pcbConnStrOut + (fDriverCompletion :short) ; UWORD fDriverCompletion + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLDisconnect" + ((hdbc sql-handle)) ; HDBC hdbc + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLAllocStmt" + ((hdbc sql-handle) ; HDBC hdbc + (*phstmt sql-handle-ptr) ; HSTMT FAR *phstmt + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLGetInfo" + ((hdbc sql-handle) ; HDBC hdbc + (fInfoType :short) ; UWORD fInfoType + (rgbInfoValue :pointer-void) ; PTR rgbInfoValue + (cbInfoValueMax :short) ; SWORD cbInfoValueMax + (*pcbInfoValue :pointer-void) ; SWORD FAR *pcbInfoValue + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLPrepare" + ((hstmt sql-handle) ; HSTMT hstmt + (*szSqlStr string-ptr) ; UCHAR FAR *szSqlStr + (cbSqlStr :long) ; SDWORD cbSqlStr + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLExecute" + ((hstmt sql-handle) ; HSTMT hstmt + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLExecDirect" + ((hstmt sql-handle) ; HSTMT hstmt + (*szSqlStr string-ptr) ; UCHAR FAR *szSqlStr + (cbSqlStr :long) ; SDWORD cbSqlStr + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLFreeStmt" + ((hstmt sql-handle) ; HSTMT hstmt + (fOption :short)) ; UWORD fOption + :module :odbc + :returning :short) ; RETCODE_SQL_API + + (def-function "SQLCancel" + ((hstmt sql-handle) ; HSTMT hstmt + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLError" + ((henv sql-handle) ; HENV henv + (hdbc sql-handle) ; HDBC hdbc + (hstmt sql-handle) ; HSTMT hstmt + (*szSqlState string-ptr) ; UCHAR FAR *szSqlState + (*pfNativeError :pointer-void) ; SDWORD FAR *pfNativeError + (*szErrorMsg string-ptr) ; UCHAR FAR *szErrorMsg + (cbErrorMsgMax :short) ; SWORD cbErrorMsgMax + (*pcbErrorMsg :pointer-void) ; SWORD FAR *pcbErrorMsg + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLNumResultCols" + ((hstmt sql-handle) ; HSTMT hstmt + (*pccol :pointer-void) ; SWORD FAR *pccol + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLRowCount" + ((hstmt sql-handle) ; HSTMT hstmt + (*pcrow :pointer-void) ; SDWORD FAR *pcrow + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLDescribeCol" + ((hstmt sql-handle) ; HSTMT hstmt + (icol :short) ; UWORD icol + (*szColName string-ptr) ; UCHAR FAR *szColName + (cbColNameMax :short) ; SWORD cbColNameMax + (*pcbColName :pointer-void) ; SWORD FAR *pcbColName + (*pfSqlType :pointer-void) ; SWORD FAR *pfSqlType + (*pcbColDef :pointer-void) ; UDWORD FAR *pcbColDef + (*pibScale :pointer-void) ; SWORD FAR *pibScale + (*pfNullable :pointer-void) ; SWORD FAR *pfNullable + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLColAttributes" + ((hstmt sql-handle) ; HSTMT hstmt + (icol :short) ; UWORD icol + (fDescType :short) ; UWORD fDescType + (rgbDesc :pointer-void) ; PTR rgbDesc + (cbDescMax :short) ; SWORD cbDescMax + (*pcbDesc :pointer-void) ; SWORD FAR *pcbDesc + (*pfDesc :pointer-void) ; SDWORD FAR *pfDesc + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLColumns" + ((hstmt sql-handle) ; HSTMT hstmt + (*szTableQualifier string-ptr) ; UCHAR FAR *szTableQualifier + (cbTableQualifier :short) ; SWORD cbTableQualifier + (*szTableOwner string-ptr) ; UCHAR FAR *szTableOwner + (cbTableOwner :short) ; SWORD cbTableOwner + (*szTableName string-ptr) ; UCHAR FAR *szTableName + (cbTableName :short) ; SWORD cbTableName + (*szColumnName string-ptr) ; UCHAR FAR *szColumnName + (cbColumnName :short) ; SWORD cbColumnName + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLBindCol" + ((hstmt sql-handle) ; HSTMT hstmt + (icol :short) ; UWORD icol + (fCType :short) ; SWORD fCType + (rgbValue :pointer-void) ; PTR rgbValue + (cbValueMax :long) ; SDWORD cbValueMax + (*pcbValue :pointer-void) ; SDWORD FAR *pcbValue + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLFetch" + ((hstmt sql-handle) ; HSTMT hstmt + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLTransact" + ((henv sql-handle) ; HENV henv + (hdbc sql-handle) ; HDBC hdbc + (fType :short) ; UWORD fType ($SQL_COMMIT or $SQL_ROLLBACK) + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +;; ODBC 2.0 +(def-function "SQLDescribeParam" + ((hstmt sql-handle) ; HSTMT hstmt + (ipar :short) ; UWORD ipar + (*pfSqlType :pointer-void) ; SWORD FAR *pfSqlType + (*pcbColDef :pointer-void) ; UDWORD FAR *pcbColDef + (*pibScale :pointer-void) ; SWORD FAR *pibScale + (*pfNullable :pointer-void) ; SWORD FAR *pfNullable + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +;; ODBC 2.0 +(def-function "SQLBindParameter" + ((hstmt sql-handle) ; HSTMT hstmt + (ipar :short) ; UWORD ipar + (fParamType :short) ; SWORD fParamType + (fCType :short) ; SWORD fCType + (fSqlType :short) ; SWORD fSqlType + (cbColDef :long) ; UDWORD cbColDef + (ibScale :short) ; SWORD ibScale + (rgbValue :pointer-void) ; PTR rgbValue + (cbValueMax :long) ; SDWORD cbValueMax + (*pcbValue :pointer-void) ; SDWORD FAR *pcbValue + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +;; level 1 +(def-function "SQLGetData" + ((hstmt sql-handle) ; HSTMT hstmt + (icol :short) ; UWORD icol + (fCType :short) ; SWORD fCType + (rgbValue :pointer-void) ; PTR rgbValue + (cbValueMax :long) ; SDWORD cbValueMax + (*pcbValue :pointer-void) ; SDWORD FAR *pcbValue + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLParamData" + ((hstmt sql-handle) ; HSTMT hstmt + (*prgbValue :pointer-void) ; PTR FAR *prgbValue + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLPutData" + ((hstmt sql-handle) ; HSTMT hstmt + (rgbValue :pointer-void) ; PTR rgbValue + (cbValue :long) ; SDWORD cbValue + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLGetConnectOption" + ((hdbc sql-handle) ; HDBC hdbc + (fOption :short) ; UWORD fOption + (pvParam :pointer-void) ; PTR pvParam + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLSetConnectOption" + ((hdbc sql-handle) ; HDBC hdbc + (fOption :short) ; UWORD fOption + (vParam :long) ; UDWORD vParam + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLSetPos" + ((hstmt sql-handle) ; HSTMT hstmt + (irow :short) ; UWORD irow + (fOption :short) ; UWORD fOption + (fLock :short) ; UWORD fLock + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + + ; level 2 +(def-function "SQLExtendedFetch" + ((hstmt sql-handle) ; HSTMT hstmt + (fFetchType :short) ; UWORD fFetchType + (irow :long) ; SDWORD irow + (*pcrow :pointer-void) ; UDWORD FAR *pcrow + (*rgfRowStatus :pointer-void) ; UWORD FAR *rgfRowStatus + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLDataSources" + ((henv sql-handle) ; HENV henv + (fDirection :short) + (*szDSN string-ptr) ; UCHAR FAR *szDSN + (cbDSNMax :short) ; SWORD cbDSNMax + (*pcbDSN :pointer-void) ; SWORD *pcbDSN + (*szDescription string-ptr) ; UCHAR *szDescription + (cbDescriptionMax :short) ; SWORD cbDescriptionMax + (*pcbDescription :pointer-void) ; SWORD *pcbDescription + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + +(def-function "SQLFreeEnv" + ((henv sql-handle) ; HSTMT hstmt + ) + :module :odbc + :returning :short) ; RETCODE_SQL_API + + +;;; foreign type definitions + +;;(defmacro %sql-len-data-at-exec (length) +;; `(- $SQL_LEN_DATA_AT_EXEC_OFFSET ,length)) + + +(def-struct sql-c-time + (hour :short) + (minute :short) + (second :short)) + +(def-struct sql-c-date + (year :short) + (month :short) + (day :short)) + +(def-struct sql-c-timestamp + (year :short) + (month :short) + (day :short) + (hour :short) + (minute :short) + (second :short) + (fraction :long)) + diff --git a/db-odbc/odbc-package.lisp b/db-odbc/odbc-package.lisp index b76d282..cd40c00 100644 --- a/db-odbc/odbc-package.lisp +++ b/db-odbc/odbc-package.lisp @@ -22,6 +22,43 @@ (:use #:cl #:uffi) (:export #:database-library-loaded + + #:*null* + #:*trace-sql* + #:+max-precision+ + #:get-cast-long + #:%free-statement + #:%disconnect + #:%commit + #:%rollback + #:%sql-fetch + #:%sql-cancel + #:%new-db-connection-handle + #:%new-environment-handle + #:%sql-driver-connect + #:%sql-connect + #:disable-autocommit + #:enable-autocommit + #:%null-ptr + #:%sql-free-environment + #:%sql-data-sources + #:%sql-get-info + #:%sql-param-data + #:%sql-execute + #:%put-str + #:%sql-bind-parameter + #:%sql-prepare + #:sqlfetch + #:%bind-column + #:%allocate-bindings + #:%describe-column + #:%describe-columns + #:read-data + #:read-data-in-chunks + #:query-database + #:%new-statement-handle + #:%sql-exec-direct + #:%put-str ) (:documentation "This is the low-level interface ODBC."))