db-odbc/odbc-api.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: odbc -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:     odbc-ff-interface.lisp
   6 ;;;; Purpose:  Function definitions for UFFI interface to ODBC
   7 ;;;; Author:   Kevin M. Rosenberg, Paul Meurer
   8 ;;;;
   9 ;;;; $Id: odbc-package.lisp 7061 2003-09-07 06:34:45Z kevin $
  10 ;;;;
  11 ;;;; This file, part of CLSQL, is Copyright (c) 2004 by Kevin M. Rosenberg
  12 ;;;; and Copyright (C) Paul Meurer 1999 - 2001. All rights reserved.
  13 ;;;;
  14 ;;;; CLSQL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:odbc)
  20
  21 (defvar *null* (make-null-pointer :byte))
  22 (defvar *binary-format* :unsigned-byte-vector)
  23 (defvar *time-conversion-function* 'identity)
  24 (defvar *trace-sql* nil)
  25
  26 (defun %null-ptr ()
  27   (allocate-foreign-object :pointer-void))
  28
  29 (defmacro %put-str (ptr string &optional max-length)
  30   (let ((size (gensym)))
  31     `(let ((,size (length ,string)))
  32        (when (and ,max-length (> ,size ,max-length))
  33          (error "string \"~a\" of length ~d is longer than max-length: ~d"
  34                 ,string ,size ,max-length))
  35        (dotimes (i ,size)
  36          (setf (deref-array ,ptr '(:array :unsigned-char) i) (char ,string i)))
  37        (setf (deref-array ,ptr '(:array :unsigned-char) ,size) 0))))
  38
  39 (defun handle-error (henv hdbc hstmt)
  40   (with-foreign-objects ((sql-state '(:array :unsigned-char 256))
  41                          (error-message '(:array :unsigned-char
  42                                           #.$SQL_MAX_MESSAGE_LENGTH))
  43                          (error-code :long)
  44                          (msg-length :short))
  45     (SQLError henv hdbc hstmt sql-state
  46               error-code error-message
  47               $SQL_MAX_MESSAGE_LENGTH msg-length)
  48     (values
  49      (convert-from-foreign-string error-message)
  50      (convert-from-foreign-string sql-state)
  51      (deref-pointer msg-length :short)
  52      (deref-pointer error-code :long))))
  53
  54 ; test this: return a keyword for efficiency
  55 (defun sql-state (henv hdbc hstmt)
  56   (with-foreign-objects ((sql-state '(:array :unsigned-char 256))
  57                          (error-message '(:array :unsigned-char
  58                                           #.$SQL_MAX_MESSAGE_LENGTH))
  59                          (error-code :long)
  60                          (msg-length :short))
  61     (SQLError henv hdbc hstmt sql-state error-code
  62               error-message $SQL_MAX_MESSAGE_LENGTH msg-length)
  63     (convert-from-foreign-string sql-state) ;(%cstring-to-keyword sql-state)
  64     ))
  65
  66 (defmacro with-error-handling ((&key henv hdbc hstmt (print-info t))
  67                                    odbc-call &body body)
  68   (let ((result-code (gensym)))
  69     `(let ((,result-code ,odbc-call))
  70        (case ,result-code
  71          (#.$SQL_SUCCESS
  72           (progn ,result-code ,@body))
  73          (#.$SQL_SUCCESS_WITH_INFO
  74           (when ,print-info
  75             (multiple-value-bind (error-message sql-state)
  76                                  (handle-error (or ,henv (%null-ptr))
  77                                                (or ,hdbc (%null-ptr))
  78                                                (or ,hstmt (%null-ptr)))
  79               (warn "[ODBC info] ~a state: ~a"
  80                     ,result-code error-message
  81                     sql-state)))
  82           (progn ,result-code ,@body))
  83          (#.$SQL_INVALID_HANDLE
  84           (error "[ODBC error] Invalid handle"))
  85          (#.$SQL_STILL_EXECUTING
  86           (error "[ODBC error] Still executing"))
  87          (#.$SQL_ERROR
  88           (multiple-value-bind (error-message sql-state)
  89                                (handle-error (or ,henv (%null-ptr))
  90                                              (or ,hdbc (%null-ptr))
  91                                              (or ,hstmt (%null-ptr)))
  92             (error "[ODBC error] ~a; state: ~a" error-message sql-state)))
  93          (otherwise
  94           (progn ,result-code ,@body))))))
  95
  96 (defun %new-environment-handle ()
  97   (with-foreign-object (phenv 'sql-handle-ptr)
  98     (with-error-handling
  99         ()
 100       (SQLAllocEnv phenv)
 101       (deref-pointer phenv 'sql-handle-ptr))))
 102
 103 (defun %sql-free-environment (henv)
 104   (with-error-handling
 105     (:henv henv)
 106     (SQLFreeEnv henv)))
 107
 108 (defun %new-db-connection-handle (henv)
 109   (with-foreign-object (phdbc 'sql-handle-ptr)
 110     (with-error-handling
 111       (:henv henv)
 112       (SQLAllocConnect henv phdbc)
 113       (deref-pointer phdbc 'sql-handle-ptr))))
 114
 115 (defun %free-statement (hstmt option)
 116   (with-error-handling
 117       (:hstmt hstmt)
 118       (SQLFreeStmt
 119        hstmt
 120        (ecase option
 121          (:drop $SQL_DROP)
 122          (:close $SQL_CLOSE)
 123          (:unbind $SQL_UNBIND)
 124          (:reset $SQL_RESET_PARAMS)))))
 125
 126 (defmacro with-statement-handle ((hstmt hdbc) &body body)
 127   `(let ((,hstmt (%new-statement-handle ,hdbc)))
 128      (unwind-protect
 129        (progn ,@body)
 130        (%free-statement ,hstmt :drop))))
 131
 132 ;; functional interface
 133
 134 (defun %sql-connect (hdbc server uid pwd)
 135   (with-cstrings ((server-ptr server)
 136                   (uid-ptr uid)
 137                   (pwd-ptr pwd))
 138     (with-error-handling
 139         (:hdbc hdbc)
 140       (SQLConnect hdbc server-ptr $SQL_NTS uid-ptr
 141                   $SQL_NTS pwd-ptr $SQL_NTS))))
 142
 143 ;;; SQLDriverConnect
 144 ;;; [991115 CStacy@Pilgrim.COM]
 145 ;;;
 146 ;;; The CONNX ODBC driver can bring up a nice GUI prompt for the User-ID
 147 ;;; and password, so that applications don't have to supply their own.
 148 ;;;
 149 ;;; That is not desirable for non-interactive applications, such as
 150 ;;; web servers, so they should always supply complete login info
 151 ;;; to SQLConnect.   But the driver won't bring up a GUI anyway
 152 ;;; unless the SQL_QUIET_MODE is set to an HWND (nonzero).
 153 ;;; (CONNX version 6 did not have the GUI "Integrated Login" feature,
 154 ;;; and in version 7, it was broken such that the GUI always came up.)
 155 ;;;
 156 ;;; Connx version 8 respects to that connection option, so the first
 157 ;;; thing I tried was just setting it.  I hacked the DB-CONNECT ODBC
 158 ;;; method with this:
 159 ;;;        (without-error-handling
 160 ;;;         (SQLSetConnectOption hdbc $SQL_QUIET_MODE hwnd))
 161 ;;; but that didn't work -- no GUI ever comes up from SQLConnect.
 162 ;;; That may be a bug in the CONNX driver.
 163 ;;;
 164 ;;; In the end, the luser tech support person at CONNX Integrated Solutions
 165 ;;; gave me the hint that if I were using VB, I should give it a string
 166 ;;; like "DSN=CONNX8SAMPLES32, prompt=2".  There's no ODBC API that wants
 167 ;;; a string like that, but SQLDriverConnect does take an attribute-value-list
 168 ;;; connection string (including driver-defined attributes).  Reading the SDK
 169 ;;; header files, I find that it also takes an argument that is 2 if you want
 170 ;;; the driver to use a GUI and prompt the user.  Eureka!
 171 ;;;
 172 ;;; If the user specified a DSN, we use SQL_DRIVER_COMPLETE and let the
 173 ;;; Driver Manager find the appropriate driver.  (Otherwise, aside from
 174 ;;; the gratuitous prompt about the driver, the CONNX driver would also
 175 ;;; prompting for the DSN and the Data Dictionary (CDD file).
 176
 177 ;; cstacy
 178 (defun odbc-connection-string (connection-string db-name user-id password)
 179   ;; Merge the specified attributes into a usable connection-string.
 180   (multiple-value-bind (dsn uid pwd other-attr-vals)
 181       (odbc-parse-connection-string connection-string)
 182     (setq db-name (or db-name dsn)
 183           user-id (or user-id uid)
 184           password (or password pwd)
 185           connection-string
 186           (format nil "DSN=~A~:[~;~:*;UID=~A~]~:[~;~:*;PWD=~A~]~:[~;~:*;~A~]"
 187                   db-name user-id password other-attr-vals))
 188     (values
 189      connection-string
 190      db-name
 191      user-id
 192      password)))
 193
 194 ;; cstacy
 195 (defun odbc-parse-connection-string (connection-string)
 196   (flet ((parse (key)
 197            (let ((beg (search key connection-string :test #'equal)))
 198              (when beg
 199                (subseq connection-string
 200                        (+ beg (length key))
 201                        (position #\; connection-string :start beg))))))
 202     (let ((db-name (parse "DSN="))
 203           (user-id (parse "UID="))
 204           (password (parse "PWD=")))
 205       (values db-name user-id password nil))))
 206
 207 (defun %sql-driver-connect (henv hdbc hwnd connection-string completion-option)
 208   (let ((completion-option
 209          (ecase completion-option
 210            (:complete $SQL_DRIVER_COMPLETE)
 211            (:required $SQL_DRIVER_COMPLETE_REQUIRED)
 212            (:prompt $SQL_DRIVER_PROMPT)
 213            (:noprompt $SQL_DRIVER_NOPROMPT))))
 214     (with-cstring (connection-str-ptr connection-string)
 215       (with-foreign-objects
 216         ((complete-connection-str-ptr '(:array :unsigned-char 1024))
 217          (length-ptr :short))
 218         (with-error-handling
 219           (:henv henv :hdbc hdbc)
 220           (SQLDriverConnect hdbc hwnd ; (%null-ptr) ; no window
 221                             connection-str-ptr $SQL_NTS
 222                             complete-connection-str-ptr 1024
 223                             length-ptr completion-option))
 224         (print (convert-from-foreign-string complete-connection-str-ptr))))))
 225
 226 (defun %disconnect (hdbc)
 227   (with-error-handling
 228     (:hdbc hdbc)
 229     (SQLDisconnect hdbc)))
 230
 231 (defun %commit (henv hdbc)
 232   (with-error-handling
 233     (:henv henv :hdbc hdbc)
 234     (SQLTransact
 235      henv hdbc $SQL_COMMIT)))
 236
 237 (defun %rollback (henv hdbc)
 238   (with-error-handling
 239     (:henv henv :hdbc hdbc)
 240     (SQLTransact
 241      henv hdbc $SQL_ROLLBACK)))
 242
 243 ; col-nr is zero-based in Lisp
 244 ; col-nr = :bookmark retrieves a bookmark.
 245 (defun %bind-column (hstmt column-nr c-type data-ptr precision out-len-ptr)
 246   (with-error-handling
 247     (:hstmt hstmt)
 248     (SQLBindCol hstmt
 249                 (if (eq column-nr :bookmark) 0 (1+ column-nr))
 250                 c-type data-ptr precision out-len-ptr)))
 251
 252 ; parameter-nr is zero-based in Lisp
 253 (defun %sql-bind-parameter (hstmt parameter-nr parameter-type c-type
 254                                       sql-type precision scale data-ptr
 255                                       max-value out-len-ptr)
 256   (with-error-handling
 257     (:hstmt hstmt)
 258     (SQLBindParameter hstmt (1+ parameter-nr)
 259                       parameter-type ;$SQL_PARAM_INPUT
 260                       c-type ;$SQL_C_CHAR
 261                       sql-type ;$SQL_VARCHAR
 262                       precision ;(1- (length str))
 263                       scale ;0
 264                       data-ptr
 265                       max-value
 266                       out-len-ptr ;#.(%null-ptr)
 267                       )))
 268
 269 (defun %sql-fetch (hstmt)
 270   (with-error-handling
 271       (:hstmt hstmt)
 272       (SQLFetch hstmt)))
 273
 274 (defun %new-statement-handle (hdbc)
 275   (with-foreign-object (hstmt-ptr 'sql-handle-ptr)
 276     (with-error-handling
 277       (:hdbc hdbc)
 278       (SQLAllocStmt hdbc hstmt-ptr)
 279       (deref-pointer hstmt-ptr 'sql-handle-ptr))))
 280
 281 (defun %sql-get-info (hdbc info-type)
 282   (ecase info-type
 283     ;; those return string
 284     ((#.$SQL_ACCESSIBLE_PROCEDURES
 285       #.$SQL_ACCESSIBLE_TABLES
 286       #.$SQL_COLUMN_ALIAS
 287       #.$SQL_DATA_SOURCE_NAME
 288       #.$SQL_DATA_SOURCE_READ_ONLY
 289       #.$SQL_DBMS_NAME
 290       #.$SQL_DBMS_VER
 291       #.$SQL_DRIVER_NAME
 292       #.$SQL_DRIVER_ODBC_VER
 293       #.$SQL_DRIVER_VER
 294       #.$SQL_EXPRESSIONS_IN_ORDERBY
 295       #.$SQL_IDENTIFIER_QUOTE_CHAR
 296       #.$SQL_KEYWORDS
 297       #.$SQL_LIKE_ESCAPE_CLAUSE
 298       #.$SQL_MAX_ROW_SIZE_INCLUDES_LONG
 299       #.$SQL_MULT_RESULT_SETS
 300       #.$SQL_MULTIPLE_ACTIVE_TXN
 301       #.$SQL_NEED_LONG_DATA_LEN
 302       #.$SQL_ODBC_SQL_OPT_IEF
 303       #.$SQL_ODBC_VER
 304       #.$SQL_ORDER_BY_COLUMNS_IN_SELECT
 305       #.$SQL_OUTER_JOINS
 306       #.$SQL_OWNER_TERM
 307       #.$SQL_PROCEDURE_TERM
 308       #.$SQL_PROCEDURES
 309       #.$SQL_QUALIFIER_NAME_SEPARATOR
 310       #.$SQL_QUALIFIER_TERM
 311       #.$SQL_ROW_UPDATES
 312       #.$SQL_SEARCH_PATTERN_ESCAPE
 313       #.$SQL_SERVER_NAME
 314       #.$SQL_SPECIAL_CHARACTERS
 315       #.$SQL_TABLE_TERM
 316       #.$SQL_USER_NAME)
 317      (with-foreign-objects ((info-ptr '(:array :unsigned-char 1024))
 318                             (info-length-ptr :short))
 319        (with-error-handling
 320          (:hdbc hdbc)
 321          #-pcl
 322          (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr)
 323          #+pcl
 324          (SQLGetInfo-Str hdbc info-type info-ptr 1023 info-length-ptr)
 325          (convert-from-foreign-string info-ptr))))
 326     ;; those returning a word
 327     ((#.$SQL_ACTIVE_CONNECTIONS
 328       #.$SQL_ACTIVE_STATEMENTS
 329       #.$SQL_CONCAT_NULL_BEHAVIOR
 330       #.$SQL_CORRELATION_NAME
 331       #.$SQL_CURSOR_COMMIT_BEHAVIOR
 332       #.$SQL_CURSOR_ROLLBACK_BEHAVIOR
 333       #.$SQL_MAX_COLUMN_NAME_LEN
 334       #.$SQL_MAX_COLUMNS_IN_GROUP_BY
 335       #.$SQL_MAX_COLUMNS_IN_INDEX
 336       #.$SQL_MAX_COLUMNS_IN_ORDER_BY
 337       #.$SQL_MAX_COLUMNS_IN_SELECT
 338       #.$SQL_MAX_COLUMNS_IN_TABLE
 339       #.$SQL_MAX_CURSOR_NAME_LEN
 340       #.$SQL_MAX_OWNER_NAME_LEN
 341       #.$SQL_MAX_PROCEDURE_NAME_LEN
 342       #.$SQL_MAX_QUALIFIER_NAME_LEN
 343       #.$SQL_MAX_TABLE_NAME_LEN
 344       #.$SQL_MAX_TABLES_IN_SELECT
 345       #.$SQL_MAX_USER_NAME_LEN
 346       #.$SQL_NON_NULLABLE_COLUMNS
 347       #.$SQL_NULL_COLLATION
 348       #.$SQL_ODBC_API_CONFORMANCE
 349       #.$SQL_ODBC_SAG_CLI_CONFORMANCE
 350       #.$SQL_ODBC_SQL_CONFORMANCE
 351       #.$SQL_QUALIFIER_LOCATION
 352       #.$SQL_QUOTED_IDENTIFIER_CASE
 353       #.$SQL_TXN_CAPABLE)
 354      (with-foreign-objects ((info-ptr :short)
 355                             (info-length-ptr :short))
 356        (with-error-handling
 357         (:hdbc hdbc)
 358          (SQLGetInfo hdbc
 359                      info-type
 360                      info-ptr
 361                      255
 362                      info-length-ptr)
 363          (deref-pointer info-ptr :short)))
 364      )
 365     ;; those returning a long bitmask
 366     ((#.$SQL_ALTER_TABLE
 367       #.$SQL_BOOKMARK_PERSISTENCE
 368       #.$SQL_CONVERT_BIGINT
 369       #.$SQL_CONVERT_BINARY
 370       #.$SQL_CONVERT_BIT
 371       #.$SQL_CONVERT_CHAR
 372       #.$SQL_CONVERT_DATE
 373       #.$SQL_CONVERT_DECIMAL
 374       #.$SQL_CONVERT_DOUBLE
 375       #.$SQL_CONVERT_FLOAT
 376       #.$SQL_CONVERT_INTEGER
 377       #.$SQL_CONVERT_LONGVARCHAR
 378       #.$SQL_CONVERT_NUMERIC
 379       #.$SQL_CONVERT_REAL
 380       #.$SQL_CONVERT_SMALLINT
 381       #.$SQL_CONVERT_TIME
 382       #.$SQL_CONVERT_TIMESTAMP
 383       #.$SQL_CONVERT_TINYINT
 384       #.$SQL_CONVERT_VARBINARY
 385       #.$SQL_CONVERT_VARCHAR
 386       #.$SQL_CONVERT_LONGVARBINARY
 387       #.$SQL_CONVERT_FUNCTIONS
 388       #.$SQL_FETCH_DIRECTION
 389       #.$SQL_FILE_USAGE
 390       #.$SQL_GETDATA_EXTENSIONS
 391       #.$SQL_LOCK_TYPES
 392       #.$SQL_MAX_INDEX_SIZE
 393       #.$SQL_MAX_ROW_SIZE
 394       #.$SQL_MAX_STATEMENT_LEN
 395       #.$SQL_NUMERIC_FUNCTIONS
 396       #.$SQL_OWNER_USAGE
 397       #.$SQL_POS_OPERATIONS
 398       #.$SQL_POSITIONED_STATEMENTS
 399       #.$SQL_QUALIFIER_USAGE
 400       #.$SQL_SCROLL_CONCURRENCY
 401       #.$SQL_SCROLL_OPTIONS
 402       #.$SQL_STATIC_SENSITIVITY
 403       #.$SQL_STRING_FUNCTIONS
 404       #.$SQL_SUBQUERIES
 405       #.$SQL_SYSTEM_FUNCTIONS
 406       #.$SQL_TIMEDATE_ADD_INTERVALS
 407       #.$SQL_TIMEDATE_DIFF_INTERVALS
 408       #.$SQL_TIMEDATE_FUNCTIONS
 409       #.$SQL_TXN_ISOLATION_OPTION
 410       #.$SQL_UNION)
 411      (with-foreign-objects ((info-ptr :long)
 412                             (info-length-ptr :short))
 413        (with-error-handling
 414          (:hdbc hdbc)
 415          (SQLGetInfo hdbc
 416                      info-type
 417                      info-ptr
 418                      255
 419                      info-length-ptr)
 420          (deref-pointer info-ptr :long)))
 421      )
 422     ;; those returning a long integer
 423     ((#.$SQL_DEFAULT_TXN_ISOLATION
 424       #.$SQL_DRIVER_HDBC
 425       #.$SQL_DRIVER_HENV
 426       #.$SQL_DRIVER_HLIB
 427       #.$SQL_DRIVER_HSTMT
 428       #.$SQL_GROUP_BY
 429       #.$SQL_IDENTIFIER_CASE
 430       #.$SQL_MAX_BINARY_LITERAL_LEN
 431       #.$SQL_MAX_CHAR_LITERAL_LEN
 432       #.$SQL_ACTIVE_ENVIRONMENTS
 433       )
 434      (with-foreign-objects ((info-ptr :long)
 435                             (info-length-ptr :short))
 436        (with-error-handling
 437          (:hdbc hdbc)
 438          (SQLGetInfo hdbc info-type info-ptr 255 info-length-ptr)
 439          (deref-pointer info-ptr :long))))))
 440
 441 (defun %sql-exec-direct (sql hstmt henv hdbc)
 442   (with-cstring (sql-ptr sql)
 443     (with-error-handling
 444       (:hstmt hstmt :henv henv :hdbc hdbc)
 445       (SQLExecDirect hstmt sql-ptr $SQL_NTS))))
 446
 447 (defun %sql-cancel (hstmt)
 448   (with-error-handling
 449     (:hstmt hstmt)
 450     (SQLCancel hstmt)))
 451
 452 (defun %sql-execute (hstmt)
 453   (with-error-handling
 454     (:hstmt hstmt)
 455     (SQLExecute hstmt)))
 456
 457 (defun result-columns-count (hstmt)
 458   (with-foreign-objects ((columns-nr-ptr :short))
 459     (with-error-handling (:hstmt hstmt)
 460                          (SQLNumResultCols hstmt columns-nr-ptr)
 461       (deref-pointer columns-nr-ptr :short))))
 462
 463 (defun result-rows-count (hstmt)
 464   (with-foreign-objects ((row-count-ptr :long))
 465     (with-error-handling (:hstmt hstmt)
 466                          (SQLRowCount hstmt row-count-ptr)
 467       (deref-pointer row-count-ptr :long))))
 468
 469 ;; column counting is 1-based
 470 (defun %describe-column (hstmt column-nr)
 471   (with-foreign-objects ((column-name-ptr '(:array :unsigned-char 256))
 472                          (column-name-length-ptr :short)
 473                          (column-sql-type-ptr :short)
 474                          (column-precision-ptr :long)
 475                          (column-scale-ptr :short)
 476                          (column-nullable-p-ptr :short))
 477     (with-error-handling (:hstmt hstmt)
 478                          (SQLDescribeCol hstmt column-nr column-name-ptr 256
 479                                          column-name-length-ptr
 480                                          column-sql-type-ptr
 481                                          column-precision-ptr
 482                                          column-scale-ptr
 483                                          column-nullable-p-ptr)
 484       (values
 485        (convert-from-foreign-string column-name-ptr)
 486        (deref-pointer column-sql-type-ptr :short)
 487        (deref-pointer column-precision-ptr :long)
 488        (deref-pointer column-scale-ptr :short)
 489        (deref-pointer column-nullable-p-ptr :short)))))
 490
 491 ;; parameter counting is 1-based
 492 (defun %describe-parameter (hstmt parameter-nr)
 493   (with-foreign-objects ((column-sql-type-ptr :short)
 494                          (column-precision-ptr :long)
 495                          (column-scale-ptr :short)
 496                          (column-nullable-p-ptr :short))
 497     (with-error-handling
 498       (:hstmt hstmt)
 499       (SQLDescribeParam hstmt parameter-nr
 500                         column-sql-type-ptr
 501                         column-precision-ptr
 502                         column-scale-ptr
 503                         column-nullable-p-ptr)
 504       (values
 505        (deref-pointer column-sql-type-ptr :short)
 506        (deref-pointer column-precision-ptr :long)
 507        (deref-pointer column-scale-ptr :short)
 508        (deref-pointer column-nullable-p-ptr :short)))))
 509
 510 (defun %column-attributes (hstmt column-nr descriptor-type)
 511   (with-foreign-objects ((descriptor-info-ptr '(:array :unsigned-char 256))
 512                          (descriptor-length-ptr :short)
 513                          (numeric-descriptor-ptr :long))
 514     (with-error-handling
 515       (:hstmt hstmt)
 516       (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr 256
 517                         descriptor-length-ptr
 518                         numeric-descriptor-ptr)
 519       (values
 520        (convert-from-foreign-string descriptor-info-ptr)
 521        (deref-pointer numeric-descriptor-ptr :long)))))
 522
 523 (defun %prepare-describe-columns (hstmt table-qualifier table-owner
 524                                    table-name column-name)
 525   (with-cstrings ((table-qualifier-ptr table-qualifier)
 526                   (table-owner-ptr table-owner)
 527                   (table-name-ptr table-name)
 528                   (column-name-ptr column-name))
 529     (with-error-handling
 530         (:hstmt hstmt)
 531       (SQLColumns hstmt
 532                   table-qualifier-ptr (length table-qualifier)
 533                   table-owner-ptr (length table-owner)
 534                   table-name-ptr (length table-name)
 535                   column-name-ptr (length column-name)))))
 536
 537 (defun %describe-columns (hdbc table-qualifier table-owner
 538                           table-name column-name)
 539   (with-statement-handle (hstmt hdbc)
 540     (%prepare-describe-columns hstmt table-qualifier table-owner
 541                                table-name column-name)
 542     (fetch-all-rows hstmt)))
 543
 544 (defun %sql-data-sources (henv &key (direction :first))
 545   (with-foreign-objects
 546    ((name-ptr '(:array :unsigned-char #.(1+ $SQL_MAX_DSN_LENGTH)))
 547     (name-length-ptr :short)
 548     (description-ptr '(:array :unsigned-char 1024))
 549     (description-length-ptr :short))
 550     (let ((res (with-error-handling
 551                  (:henv henv)
 552                  (SQLDataSources henv
 553                                  (ecase direction
 554                                    (:first $SQL_FETCH_FIRST)
 555                                    (:next $SQL_FETCH_NEXT))
 556                                  name-ptr
 557                                  (1+ $SQL_MAX_DSN_LENGTH)
 558                                  name-length-ptr
 559                                  description-ptr
 560                                  1024
 561                                  description-length-ptr))))
 562       (unless (= res $SQL_NO_DATA_FOUND)
 563         (values (convert-from-foreign-string name-ptr)
 564                 (convert-from-foreign-string description-ptr))))))
 565
 566 (defun sql-to-c-type (sql-type)
 567   (ecase sql-type
 568     ((#.$SQL_CHAR #.$SQL_VARCHAR #.$SQL_LONGVARCHAR
 569       #.$SQL_NUMERIC #.$SQL_DECIMAL #.$SQL_BIGINT -8 -9) $SQL_C_CHAR)
 570     (#.$SQL_INTEGER $SQL_C_SLONG)
 571     (#.$SQL_SMALLINT $SQL_C_SSHORT)
 572     ((#.$SQL_FLOAT #.$SQL_DOUBLE) $SQL_C_DOUBLE)
 573     (#.$SQL_REAL $SQL_C_FLOAT)
 574     (#.$SQL_DATE $SQL_C_DATE)
 575     (#.$SQL_TIME $SQL_C_TIME)
 576     (#.$SQL_TIMESTAMP $SQL_C_TIMESTAMP)
 577     ((#.$SQL_BINARY #.$SQL_VARBINARY #.$SQL_LONGVARBINARY) $SQL_C_BINARY)
 578     (#.$SQL_TINYINT $SQL_C_STINYINT)
 579     (#.$SQL_BIT $SQL_C_BIT)))
 580
 581 (defun get-cast-byte (ptr)
 582   (declare (type long-ptr-type out-len-ptr))
 583   (with-cast-pointer (casted ptr '(* :byte))
 584     (deref-pointer casted :byte)))
 585
 586 (defun get-cast-short (ptr)
 587   (declare (type long-ptr-type out-len-ptr))
 588   (with-cast-pointer (casted ptr '(* :short))
 589     (deref-pointer casted :short)))
 590
 591 (defun get-cast-int (ptr)
 592   (declare (type long-ptr-type out-len-ptr))
 593   (with-cast-pointer (casted ptr '(* :int))
 594     (deref-pointer casted :int)))
 595
 596 (defun get-cast-long (ptr)
 597   (declare (type long-ptr-type out-len-ptr))
 598   (with-cast-pointer (casted ptr '(* :long))
 599     (deref-pointer casted :long)))
 600
 601 (defun get-cast-single-float (ptr)
 602   (declare (type long-ptr-type out-len-ptr))
 603   (with-cast-pointer (casted ptr '(* :float))
 604     (deref-pointer casted :float)))
 605
 606 (defun get-cast-double-float (ptr)
 607   (declare (type long-ptr-type out-len-ptr))
 608   (with-cast-pointer (casted ptr '(* :double))
 609     (deref-pointer casted :double)))
 610
 611 (defun get-cast-foreign-string (ptr)
 612   (declare (type long-ptr-type out-len-ptr))
 613   (with-cast-pointer (casted ptr '(* :unsigned-char))
 614     (convert-from-foreign-string casted)))
 615
 616 (defun get-cast-binary (ptr len format)
 617   "FORMAT is one of :unsigned-byte-vector, :bit-vector (:string, :hex-string)"
 618   (with-cast-pointer (casted ptr '(* :byte))
 619     (ecase format
 620       (:unsigned-byte-vector
 621        (let ((vector (make-array len :element-type '(unsigned-byte 8))))
 622          (dotimes (i len)
 623            (setf (aref vector i)
 624                  (deref-array casted '(:array :byte) i)))
 625          vector))
 626       (:bit-vector
 627        (let ((vector (make-array (ash len 3) :element-type 'bit)))
 628          (dotimes (i len)
 629            (let ((byte (deref-array casted '(:array :byte) i)))
 630              (dotimes (j 8)
 631                (setf (bit vector (+ (ash i 3) j)) (logand (ash byte (- j 7)) 1)))))
 632          vector)))))
 633
 634
 635 (defun read-data (data-ptr c-type sql-type out-len-ptr convert-to-string-p)
 636   (declare (type long-ptr-type out-len-ptr))
 637   (let ((out-len (deref-pointer out-len-ptr :long)))
 638     (cond ((= out-len $SQL_NULL_DATA)
 639            *null*)
 640           ;; obsolete?
 641           (convert-to-string-p
 642            (convert-from-foreign-string data-ptr))
 643           (t
 644            (case sql-type
 645              ;; SQL extended datatypes
 646              (#.$SQL_TINYINT  (get-cast-short data-ptr))
 647              (#.$SQL_C_STINYINT (get-cast-short data-ptr)) ;; ?
 648              (#.$SQL_C_SSHORT (get-cast-short data-ptr)) ;; ?
 649              (#.$SQL_SMALLINT (deref-pointer data-ptr :short)) ; ??
 650              (#.$SQL_INTEGER (deref-pointer data-ptr :long))
 651              (#.$SQL_DECIMAL
 652               (let ((*read-base* 10))
 653                 (read-from-string (get-cast-foreign-string data-ptr))))
 654              (t
 655               (case c-type
 656                 (#.$SQL_C_DATE
 657                  (funcall *time-conversion-function* (date-to-universal-time data-ptr)))
 658                 (#.$SQL_C_TIME
 659                  (multiple-value-bind (universal-time frac) (time-to-universal-time data-ptr)
 660                    (funcall *time-conversion-function* universal-time frac)))
 661                 (#.$SQL_C_TIMESTAMP
 662                  (multiple-value-bind (universal-time frac) (timestamp-to-universal-time data-ptr)
 663                    (funcall *time-conversion-function* universal-time frac)))
 664                 (#.$SQL_INTEGER
 665                  (get-cast-int data-ptr))
 666                 (#.$SQL_C_FLOAT
 667                  (get-cast-single-float data-ptr))
 668                 (#.$SQL_C_DOUBLE
 669                  (get-cast-double-float data-ptr))
 670                 (#.$SQL_C_SLONG
 671                  (get-cast-long data-ptr))
 672                 #+lispworks
 673                 (#.$SQL_C_BIT ; encountered only in Access
 674                  (get-cast-byte data-ptr))
 675                 (#.$SQL_C_BINARY
 676                  (get-cast-binary data-ptr out-len *binary-format*))
 677                 ((#.$SQL_C_SSHORT #.$SQL_C_STINYINT) ; LMH short ints
 678                  (get-cast-short data-ptr))     ; LMH
 679                 #+ignore
 680                 (#.$SQL_C_CHAR
 681                  (code-char (get-cast-short data-ptr)))
 682                 (t
 683                  (convert-from-foreign-string data-ptr)))))))))
 684
 685 ;; which value is appropriate?
 686 (defparameter +max-precision+
 687   #+mcl 512
 688   #-mcl 4001)
 689
 690 (defvar *break-on-unknown-data-type* t)
 691
 692 ;; C. Stacy's idea to factor this out
 693 ;; "Make it easy to add new datatypes by making new subroutine %ALLOCATE-BINDINGS,
 694 ;; so that I don't have to remember to make changes in more than one place.
 695 ;; Just keep it in synch with READ-DATA."
 696 (defun %allocate-bindings (sql-type precision)
 697   (let* ((c-type (sql-to-c-type sql-type))
 698          (size (if (zerop precision)
 699                    +max-precision+ ;; if the precision cannot be determined
 700                  (min precision +max-precision+)))
 701          (long-p (= size +max-precision+))
 702          (data-ptr
 703           (case c-type ;; add more?
 704             (#.$SQL_C_SLONG (uffi:allocate-foreign-object :long))
 705             (#.$SQL_C_DOUBLE (uffi:allocate-foreign-object :double))
 706             (#.$SQL_C_DATE (allocate-foreign-object 'sql-c-date))
 707             (#.$SQL_C_TIME (allocate-foreign-object 'sql-c-time))
 708             (#.$SQL_C_TIMESTAMP (allocate-foreign-object 'sql-c-timestamp))
 709             #+lispworks(#.$SQL_C_FLOAT (uffi:allocate-foreign-object :float))
 710             (#.$SQL_C_BIT (uffi:allocate-foreign-object :boolean))
 711             (#.$SQL_C_STINYINT (uffi:allocate-foreign-object :byte))
 712             (#.$SQL_C_SSHORT (uffi:allocate-foreign-object :short))
 713             (#.$SQL_C_CHAR (uffi:allocate-foreign-string (1+ size)))
 714             (#.$SQL_C_BINARY (uffi:allocate-foreign-string (1+ (* 2 size))))
 715             (t
 716                 ;; Maybe should signal a restartable condition for this?
 717                 (when *break-on-unknown-data-type*
 718                   (break "SQL type is ~A, precision ~D, size ~D, C type is ~A"
 719                          sql-type precision size c-type))
 720                 (uffi:allocate-foreign-object :ptr (1+ size)))))
 721          (out-len-ptr (uffi:allocate-foreign-object :long)))
 722     (values c-type data-ptr out-len-ptr size long-p)))
 723
 724 (defun fetch-all-rows (hstmt &key free-option flatp)
 725   (let ((column-count (result-columns-count hstmt)))
 726     (unless (zerop column-count)
 727       (let ((names (make-array column-count :element-type 'string))
 728             (sql-types (make-array column-count :element-type 'fixnum))
 729             (c-types (make-array column-count :element-type 'fixnum))
 730             (precisions (make-array column-count :element-type 'fixnum))
 731             (data-ptrs (make-array column-count :initial-element nil))
 732             (out-len-ptrs (make-array column-count :initial-element nil))
 733             (scales (make-array column-count :element-type 'fixnum))
 734             (nullables-p (make-array column-count :element-type 'fixnum)))
 735         (unwind-protect
 736           (values
 737            (progn
 738              (dotimes (col-nr column-count)
 739                ;; get column information
 740                (multiple-value-bind (name sql-type precision scale nullable-p)
 741                                     (%describe-column hstmt (1+ col-nr))
 742                  ;; allocate space to bind result rows to
 743                  (multiple-value-bind (c-type data-ptr out-len-ptr)
 744                      (%allocate-bindings sql-type precision)
 745                    (%bind-column hstmt col-nr c-type data-ptr (1+ precision) out-len-ptr)
 746                    (setf (svref names col-nr) name
 747                          (aref sql-types col-nr) sql-type
 748                          (aref c-types col-nr) (sql-to-c-type sql-type)
 749                          (aref precisions col-nr) (if (zerop precision) nil precision)
 750                          (aref scales col-nr) scale
 751                          (aref nullables-p col-nr) nullable-p
 752                          (aref data-ptrs col-nr) data-ptr
 753                          (aref out-len-ptrs col-nr) out-len-ptr))))
 754              ;; the main loop
 755              (prog1
 756                (cond (flatp
 757                       (when (> column-count 1)
 758                         (error "If more than one column is to be fetched, flatp has to be nil."))
 759                       (loop until (= (%sql-fetch hstmt) $SQL_NO_DATA_FOUND)
 760                             collect
 761                             (read-data (aref data-ptrs 0)
 762                                        (aref c-types 0)
 763                                        (aref sql-types 0)
 764                                        (aref out-len-ptrs 0)
 765                                        nil)))
 766                      (t
 767                       (loop until (= (%sql-fetch hstmt) $SQL_NO_DATA_FOUND)
 768                             collect
 769                             (loop for col-nr from 0 to (1- column-count)
 770                                   collect
 771                                   (read-data (aref data-ptrs col-nr)
 772                                              (aref c-types col-nr)
 773                                              (aref sql-types col-nr)
 774                                              (aref out-len-ptrs col-nr)
 775                                              nil)))))))
 776            names)
 777           ;; dispose of memory etc
 778           (when free-option (%free-statement hstmt free-option))
 779           (dotimes (col-nr column-count)
 780             (let ((data-ptr (aref data-ptrs col-nr))
 781                   (out-len-ptr (aref out-len-ptrs col-nr)))
 782               (when data-ptr (free-foreign-object data-ptr)) ; we *did* allocate them
 783               (when out-len-ptr (free-foreign-object out-len-ptr)))))))))
 784
 785 ;; to do: factor out common parts, put the sceleton (the obligatory macro part)
 786 ;; of %do-fetch into sql package (has been done)
 787
 788 (defun %sql-prepare (hstmt sql)
 789   (with-cstring (sql-ptr sql)
 790     (with-error-handling (:hstmt hstmt)
 791       (SQLPrepare hstmt sql-ptr $SQL_NTS))))
 792
 793 ;; depending on option, we return a long int or a string; string not implemented
 794 (defun get-connection-option (hdbc option)
 795   (with-foreign-objects ((param-ptr :long #+ignore #.(1+ $SQL_MAX_OPTION_STRING_LENGTH)))
 796     (with-error-handling (:hdbc hdbc)
 797                          (SQLGetConnectOption hdbc option param-ptr)
 798       (deref-pointer param-ptr :long))))
 799
 800 (defun set-connection-option (hdbc option param)
 801   (with-error-handling (:hdbc hdbc)
 802     (SQLSetConnectOption hdbc option param)))
 803
 804 (defun disable-autocommit (hdbc)
 805   (set-connection-option hdbc $SQL_AUTOCOMMIT $SQL_AUTOCOMMIT_OFF))
 806
 807 (defun enable-autocommit (hdbc)
 808   (set-connection-option hdbc $SQL_AUTOCOMMIT $SQL_AUTOCOMMIT_ON))
 809
 810 (defun %sql-set-pos (hstmt row option lock)
 811   (with-error-handling
 812     (:hstmt hstmt)
 813     (SQLSetPos hstmt row option lock)))
 814
 815 (defun %sql-extended-fetch (hstmt fetch-type row)
 816   (with-foreign-objects ((row-count-ptr :unsigned-long)
 817                          (row-status-ptr :short))
 818     (with-error-handling (:hstmt hstmt)
 819       (SQLExtendedFetch hstmt fetch-type row row-count-ptr
 820                         row-status-ptr)
 821       (values (deref-pointer row-count-ptr :unsigned-long)
 822               (deref-pointer row-status-ptr :short)))))
 823
 824 ; column-nr is zero-based
 825 (defun %sql-get-data (hstmt column-nr c-type data-ptr precision out-len-ptr)
 826   (with-error-handling
 827     (:hstmt hstmt :print-info nil)
 828     (SQLGetData hstmt (if (eq column-nr :bookmark) 0 (1+ column-nr))
 829                 c-type data-ptr precision out-len-ptr)))
 830
 831 (defun %sql-param-data (hstmt param-ptr)
 832   (with-error-handling (:hstmt hstmt :print-info t) ;; nil
 833       (SQLParamData hstmt param-ptr)))
 834
 835 (defun %sql-put-data (hstmt data-ptr size)
 836   (with-error-handling
 837     (:hstmt hstmt :print-info t) ;; nil
 838     (SQLPutData hstmt data-ptr size)))
 839
 840 (defconstant $sql-data-truncated (intern "01004" :keyword))
 841
 842 (defun read-data-in-chunks (hstmt column-nr data-ptr c-type sql-type
 843                                       out-len-ptr convert-to-string-p)
 844   (declare (ignore convert-to-string-p) ; prelimianary
 845            (type long-ptr-type out-len-ptr))
 846   (let* ((res (%sql-get-data hstmt column-nr c-type data-ptr
 847                              +max-precision+ out-len-ptr))
 848          (out-len (deref-pointer out-len-ptr :long))
 849          (offset 0))
 850     (case out-len
 851       (#.$SQL_NULL_DATA
 852        (return-from read-data-in-chunks *null*))
 853       (#.$SQL_NO_TOTAL ;; don't know how long it is going to be
 854        (let ((str (make-array 0 :element-type 'character :adjustable t)))
 855          (loop do (if (= c-type #.$SQL_CHAR)
 856                       (let ((data-length (foreign-string-length data-ptr)))
 857                         (adjust-array str (+ offset data-length)
 858                                       :initial-element #\?)
 859                         (setf offset (%cstring-into-vector
 860                                       data-ptr str
 861                                       offset
 862                                       data-length)))
 863                     (error "wrong type. preliminary."))
 864                while (and (= res $SQL_SUCCESS_WITH_INFO)
 865                           (equal (sql-state (%null-ptr) (%null-ptr) hstmt)
 866                                  "01004"))
 867                do (setf res (%sql-get-data hstmt column-nr c-type data-ptr
 868                                            +max-precision+ out-len-ptr)))
 869          (setf str (coerce str 'string))
 870          (if (= sql-type $SQL_DECIMAL)
 871              (let ((*read-base* 10))
 872                (read-from-string str))
 873            str)))
 874       (otherwise
 875        (let ((str (make-string out-len)))
 876          (loop do (if (= c-type #.$SQL_CHAR)
 877                       (setf offset (%cstring-into-vector ;string
 878                                     data-ptr str
 879                                     offset
 880                                     (min out-len (1- +max-precision+))))
 881                     (error "wrong type. preliminary."))
 882                while
 883                (and (= res $SQL_SUCCESS_WITH_INFO)
 884                     #+ingore(eq (sql-state (%null-ptr) (%null-ptr) hstmt)
 885                                 $sql-data-truncated)
 886                     (equal (sql-state (%null-ptr) (%null-ptr) hstmt)
 887                            "01004"))
 888                do (setf res (%sql-get-data hstmt column-nr c-type data-ptr
 889                                            +max-precision+ out-len-ptr)
 890                         out-len (deref-pointer out-len-ptr :long)))
 891          (if (= sql-type $SQL_DECIMAL)
 892              (let ((*read-base* 10))
 893                (read-from-string str))
 894            str))))))
 895
 896 (defun timestamp-to-universal-time (ptr)
 897   (values
 898    (encode-universal-time
 899     (get-slot-value ptr 'sql-c-timestamp 'second)
 900     (get-slot-value ptr 'sql-c-timestamp 'minute)
 901     (get-slot-value ptr 'sql-c-timestamp 'hour)
 902     (get-slot-value ptr 'sql-c-timestamp 'day)
 903     (get-slot-value ptr 'sql-c-timestamp 'month)
 904     (get-slot-value ptr 'sql-c-timestamp 'year))
 905    (get-slot-value ptr 'sql-c-timestamp 'fraction)))
 906
 907 (defun universal-time-to-timestamp (time &optional (fraction 0))
 908   (multiple-value-bind (sec min hour day month year)
 909       (decode-universal-time time)
 910     (with-foreign-object (ptr 'sql-c-timestamp)
 911       (setf (get-slot-value ptr 'sql-c-timestamp 'second) sec
 912             (get-slot-value ptr 'sql-c-timestamp 'minute) min
 913             (get-slot-value ptr 'sql-c-timestamp 'hour) hour
 914             (get-slot-value ptr 'sql-c-timestamp 'day) day
 915             (get-slot-value ptr 'sql-c-timestamp 'month) month
 916             (get-slot-value ptr 'sql-c-timestamp 'year) year
 917             (get-slot-value ptr 'sql-c-timestamp 'fraction) fraction)
 918       ptr)))
 919
 920 (defun %put-timestamp (ptr time &optional (fraction 0))
 921   (multiple-value-bind (sec min hour day month year)
 922       (decode-universal-time time)
 923     (setf (get-slot-value ptr 'sql-c-timestamp 'second) sec
 924           (get-slot-value ptr 'sql-c-timestamp 'minute) min
 925           (get-slot-value ptr 'sql-c-timestamp 'hour) hour
 926           (get-slot-value ptr 'sql-c-timestamp 'day) day
 927           (get-slot-value ptr 'sql-c-timestamp 'month) month
 928           (get-slot-value ptr 'sql-c-timestamp 'year) year
 929           (get-slot-value ptr 'sql-c-timestamp 'fraction) fraction)
 930       ptr))
 931
 932 (defun date-to-universal-time (ptr)
 933   (encode-universal-time
 934    0 0 0
 935    (get-slot-value ptr 'sql-c-timestamp 'day)
 936    (get-slot-value ptr 'sql-c-timestamp 'month)
 937    (get-slot-value ptr 'sql-c-timestamp 'year)))
 938
 939 (defun time-to-universal-time (ptr)
 940   (encode-universal-time
 941    (get-slot-value ptr 'sql-c-timestamp 'second)
 942    (get-slot-value ptr 'sql-c-timestamp 'minute)
 943    (get-slot-value ptr 'sql-c-timestamp 'hour)
 944    0 0 0))