/usr/share/common-lisp/source/clsql-odbc/db-odbc/odbc-dbi.lisp is in cl-sql-odbc 6.7.0-1.1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: odbc-dbi.cl
;;;; Purpose: Mid-level (DBI) interface for CLSQL ODBC backend
;;;; Author: Kevin M. Rosenberg
;;;; Create: April 2004
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; 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 #:cl-user)
(defpackage #:odbc-dbi
(:use #:cl #:odbc)
(:export
#:bind-parameter
#:close-query
#:connect
#:db-external-format
#:db-hstmt
#:db-width
#:disconnect
#:end-transaction
#:fetch-row
#:list-all-data-sources
#:list-all-database-tables
#:list-all-table-columns
#:list-table-indexes
#:loop-over-results
#:prepare-sql
#:rr-sql
#:run-prepared-sql
#:set-autocommit
#:sql
#:*auto-trim-strings*
#:*default-database*
#:*default-odbc-external-format*
#:*null-value*
)
(:documentation "This is the mid-level interface ODBC."))
(in-package #:odbc-dbi)
(defgeneric terminate (src))
(defgeneric db-open-query (src query-expression
&key arglen col-positions result-types width
&allow-other-keys))
(defgeneric db-fetch-query-results (src &optional count))
(defgeneric %db-execute (src sql-expression &key &allow-other-keys))
(defgeneric db-execute-command (src sql-string))
(defgeneric %initialize-query (src arglen col-positions
&key result-types width))
(defgeneric %read-query-data (src ignore-columns))
(defgeneric db-map-query (src type function query-exp &key result-types))
(defgeneric db-prepare-statement (src sql &key parameter-table
parameter-columns))
(defgeneric get-odbc-info (src info-type))
(defvar *reuse-query-objects* t)
;;; SQL Interface
(defclass odbc-db ()
(;; any reason to have more than one henv?
(width :initform +max-precision+ :accessor db-width)
(hstmt :initform nil :accessor db-hstmt)
(henv :initform nil :allocation :class :initarg :henv :accessor henv)
(hdbc :initform nil :initarg :hdbc :accessor hdbc)
;; info returned from SQLGetInfo
(info :initform (make-hash-table) :reader db-info)
(type :initform nil :initarg :db-type :reader db-type)
(connected-p :initform nil :accessor db-connected-p)
;; not used yet
(count :initform 0 :initarg :count :accessor db-count)
;; not used yet
(total-count :initform 0 :allocation :class :accessor db-total-count)
;; the use of this slot is deprecated; it will be removed when dtf works without it.
(query :initform nil :accessor db-query-object)
;; resource of (active and inactive) query objects
(queries :initform () :accessor db-queries)))
(defclass odbc-query ()
((hstmt :initform nil :initarg :hstmt :accessor hstmt) ; = cursor??
(width :initform +max-precision+ :accessor query-width)
(computed-result-types :initform nil :initarg :computed-result-types :accessor computed-result-types)
(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 'integer :adjustable t :fill-pointer t)
:accessor column-precisions)
(column-scales :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
:accessor column-scales)
(column-nullables-p :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
:accessor column-nullables-p)
;;(parameter-count :initform 0 :accessor parameter-count)
(parameter-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t)
:accessor parameter-ptrs)
;; a query string or a query expression object
(sql-expression :initform nil :initarg :sql-expression :accessor sql-expression)
;; database object the query is to be run against
(database :initarg :database :reader query-database)
(active-p :initform nil :initarg :active-p :accessor query-active-p))
(:documentation
"Stores query information, like SQL query string/expression and database to run
the query against." ))
;;; AODBC Compatible interface
(defun connect (&key data-source-name user password connection-string completion window-handle (autocommit t))
(let ((db (make-instance 'odbc-db)))
(unless (henv db) ;; has class allocation!
(setf (henv db) (%new-environment-handle)))
(setf (hdbc db) (%new-db-connection-handle (henv db)))
(if connection-string
(%sql-driver-connect (hdbc db)
connection-string
(ecase completion
(:no-prompt odbc::$SQL_DRIVER_NOPROMPT)
(:complete odbc::$SQL_DRIVER_COMPLETE)
(:prompt odbc::$SQL_DRIVER_PROMPT)
(:complete-required odbc::$SQL_DRIVER_COMPLETE_REQUIRED))
window-handle)
(%sql-connect (hdbc db) data-source-name user password))
#+ignore (setf (db-hstmt db) (%new-statement-handle (hdbc db)))
(when (/= (get-odbc-info db odbc::$SQL_TXN_CAPABLE) odbc::$SQL_TC_NONE)
(if autocommit
(enable-autocommit (hdbc db))
(disable-autocommit (hdbc db))))
db))
(defun disconnect (database)
"This is set in the generic-odbc-database disconnect-fn slot so xref fails
but this does get called on generic ODBC connections "
(with-slots (hdbc queries) database
(dolist (query queries)
(db-close-query query :drop-p T))
(when (db-hstmt database)
(%free-statement (db-hstmt database) :drop))
(%disconnect hdbc)))
(defun sql (expr &key db result-types row-count (column-names t) query
hstmt width)
(declare (ignore hstmt))
(cond
(query
(let ((q (db-open-query db expr :result-types result-types :width width)))
(if column-names
(values q (column-names q))
q)))
(t
(multiple-value-bind (data col-names)
(db-query db expr :result-types result-types :width width)
(cond
(row-count
(if (consp data) (length data) data))
(column-names
(values data col-names))
(t
data))))))
(defun fetch-row (query &optional (eof-errorp t) eof-value)
(multiple-value-bind (row query count) (db-fetch-query-results query 1)
(cond
((zerop count)
(close-query query)
(when eof-errorp
(error 'clsql:sql-database-data-error
:message "ODBC: Ran out of data in fetch-row"))
eof-value)
(t
(car row)))))
(defun close-query (query)
(db-close-query query))
(defun list-all-database-tables (&key db hstmt)
(declare (ignore hstmt))
(let ((query (get-free-query db)))
(unwind-protect
(progn
(with-slots (hstmt) query
(unless hstmt (setf hstmt (%new-statement-handle (hdbc db))))
(%list-tables hstmt)
(%initialize-query query nil nil)
(values
(db-fetch-query-results query)
(coerce (column-names query) 'list))))
(db-close-query query))))
(defun list-table-indexes (table &key db unique hstmt
&aux (table
(princ-to-string
(clsql-sys::unescaped-database-identifier table))))
(declare (ignore hstmt))
(let ((query (get-free-query db)))
(unwind-protect
(progn
(with-slots (hstmt) query
(unless hstmt
(setf hstmt (%new-statement-handle (hdbc db))))
(%table-statistics table hstmt :unique unique)
(%initialize-query query nil nil)
(values
(db-fetch-query-results query)
(coerce (column-names query) 'list))))
(db-close-query query))))
(defun list-all-table-columns (table &key db hstmt
&aux (table
(princ-to-string
(clsql-sys::unescaped-database-identifier table))))
(declare (ignore hstmt))
(db-describe-columns db nil nil table nil)) ;; use nil rather than "" for unspecified values
(defun list-all-data-sources ()
(let ((db (make-instance 'odbc-db)))
(unless (henv db) ;; has class allocation!
(setf (henv db) (%new-environment-handle)))
(%list-data-sources (henv db))))
(defun rr-sql (hstmt sql-statement &key db)
(declare (ignore hstmt sql-statement db))
(warn "rr-sql not implemented."))
;;; Mid-level interface
(defun db-commit (database)
(%commit (henv database) (hdbc database)))
(defun db-rollback (database)
(%rollback (henv database) (hdbc database)))
(defun db-cancel-query (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 nil nil)
(setf active-p t)))))
;; one for odbc-db is missing
;; TODO: Seems to be uncalled
(defmethod terminate ((query odbc-query))
;;(format tb::*local-output* "~%*** terminated: ~s" query)
(db-close-query query))
(defun %dispose-column-ptrs (query)
"frees memory allocated for query object column-data and column-data-length"
(with-slots (column-data-ptrs column-out-len-ptrs hstmt) query
(loop for data-ptr across column-data-ptrs
for out-len-ptr across column-out-len-ptrs
when data-ptr
do (uffi:free-foreign-object data-ptr)
when out-len-ptr
do (uffi:free-foreign-object out-len-ptr))
(setf (fill-pointer column-data-ptrs) 0
(fill-pointer column-out-len-ptrs) 0)))
(defmethod db-open-query ((database odbc-db) query-expression
&key arglen col-positions result-types width
&allow-other-keys)
(db-open-query (get-free-query database) query-expression
:arglen arglen :col-positions col-positions
:result-types result-types
:width (if width width (db-width database))))
(defmethod db-open-query ((query odbc-query) query-expression
&key arglen col-positions result-types width
&allow-other-keys)
(%db-execute query query-expression)
(%initialize-query query arglen col-positions :result-types result-types
:width width))
(defmethod db-fetch-query-results ((database odbc-db) &optional count)
(db-fetch-query-results (db-query-object database) count))
(defmethod db-fetch-query-results ((query odbc-query) &optional count)
(when (query-active-p query)
(with-slots (column-count column-data-ptrs column-c-types column-sql-types
column-out-len-ptrs column-precisions hstmt computed-result-types)
query
(let* ((rows-fetched 0)
(rows
(loop for i from 0
until (or (and count (= i count))
(= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND))
collect
(loop for result-type across computed-result-types
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
(progn
(incf rows-fetched)
(cond ((< 0 precision (query-width query))
(read-data data-ptr c-type sql-type out-len-ptr result-type))
((zerop (get-cast-long out-len-ptr))
nil)
(t
(read-data-in-chunks hstmt j data-ptr c-type sql-type
out-len-ptr result-type))))))))
(values rows query rows-fetched)))))
(defun db-query (database query-expression &key result-types width)
(let ((free-query (get-free-query database)))
(setf (sql-expression free-query) query-expression)
(unwind-protect
(progn
(%db-execute free-query query-expression)
(%initialize-query free-query nil nil :result-types result-types :width width)
(if (plusp (column-count free-query)) ;; KMR: Added check for commands that don't return columns
(values
(db-fetch-query-results free-query nil)
(map 'list #'identity (column-names free-query)))
(values
(result-rows-count (hstmt free-query))
nil)))
(db-close-query free-query)
)))
(defmethod %db-execute ((database odbc-db) sql-expression &key &allow-other-keys)
(%db-execute (get-free-query database) sql-expression))
(defmethod %db-execute ((query odbc-query) sql-expression &key &allow-other-keys)
(with-slots (henv hdbc) (odbc::query-database query)
(with-slots (hstmt) query
(unless hstmt (setf hstmt (%new-statement-handle hdbc)))
(setf (sql-expression query) sql-expression)
(%sql-exec-direct sql-expression hstmt henv hdbc)
query)))
;; reuse inactive queries
(defun get-free-query (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 hdbc) database
(or (and *reuse-query-objects*
(clsql-sys:without-interrupts
(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
width hstmt
column-sql-types column-data-ptrs
column-out-len-ptrs column-precisions
column-scales column-nullables-p)
inactive-query
(setf column-count 0
width +max-precision+
;; KMR hstmt (%new-statement-handle hdbc)
(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-db) sql-string)
(db-execute-command (get-free-query database) sql-string))
(defmethod db-execute-command ((query odbc-query) 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-db) arglen col-positions &key result-types width)
(%initialize-query (db-query-object database) arglen col-positions
:result-types result-types
:width (if width width (db-width database))))
(defmethod %initialize-query ((query odbc-query) arglen col-positions &key result-types width)
(with-slots (hstmt computed-result-types
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)))
(when width (setf (query-width query) width))
;;(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)
(if long-p ;; if long-p we fetch in chunks with %sql-get-data but must ensure that out_len_ptr is non zero
(setf (uffi:deref-pointer out-len-ptr #.odbc::$ODBC-LONG-TYPE) #.odbc::$SQL_NO_TOTAL)
(%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))))
;; TODO: move this into the above loop
(setf computed-result-types (make-array column-count))
(dotimes (i column-count)
(setf (aref computed-result-types i)
(cond
((consp result-types)
(nth i result-types))
((eq result-types :auto)
(case (aref column-c-types i)
(#.odbc::$SQL_C_SLONG :int)
(#.odbc::$SQL_C_DOUBLE :double)
(#.odbc::$SQL_C_FLOAT :float)
(#.odbc::$SQL_C_SSHORT :short)
(#.odbc::$SQL_C_STINYINT :short)
(#.odbc::$SQL_C_SBIGINT #.odbc::$ODBC-BIG-TYPE)
(#.odbc::$SQL_C_TYPE_TIMESTAMP :time)
(#.odbc::$SQL_C_CHAR ;; TODO: Read this as rational instead of double
(or (case (aref column-sql-types i)
((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL) :double))
T))
(t t)))
(t t)))))
query)
(defun db-close-query (query &key (drop-p (not *reuse-query-objects*)))
(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 database) query
(%dispose-column-ptrs query)
(cond ((null hstmt) nil)
(drop-p
(%free-statement hstmt :drop)
;; dont free with uffi/ this is a double free and crashes everything
;; (uffi:free-foreign-object hstmt)
(setf hstmt nil))
(t
(%free-statement hstmt :unbind)
(%free-statement hstmt :reset)
(%free-statement hstmt :close)))
(setf (query-active-p query) nil)
(when drop-p
(clsql-sys:without-interrupts
(with-slots (queries) database
(setf queries (remove query queries))))))
query)
(defmethod %read-query-data ((database odbc-db) ignore-columns)
(%read-query-data (db-query-object database) ignore-columns))
(defmethod %read-query-data ((query odbc-query) ignore-columns)
(with-slots (hstmt column-count column-c-types column-sql-types
column-data-ptrs column-out-len-ptrs column-precisions
computed-result-types)
query
(unless (= (odbc::SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND)
(values
(loop for col-nr from 0 to (- column-count
(if (eq ignore-columns :last) 2 1))
for result-type across computed-result-types
collect
(let ((precision (aref column-precisions col-nr))
(sql-type (aref column-sql-types col-nr)))
(cond ((or (< 0 precision (query-width query))
(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)
result-type))
((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)
result-type)))))
t))))
(defmethod db-map-query ((database odbc-db) type function query-exp &key result-types)
(db-map-query (get-free-query database) type function query-exp :result-types result-types))
(defmethod db-map-query ((query odbc-query) type function query-exp &key result-types)
(declare (ignore type)) ; preliminary. Do a type coersion here
(%db-execute query (sql-expression query-exp))
(unwind-protect
(progn
(%initialize-query query nil nil :result-types result-types)
;; 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)))
(defun db-map-bind-query (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) :string) ; ??
(#.odbc::$SQL_BIGINT #.odbc::$ODBC-BIG-TYPE)
(#.odbc::$SQL_INTEGER #.odbc::$ODBC-LONG-TYPE)
(#.odbc::$SQL_SMALLINT :short)
((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) #.odbc::$ODBC-LONG-TYPE)
(#.odbc::$SQL_REAL #.odbc::$ODBC-LONG-TYPE)
((#.odbc::$SQL_DATE #.odbc::$SQL_TYPE_DATE) 'sql-c-date)
((#.odbc::$SQL_TIME #.odbc::$SQL_TYPE_TIME) 'sql-c-time)
((#.odbc::$SQL_TIMESTAMP #.odbc::$SQL_TYPE_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_BIT :short)
((#.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) :binary)
))
;; prepared queries
(defmethod db-prepare-statement ((database odbc-db) 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-table :parameter-columns 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 'clsql:sql-database-error
(format nil
"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 nil nil)
(with-slots (hstmt) query
(%free-statement hstmt :unbind)
(%free-statement hstmt :reset)
(setf (sql-expression query) sql)
(%sql-prepare hstmt sql))
query)
(defun %db-bind-execute (query &rest parameters)
"Only used from db-map-bind-query
parameters are released in %reset-query
"
(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
(query-width query) ;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)))
(defun %db-reset-query (query)
"Only used from db-map-bind-query
parameters are allocated in %db-bind-execute
"
(with-slots (hstmt parameter-data-ptrs) query
(prog1
(db-fetch-query-results query 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
(defun db-describe-columns (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-db) 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 inquiry
;; How does this differ from list-data-sources?
(defgeneric db-data-sources (db-type))
(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))))
|