1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: odbc -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: odbc-api.lisp
6 ;;;; Purpose: Low-level ODBC API using UFFI
7 ;;;; Authors: Kevin M. Rosenberg and Paul Meurer
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.
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 ;;;; *************************************************************************
22 "Lisp representation of SQL Null value, default = nil.
23 May be locally bound to something else if a certain type is necessary.")
26 (defvar *binary-format
* :unsigned-byte-vector
)
27 (defvar *time-conversion-function
*
28 (lambda (universal-time &optional fraction
)
29 (declare (ignore fraction
))
30 (clsql-sys:format-time
31 nil
(clsql-sys:utime-
>time universal-time
)
35 "Bound to a function that converts from a Lisp universal time fixnum (and a fractional
36 as possible second argument) to the desired representation of date/time/timestamp. By default, returns an iso-timestring.")
38 (defvar +null-ptr
+ (make-null-pointer :byte
))
39 (defparameter +null-handle-ptr
+ (make-null-pointer :void
))
40 (defvar *info-output
* nil
41 "Stream to send SUCCESS_WITH_INFO messages.")
43 (defmacro %put-str
(ptr string
&optional max-length
)
44 (let ((size (gensym)))
45 `(let ((,size
(length ,string
)))
46 (when (and ,max-length
(> ,size
,max-length
))
47 (error 'clsql
:sql-database-data-error
49 (format nil
"string \"~a\" of length ~d is longer than max-length: ~d"
50 ,string
,size
,max-length
)))
51 (with-cast-pointer (char-ptr ,ptr
:byte
)
53 (setf (deref-array char-ptr
'(:array
:byte
) i
)
54 (char-code (char ,string i
))))
55 (setf (deref-array char-ptr
'(:array
:byte
) ,size
) 0)))))
57 (defun %cstring-into-vector
(ptr vector offset size-in-bytes
)
58 (dotimes (i size-in-bytes
)
59 (setf (schar vector offset
)
60 (ensure-char-character
61 (deref-array ptr
'(:array
:unsigned-char
) i
)))
65 (defun handle-error (henv hdbc hstmt
)
66 (let ((sql-state (allocate-foreign-string 256))
67 (error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH
)))
68 (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE
)
70 (SQLError henv hdbc hstmt sql-state
71 error-code error-message
72 #.$SQL_MAX_MESSAGE_LENGTH msg-length
)
73 (let ((err (convert-from-foreign-string error-message
))
74 (state (convert-from-foreign-string sql-state
)))
75 (free-foreign-object error-message
)
76 (free-foreign-object sql-state
)
80 (deref-pointer msg-length
:short
)
81 (deref-pointer error-code
#.$ODBC-LONG-TYPE
))))))
83 (defun sql-state (henv hdbc hstmt
)
84 (let ((sql-state (allocate-foreign-string 256))
85 (error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH
)))
86 (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE
)
88 (SQLError henv hdbc hstmt sql-state error-code
89 error-message
#.$SQL_MAX_MESSAGE_LENGTH msg-length
)
90 (let ((state (convert-from-foreign-string sql-state
)))
91 (free-foreign-object error-message
)
92 (free-foreign-object sql-state
)
94 ;; test this: return a keyword for efficiency
95 ;;(%cstring-to-keyword state)
98 (defmacro with-error-handling
((&key henv hdbc hstmt
(print-info t
))
100 (let ((result-code (gensym "RC-")))
101 `(let ((,result-code
,odbc-call
))
103 ;; Check for allegro v7 & v8 bug with ODBC calls returning
104 ;; 32-bit unsigned ints, not 16-bit signed ints
105 #+(and allegro mswindows
)
106 (when (> ,result-code
#xFFFF
)
107 (warn (format nil
"16-bit return bug: result-code #x~X for expression ~S"
108 ,result-code
(quote ,odbc-call
)))
109 (setq ,result-code
(logand ,result-code
#xFFFF
))
110 (when (> ,result-code
#x7FFF
)
111 (setq ,result-code
(- ,result-code
#x10000
))))
115 (progn ,result-code
,@body
))
116 (#.$SQL_SUCCESS_WITH_INFO
118 (multiple-value-bind (error-message sql-state
)
119 (handle-error (or ,henv
+null-handle-ptr
+)
120 (or ,hdbc
+null-handle-ptr
+)
121 (or ,hstmt
+null-handle-ptr
+))
123 (format *info-output
* "[ODBC info ~A] ~A state: ~A"
124 ,result-code error-message
126 (progn ,result-code
,@body
))
127 (#.$SQL_INVALID_HANDLE
129 'clsql-sys
:sql-database-error
130 :message
"ODBC: Invalid handle"))
131 (#.$SQL_STILL_EXECUTING
133 'clsql-sys
:sql-temporary-error
134 :message
"ODBC: Still executing"))
136 (multiple-value-bind (error-message sql-state
)
137 (handle-error (or ,henv
+null-handle-ptr
+)
138 (or ,hdbc
+null-handle-ptr
+)
139 (or ,hstmt
+null-handle-ptr
+))
141 'clsql-sys
:sql-database-error
142 :message error-message
143 :secondary-error-id sql-state
)))
144 (#.$SQL_NO_DATA_FOUND
145 (progn ,result-code
,@body
))
146 ;; work-around for Allegro 7.0beta AMD64 which returns negative numbers
148 (multiple-value-bind (error-message sql-state
)
149 (handle-error (or ,henv
+null-handle-ptr
+)
150 (or ,hdbc
+null-handle-ptr
+)
151 (or ,hstmt
+null-handle-ptr
+))
153 'clsql-sys
:sql-database-error
154 :message error-message
155 :secondary-error-id sql-state
))
157 (progn ,result-code
,@body
))))))
159 (defun %new-environment-handle
()
161 (with-foreign-object (phenv 'sql-handle
)
164 (SQLAllocHandle $SQL_HANDLE_ENV
+null-handle-ptr
+ phenv
)
165 (deref-pointer phenv
'sql-handle
)))))
166 (%set-attr-odbc-version henv $SQL_OV_ODBC3
)
170 (defun %sql-free-environment
(henv)
175 (defun %new-db-connection-handle
(henv)
176 (with-foreign-object (phdbc 'sql-handle
)
177 (setf (deref-pointer phdbc
'sql-handle
) +null-handle-ptr
+)
180 (SQLAllocHandle $SQL_HANDLE_DBC henv phdbc
)
181 (deref-pointer phdbc
'sql-handle
))))
183 (defun %free-statement
(hstmt option
)
191 (:unbind $SQL_UNBIND
)
192 (:reset $SQL_RESET_PARAMS
)))))
194 (defmacro with-statement-handle
((hstmt hdbc
) &body body
)
195 `(let ((,hstmt
(%new-statement-handle
,hdbc
)))
198 (%free-statement
,hstmt
:drop
))))
200 ;; functional interface
202 (defun %sql-connect
(hdbc server uid pwd
)
203 (with-cstrings ((server-ptr server
)
208 (SQLConnect hdbc server-ptr $SQL_NTS uid-ptr
209 $SQL_NTS pwd-ptr $SQL_NTS
))))
211 (defun %sql-driver-connect
(hdbc connection-string completion window-handle
)
212 (with-cstring (connection-ptr connection-string
)
213 (let ((completed-connection-string (allocate-foreign-string $SQL_MAX_CONN_OUT
)))
215 (with-foreign-object (completed-connection-length :short
)
218 (SQLDriverConnect hdbc
220 connection-ptr $SQL_NTS
221 completed-connection-string $SQL_MAX_CONN_OUT
222 completed-connection-length
224 (free-foreign-object completed-connection-string
)))))
226 (defun %disconnect
(hdbc)
229 (SQLDisconnect hdbc
)))
231 (defun %commit
(henv hdbc
)
233 (:henv henv
:hdbc hdbc
)
235 henv hdbc $SQL_COMMIT
)))
237 (defun %rollback
(henv hdbc
)
239 (:henv henv
:hdbc hdbc
)
241 henv hdbc $SQL_ROLLBACK
)))
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
)
249 (if (eq column-nr
:bookmark
) 0 (1+ column-nr
))
250 c-type data-ptr precision out-len-ptr
)))
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
)
258 (SQLBindParameter hstmt
(1+ parameter-nr
)
259 parameter-type
;$SQL_PARAM_INPUT
261 sql-type
;$SQL_VARCHAR
262 precision
;(1- (length str))
266 out-len-ptr
;#.+null-ptr+
269 (defun %sql-fetch
(hstmt)
274 (defun %new-statement-handle
(hdbc)
275 (let ((statement-handle
276 (with-foreign-object (phstmt 'sql-handle
)
279 (SQLAllocHandle $SQL_HANDLE_STMT hdbc phstmt
)
280 (deref-pointer phstmt
'sql-handle
)))))
281 (if (uffi:null-pointer-p statement-handle
)
282 (error 'clsql
:sql-database-error
:message
"Received null statement handle.")
285 (defun %sql-get-info
(hdbc info-type
)
287 ;; those return string
288 ((#.$SQL_ACCESSIBLE_PROCEDURES
289 #.$SQL_ACCESSIBLE_TABLES
291 #.$SQL_DATA_SOURCE_NAME
292 #.$SQL_DATA_SOURCE_READ_ONLY
296 #.$SQL_DRIVER_ODBC_VER
298 #.$SQL_EXPRESSIONS_IN_ORDERBY
299 #.$SQL_IDENTIFIER_QUOTE_CHAR
301 #.$SQL_LIKE_ESCAPE_CLAUSE
302 #.$SQL_MAX_ROW_SIZE_INCLUDES_LONG
303 #.$SQL_MULT_RESULT_SETS
304 #.$SQL_MULTIPLE_ACTIVE_TXN
305 #.$SQL_NEED_LONG_DATA_LEN
306 #.$SQL_ODBC_SQL_OPT_IEF
308 #.$SQL_ORDER_BY_COLUMNS_IN_SELECT
311 #.$SQL_PROCEDURE_TERM
313 #.$SQL_QUALIFIER_NAME_SEPARATOR
314 #.$SQL_QUALIFIER_TERM
316 #.$SQL_SEARCH_PATTERN_ESCAPE
318 #.$SQL_SPECIAL_CHARACTERS
321 (let ((info-ptr (allocate-foreign-string 1024)))
322 (with-foreign-object (info-length-ptr :short
)
325 (SQLGetInfo hdbc info-type info-ptr
1023 info-length-ptr
)
326 (let ((info (convert-from-foreign-string info-ptr
)))
327 (free-foreign-object info-ptr
)
329 ;; those returning a word
330 ((#.$SQL_ACTIVE_CONNECTIONS
331 #.$SQL_ACTIVE_STATEMENTS
332 #.$SQL_CONCAT_NULL_BEHAVIOR
333 #.$SQL_CORRELATION_NAME
334 #.$SQL_CURSOR_COMMIT_BEHAVIOR
335 #.$SQL_CURSOR_ROLLBACK_BEHAVIOR
336 #.$SQL_MAX_COLUMN_NAME_LEN
337 #.$SQL_MAX_COLUMNS_IN_GROUP_BY
338 #.$SQL_MAX_COLUMNS_IN_INDEX
339 #.$SQL_MAX_COLUMNS_IN_ORDER_BY
340 #.$SQL_MAX_COLUMNS_IN_SELECT
341 #.$SQL_MAX_COLUMNS_IN_TABLE
342 #.$SQL_MAX_CURSOR_NAME_LEN
343 #.$SQL_MAX_OWNER_NAME_LEN
344 #.$SQL_MAX_PROCEDURE_NAME_LEN
345 #.$SQL_MAX_QUALIFIER_NAME_LEN
346 #.$SQL_MAX_TABLE_NAME_LEN
347 #.$SQL_MAX_TABLES_IN_SELECT
348 #.$SQL_MAX_USER_NAME_LEN
349 #.$SQL_NON_NULLABLE_COLUMNS
350 #.$SQL_NULL_COLLATION
351 #.$SQL_ODBC_API_CONFORMANCE
352 #.$SQL_ODBC_SAG_CLI_CONFORMANCE
353 #.$SQL_ODBC_SQL_CONFORMANCE
354 #.$SQL_QUALIFIER_LOCATION
355 #.$SQL_QUOTED_IDENTIFIER_CASE
357 (with-foreign-objects ((info-ptr :short
)
358 (info-length-ptr :short
))
366 (deref-pointer info-ptr
:short
)))
368 ;; those returning a long bitmask
370 #.$SQL_BOOKMARK_PERSISTENCE
371 #.$SQL_CONVERT_BIGINT
372 #.$SQL_CONVERT_BINARY
376 #.$SQL_CONVERT_DECIMAL
377 #.$SQL_CONVERT_DOUBLE
379 #.$SQL_CONVERT_INTEGER
380 #.$SQL_CONVERT_LONGVARCHAR
381 #.$SQL_CONVERT_NUMERIC
383 #.$SQL_CONVERT_SMALLINT
385 #.$SQL_CONVERT_TIMESTAMP
386 #.$SQL_CONVERT_TINYINT
387 #.$SQL_CONVERT_VARBINARY
388 #.$SQL_CONVERT_VARCHAR
389 #.$SQL_CONVERT_LONGVARBINARY
390 #.$SQL_CONVERT_FUNCTIONS
391 #.$SQL_FETCH_DIRECTION
393 #.$SQL_GETDATA_EXTENSIONS
395 #.$SQL_MAX_INDEX_SIZE
397 #.$SQL_MAX_STATEMENT_LEN
398 #.$SQL_NUMERIC_FUNCTIONS
400 #.$SQL_POS_OPERATIONS
401 #.$SQL_POSITIONED_STATEMENTS
402 #.$SQL_QUALIFIER_USAGE
403 #.$SQL_SCROLL_CONCURRENCY
404 #.$SQL_SCROLL_OPTIONS
405 #.$SQL_STATIC_SENSITIVITY
406 #.$SQL_STRING_FUNCTIONS
408 #.$SQL_SYSTEM_FUNCTIONS
409 #.$SQL_TIMEDATE_ADD_INTERVALS
410 #.$SQL_TIMEDATE_DIFF_INTERVALS
411 #.$SQL_TIMEDATE_FUNCTIONS
412 #.$SQL_TXN_ISOLATION_OPTION
414 (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE
)
415 (info-length-ptr :short
))
423 (deref-pointer info-ptr
#.$ODBC-LONG-TYPE
)))
425 ;; those returning a long integer
426 ((#.$SQL_DEFAULT_TXN_ISOLATION
432 #.$SQL_IDENTIFIER_CASE
433 #.$SQL_MAX_BINARY_LITERAL_LEN
434 #.$SQL_MAX_CHAR_LITERAL_LEN
435 #.$SQL_ACTIVE_ENVIRONMENTS
437 (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE
)
438 (info-length-ptr :short
))
441 (SQLGetInfo hdbc info-type info-ptr
255 info-length-ptr
)
442 (deref-pointer info-ptr
#.$ODBC-LONG-TYPE
))))))
444 (defun %sql-exec-direct
(sql hstmt henv hdbc
)
445 (with-cstring (sql-ptr sql
)
447 (:hstmt hstmt
:henv henv
:hdbc hdbc
)
448 (SQLExecDirect hstmt sql-ptr $SQL_NTS
))))
450 (defun %sql-cancel
(hstmt)
455 (defun %sql-execute
(hstmt)
460 (defun result-columns-count (hstmt)
461 (with-foreign-objects ((columns-nr-ptr :short
))
462 (with-error-handling (:hstmt hstmt
)
463 (SQLNumResultCols hstmt columns-nr-ptr
)
464 (deref-pointer columns-nr-ptr
:short
))))
466 (defun result-rows-count (hstmt)
467 (with-foreign-objects ((row-count-ptr #.$ODBC-LONG-TYPE
))
468 (with-error-handling (:hstmt hstmt
)
469 (SQLRowCount hstmt row-count-ptr
)
470 (deref-pointer row-count-ptr
#.$ODBC-LONG-TYPE
))))
472 ;; column counting is 1-based
473 (defun %describe-column
(hstmt column-nr
)
474 (let ((column-name-ptr (allocate-foreign-string 256)))
475 (with-foreign-objects ((column-name-length-ptr :short
)
476 (column-sql-type-ptr :short
)
477 (column-precision-ptr #.$ODBC-ULONG-TYPE
)
478 (column-scale-ptr :short
)
479 (column-nullable-p-ptr :short
))
480 (with-error-handling (:hstmt hstmt
)
481 (SQLDescribeCol hstmt column-nr column-name-ptr
256
482 column-name-length-ptr
486 column-nullable-p-ptr
)
487 (let ((column-name (convert-from-foreign-string column-name-ptr
)))
488 (free-foreign-object column-name-ptr
)
491 (deref-pointer column-sql-type-ptr
:short
)
492 (deref-pointer column-precision-ptr
#.$ODBC-ULONG-TYPE
)
493 (deref-pointer column-scale-ptr
:short
)
494 (deref-pointer column-nullable-p-ptr
:short
)))))))
496 ;; parameter counting is 1-based
497 (defun %describe-parameter
(hstmt parameter-nr
)
498 (with-foreign-objects ((column-sql-type-ptr :short
)
499 (column-precision-ptr #.$ODBC-ULONG-TYPE
)
500 (column-scale-ptr :short
)
501 (column-nullable-p-ptr :short
))
504 (SQLDescribeParam hstmt parameter-nr
508 column-nullable-p-ptr
)
510 (deref-pointer column-sql-type-ptr
:short
)
511 (deref-pointer column-precision-ptr
#.$ODBC-ULONG-TYPE
)
512 (deref-pointer column-scale-ptr
:short
)
513 (deref-pointer column-nullable-p-ptr
:short
)))))
515 (defun %column-attributes
(hstmt column-nr descriptor-type
)
516 (let ((descriptor-info-ptr (allocate-foreign-string 256)))
517 (with-foreign-objects ((descriptor-length-ptr :short
)
518 (numeric-descriptor-ptr #.$ODBC-LONG-TYPE
))
521 (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr
522 256 descriptor-length-ptr
523 numeric-descriptor-ptr
)
524 (let ((desc (convert-from-foreign-string descriptor-info-ptr
)))
525 (free-foreign-object descriptor-info-ptr
)
528 (deref-pointer numeric-descriptor-ptr
#.$ODBC-LONG-TYPE
)))))))
530 (defun %prepare-describe-columns
(hstmt table-qualifier table-owner
531 table-name column-name
)
532 (with-cstrings ((table-qualifier-ptr table-qualifier
)
533 (table-owner-ptr table-owner
)
534 (table-name-ptr table-name
)
535 (column-name-ptr column-name
))
539 table-qualifier-ptr
(length table-qualifier
)
540 table-owner-ptr
(length table-owner
)
541 table-name-ptr
(length table-name
)
542 column-name-ptr
(length column-name
)))))
544 (defun %describe-columns
(hdbc table-qualifier table-owner
545 table-name column-name
)
546 (with-statement-handle (hstmt hdbc
)
547 (%prepare-describe-columns hstmt table-qualifier table-owner
548 table-name column-name
)
549 (fetch-all-rows hstmt
)))
551 (defun %sql-data-sources
(henv &key
(direction :first
))
552 (let ((name-ptr (allocate-foreign-string (1+ $SQL_MAX_DSN_LENGTH
)))
553 (description-ptr (allocate-foreign-string 1024)))
554 (with-foreign-objects ((name-length-ptr :short
)
555 (description-length-ptr :short
))
556 (let ((res (with-error-handling
560 (:first $SQL_FETCH_FIRST
)
561 (:next $SQL_FETCH_NEXT
))
563 (1+ $SQL_MAX_DSN_LENGTH
)
567 description-length-ptr
))))
569 ((= res $SQL_NO_DATA_FOUND
)
570 (let ((name (convert-from-foreign-string name-ptr
))
571 (desc (convert-from-foreign-string description-ptr
)))
572 (free-foreign-object name-ptr
)
573 (free-foreign-object description-ptr
)
578 (free-foreign-object name-ptr
)
579 (free-foreign-object description-ptr
)
584 (defun sql-to-c-type (sql-type)
586 ((#.$SQL_CHAR
#.$SQL_VARCHAR
#.$SQL_LONGVARCHAR
587 #.$SQL_NUMERIC
#.$SQL_DECIMAL
#.$SQL_BIGINT -
8 -
9 -
10) $SQL_C_CHAR
) ;; Added -10 for MSSQL ntext type
588 (#.$SQL_INTEGER $SQL_C_SLONG
)
589 (#.$SQL_SMALLINT $SQL_C_SSHORT
)
590 (#.$SQL_DOUBLE $SQL_C_DOUBLE
)
591 (#.$SQL_FLOAT $SQL_C_DOUBLE
)
592 (#.$SQL_REAL $SQL_C_FLOAT
)
593 (#.$SQL_DATE $SQL_C_DATE
)
594 (#.$SQL_TIME $SQL_C_TIME
)
595 (#.$SQL_TIMESTAMP $SQL_C_TIMESTAMP
)
596 (#.$SQL_TYPE_DATE $SQL_C_TYPE_DATE
)
597 (#.$SQL_TYPE_TIME $SQL_C_TYPE_TIME
)
598 (#.$SQL_TYPE_TIMESTAMP $SQL_C_TYPE_TIMESTAMP
)
599 ((#.$SQL_BINARY
#.$SQL_VARBINARY
#.$SQL_LONGVARBINARY
) $SQL_C_BINARY
)
600 (#.$SQL_TINYINT $SQL_C_STINYINT
)
601 (#.$SQL_BIT $SQL_C_BIT
)))
603 (def-type byte-pointer-type
(* :byte
))
604 (def-type short-pointer-type
(* :short
))
605 (def-type int-pointer-type
(* :int
))
606 (def-type long-pointer-type
(* #.$ODBC-LONG-TYPE
))
607 (def-type float-pointer-type
(* :float
))
608 (def-type double-pointer-type
(* :double
))
609 (def-type string-pointer-type
(* :unsigned-char
))
611 (defun get-cast-byte (ptr)
612 (locally (declare (type byte-pointer-type ptr
))
613 (deref-pointer ptr
:byte
)))
615 (defun get-cast-short (ptr)
616 (locally (declare (type short-pointer-type ptr
))
617 (deref-pointer ptr
:short
)))
619 (defun get-cast-int (ptr)
620 (locally (declare (type int-pointer-type ptr
))
621 (deref-pointer ptr
:int
)))
623 (defun get-cast-long (ptr)
624 (locally (declare (type long-pointer-type ptr
))
625 (deref-pointer ptr
#.$ODBC-LONG-TYPE
)))
627 (defun get-cast-single-float (ptr)
628 (locally (declare (type float-pointer-type ptr
))
629 (deref-pointer ptr
:float
)))
631 (defun get-cast-double-float (ptr)
632 (locally (declare (type double-pointer-type ptr
))
633 (deref-pointer ptr
:double
)))
635 (defun get-cast-foreign-string (ptr)
636 (locally (declare (type string-pointer-type ptr
))
637 (convert-from-foreign-string ptr
)))
639 (defun get-cast-binary (ptr len format
)
640 "FORMAT is one of :unsigned-byte-vector, :bit-vector (:string, :hex-string)"
641 (with-cast-pointer (casted ptr
:byte
)
643 (:unsigned-byte-vector
644 (let ((vector (make-array len
:element-type
'(unsigned-byte 8))))
646 (setf (aref vector i
)
647 (deref-array casted
'(:array
:byte
) i
)))
650 (let ((vector (make-array (ash len
3) :element-type
'bit
)))
652 (let ((byte (deref-array casted
'(:array
:byte
) i
)))
654 (setf (bit vector
(+ (ash i
3) j
))
655 (logand (ash byte
(- j
7)) 1)))))
659 (defun read-data (data-ptr c-type sql-type out-len-ptr result-type
)
660 (declare (type long-ptr-type out-len-ptr
))
661 (let* ((out-len (deref-pointer out-len-ptr
#.$ODBC-LONG-TYPE
))
663 (cond ((= out-len $SQL_NULL_DATA
)
667 ;; SQL extended datatypes
668 (#.$SQL_TINYINT
(get-cast-byte data-ptr
))
669 (#.$SQL_C_STINYINT
(get-cast-byte data-ptr
)) ;; ?
670 (#.$SQL_C_SSHORT
(get-cast-short data-ptr
)) ;; ?
671 (#.$SQL_SMALLINT
(get-cast-short data-ptr
)) ;; ??
672 (#.$SQL_INTEGER
(get-cast-int data-ptr
))
673 (#.$SQL_BIGINT
(read-from-string
674 (get-cast-foreign-string data-ptr
)))
676 (let ((*read-base
* 10))
677 (read-from-string (get-cast-foreign-string data-ptr
))))
678 (#.$SQL_BIT
(get-cast-byte data-ptr
))
681 ((#.$SQL_C_DATE
#.$SQL_C_TYPE_DATE
)
682 (funcall *time-conversion-function
* (date-to-universal-time data-ptr
)))
683 ((#.$SQL_C_TIME
#.$SQL_C_TYPE_TIME
)
684 (multiple-value-bind (universal-time frac
) (time-to-universal-time data-ptr
)
685 (funcall *time-conversion-function
* universal-time frac
)))
686 ((#.$SQL_C_TIMESTAMP
#.$SQL_C_TYPE_TIMESTAMP
)
687 (multiple-value-bind (universal-time frac
) (timestamp-to-universal-time data-ptr
)
688 (funcall *time-conversion-function
* universal-time frac
)))
690 (get-cast-int data-ptr
))
692 (get-cast-single-float data-ptr
))
694 (get-cast-double-float data-ptr
))
696 (get-cast-long data-ptr
))
698 (#.$SQL_C_BIT
; encountered only in Access
699 (get-cast-byte data-ptr
))
701 (get-cast-binary data-ptr out-len
*binary-format
*))
702 ((#.$SQL_C_SSHORT
#.$SQL_C_STINYINT
) ; LMH short ints
703 (get-cast-short data-ptr
)) ; LMH
706 (code-char (get-cast-short data-ptr
)))
708 (get-cast-foreign-string data-ptr
)))))))))
710 ;; FIXME: this could be better optimized for types which use READ-FROM-STRING above
712 (if (and (or (eq result-type t
) (eq result-type
:string
))
714 (not (stringp value
)))
715 (write-to-string value
)
718 ;; which value is appropriate?
719 (defparameter +max-precision
+ 4001)
721 (defvar *break-on-unknown-data-type
* t
)
723 ;; C. Stacy's idea to factor this out
724 ;; "Make it easy to add new datatypes by making new subroutine %ALLOCATE-BINDINGS,
725 ;; so that I don't have to remember to make changes in more than one place.
726 ;; Just keep it in synch with READ-DATA."
727 (defun %allocate-bindings
(sql-type precision
)
728 (let* ((c-type (sql-to-c-type sql-type
))
729 (size (if (zerop precision
)
730 +max-precision
+ ;; if the precision cannot be determined
731 (min precision
+max-precision
+)))
732 (long-p (= size
+max-precision
+))
734 (case c-type
;; add more?
735 (#.$SQL_C_SLONG
(uffi:allocate-foreign-object
#.$ODBC-LONG-TYPE
))
736 ((#.$SQL_C_DATE
#.$SQL_C_TYPE_DATE
) (allocate-foreign-object 'sql-c-date
))
737 ((#.$SQL_C_TIME
#.$SQL_C_TYPE_TIME
) (allocate-foreign-object 'sql-c-time
))
738 ((#.$SQL_C_TIMESTAMP
#.$SQL_C_TYPE_TIMESTAMP
) (allocate-foreign-object 'sql-c-timestamp
))
739 (#.$SQL_C_FLOAT
(uffi:allocate-foreign-object
:float
))
740 (#.$SQL_C_DOUBLE
(uffi:allocate-foreign-object
:double
))
741 (#.$SQL_C_BIT
(uffi:allocate-foreign-object
:byte
))
742 (#.$SQL_C_STINYINT
(uffi:allocate-foreign-object
:byte
))
743 (#.$SQL_C_SSHORT
(uffi:allocate-foreign-object
:short
))
744 (#.$SQL_C_CHAR
(uffi:allocate-foreign-string
(1+ size
)))
745 (#.$SQL_C_BINARY
(uffi:allocate-foreign-string
(1+ (* 2 size
))))
747 ;; Maybe should signal a restartable condition for this?
748 (when *break-on-unknown-data-type
*
749 (break "SQL type is ~A, precision ~D, size ~D, C type is ~A"
750 sql-type precision size c-type
))
751 (uffi:allocate-foreign-object
:byte
(1+ size
)))))
752 (out-len-ptr (uffi:allocate-foreign-object
#.$ODBC-LONG-TYPE
)))
753 (values c-type data-ptr out-len-ptr size long-p
)))
755 (defun fetch-all-rows (hstmt &key free-option flatp
)
756 (let ((column-count (result-columns-count hstmt
)))
757 (unless (zerop column-count
)
758 (let ((names (make-array column-count
))
759 (sql-types (make-array column-count
:element-type
'fixnum
))
760 (c-types (make-array column-count
:element-type
'fixnum
))
761 (precisions (make-array column-count
:element-type
'fixnum
))
762 (data-ptrs (make-array column-count
:initial-element nil
))
763 (out-len-ptrs (make-array column-count
:initial-element nil
))
764 (scales (make-array column-count
:element-type
'fixnum
))
765 (nullables-p (make-array column-count
:element-type
'fixnum
)))
769 (dotimes (col-nr column-count
)
770 ;; get column information
771 (multiple-value-bind (name sql-type precision scale nullable-p
)
772 (%describe-column hstmt
(1+ col-nr
))
773 ;; allocate space to bind result rows to
774 (multiple-value-bind (c-type data-ptr out-len-ptr
)
775 (%allocate-bindings sql-type precision
)
776 (%bind-column hstmt col-nr c-type data-ptr
(1+ precision
) out-len-ptr
)
777 (setf (svref names col-nr
) name
778 (aref sql-types col-nr
) sql-type
779 (aref c-types col-nr
) (sql-to-c-type sql-type
)
780 (aref precisions col-nr
) (if (zerop precision
) 0 precision
)
781 (aref scales col-nr
) scale
782 (aref nullables-p col-nr
) nullable-p
783 (aref data-ptrs col-nr
) data-ptr
784 (aref out-len-ptrs col-nr
) out-len-ptr
))))
788 (when (> column-count
1)
789 (error 'clsql
:sql-database-error
790 :message
"If more than one column is to be fetched, flatp has to be nil."))
791 (loop until
(= (%sql-fetch hstmt
) $SQL_NO_DATA_FOUND
)
793 (read-data (aref data-ptrs
0)
796 (aref out-len-ptrs
0)
799 (loop until
(= (%sql-fetch hstmt
) $SQL_NO_DATA_FOUND
)
801 (loop for col-nr from
0 to
(1- column-count
)
803 (read-data (aref data-ptrs col-nr
)
804 (aref c-types col-nr
)
805 (aref sql-types col-nr
)
806 (aref out-len-ptrs col-nr
)
809 ;; dispose of memory etc
810 (when free-option
(%free-statement hstmt free-option
))
811 (dotimes (col-nr column-count
)
812 (let ((data-ptr (aref data-ptrs col-nr
))
813 (out-len-ptr (aref out-len-ptrs col-nr
)))
814 (when data-ptr
(free-foreign-object data-ptr
)) ; we *did* allocate them
815 (when out-len-ptr
(free-foreign-object out-len-ptr
)))))))))
817 ;; to do: factor out common parts, put the sceleton (the obligatory macro part)
818 ;; of %do-fetch into sql package (has been done)
820 (defun %sql-prepare
(hstmt sql
)
821 (with-cstring (sql-ptr sql
)
822 (with-error-handling (:hstmt hstmt
)
823 (SQLPrepare hstmt sql-ptr $SQL_NTS
))))
825 ;; depending on option, we return a long int or a string; string not implemented
826 (defun get-connection-option (hdbc option
)
827 (with-foreign-object (param-ptr #.$ODBC-LONG-TYPE
)
828 (with-error-handling (:hdbc hdbc
)
829 (SQLGetConnectOption hdbc option param-ptr
)
830 (deref-pointer param-ptr
#.$ODBC-LONG-TYPE
))))
832 (defun set-connection-option (hdbc option param
)
833 (with-error-handling (:hdbc hdbc
)
834 (SQLSetConnectOption hdbc option param
)))
836 (defun disable-autocommit (hdbc)
837 (set-connection-option hdbc $SQL_AUTOCOMMIT $SQL_AUTOCOMMIT_OFF
))
839 (defun enable-autocommit (hdbc)
840 (set-connection-option hdbc $SQL_AUTOCOMMIT $SQL_AUTOCOMMIT_ON
))
842 (defun %sql-set-pos
(hstmt row option lock
)
845 (SQLSetPos hstmt row option lock
)))
847 (defun %sql-extended-fetch
(hstmt fetch-type row
)
848 (with-foreign-objects ((row-count-ptr #.$ODBC-ULONG-TYPE
)
849 (row-status-ptr :short
))
850 (with-error-handling (:hstmt hstmt
)
851 (SQLExtendedFetch hstmt fetch-type row row-count-ptr
853 (values (deref-pointer row-count-ptr
#.$ODBC-ULONG-TYPE
)
854 (deref-pointer row-status-ptr
:short
)))))
856 ; column-nr is zero-based
857 (defun %sql-get-data
(hstmt column-nr c-type data-ptr precision out-len-ptr
)
859 (:hstmt hstmt
:print-info nil
)
860 (SQLGetData hstmt
(if (eq column-nr
:bookmark
) 0 (1+ column-nr
))
861 c-type data-ptr precision out-len-ptr
)))
863 (defun %sql-param-data
(hstmt param-ptr
)
864 (with-error-handling (:hstmt hstmt
:print-info t
) ;; nil
865 (SQLParamData hstmt param-ptr
)))
867 (defun %sql-put-data
(hstmt data-ptr size
)
869 (:hstmt hstmt
:print-info t
) ;; nil
870 (SQLPutData hstmt data-ptr size
)))
872 (defconstant $sql-data-truncated
(intern "01004" :keyword
))
874 (defun read-data-in-chunks (hstmt column-nr data-ptr c-type sql-type
875 out-len-ptr result-type
)
876 (declare (type long-ptr-type out-len-ptr
)
877 (ignore result-type
))
878 (let* ((res (%sql-get-data hstmt column-nr c-type data-ptr
879 +max-precision
+ out-len-ptr
))
880 (out-len (deref-pointer out-len-ptr
#.$ODBC-LONG-TYPE
))
882 (result (case out-len
884 (return-from read-data-in-chunks
*null
*))
885 (#.$SQL_NO_TOTAL
;; don't know how long it is going to be
886 (let ((str (make-array 0 :element-type
'character
:adjustable t
)))
887 (loop do
(if (= c-type
#.$SQL_CHAR
)
888 (let ((data-length (foreign-string-length data-ptr
)))
889 (adjust-array str
(+ offset data-length
)
890 :initial-element
#\?)
891 (setf offset
(%cstring-into-vector
895 (error 'clsql
:sql-database-error
:message
"wrong type. preliminary."))
896 while
(and (= res $SQL_SUCCESS_WITH_INFO
)
897 (equal (sql-state +null-handle-ptr
+ +null-handle-ptr
+ hstmt
)
899 do
(setf res
(%sql-get-data hstmt column-nr c-type data-ptr
900 +max-precision
+ out-len-ptr
)))
901 (setf str
(coerce str
'string
))
902 (if (= sql-type $SQL_DECIMAL
)
903 (let ((*read-base
* 10))
904 (read-from-string str
))
907 (let ((str (make-string out-len
)))
908 (loop do
(if (= c-type
#.$SQL_CHAR
)
909 (setf offset
(%cstring-into-vector
;string
912 (min out-len
(1- +max-precision
+))))
913 (error 'clsql
:sql-database-error
:message
"wrong type. preliminary."))
915 (and (= res $SQL_SUCCESS_WITH_INFO
)
916 #+ingore
(eq (sql-state +null-handle-ptr
+ +null-handle-ptr
+ hstmt
)
918 (equal (sql-state +null-handle-ptr
+ +null-handle-ptr
+ hstmt
)
920 do
(setf res
(%sql-get-data hstmt column-nr c-type data-ptr
921 +max-precision
+ out-len-ptr
)
922 out-len
(deref-pointer out-len-ptr
#.$ODBC-LONG-TYPE
)))
923 (if (= sql-type $SQL_DECIMAL
)
924 (let ((*read-base
* 10))
925 (read-from-string str
))
927 (setf (deref-pointer out-len-ptr
#.$ODBC-LONG-TYPE
) #.$SQL_NO_TOTAL
) ;; reset the out length for the next row
930 (def-type c-timestamp-ptr-type
(* (:struct sql-c-timestamp
)))
931 (def-type c-time-ptr-type
(* (:struct sql-c-time
)))
932 (def-type c-date-ptr-type
(* (:struct sql-c-date
)))
934 (defun timestamp-to-universal-time (ptr)
935 (declare (type c-timestamp-ptr-type ptr
))
937 (encode-universal-time
938 (get-slot-value ptr
'sql-c-timestamp
'second
)
939 (get-slot-value ptr
'sql-c-timestamp
'minute
)
940 (get-slot-value ptr
'sql-c-timestamp
'hour
)
941 (get-slot-value ptr
'sql-c-timestamp
'day
)
942 (get-slot-value ptr
'sql-c-timestamp
'month
)
943 (get-slot-value ptr
'sql-c-timestamp
'year
))
944 (get-slot-value ptr
'sql-c-timestamp
'fraction
)))
946 (defun universal-time-to-timestamp (time &optional
(fraction 0))
947 (multiple-value-bind (sec min hour day month year
)
948 (decode-universal-time time
)
949 (let ((ptr (allocate-foreign-object 'sql-c-timestamp
)))
950 (setf (get-slot-value ptr
'sql-c-timestamp
'second
) sec
951 (get-slot-value ptr
'sql-c-timestamp
'minute
) min
952 (get-slot-value ptr
'sql-c-timestamp
'hour
) hour
953 (get-slot-value ptr
'sql-c-timestamp
'day
) day
954 (get-slot-value ptr
'sql-c-timestamp
'month
) month
955 (get-slot-value ptr
'sql-c-timestamp
'year
) year
956 (get-slot-value ptr
'sql-c-timestamp
'fraction
) fraction
)
959 (defun %put-timestamp
(ptr time
&optional
(fraction 0))
960 (declare (type c-timestamp-ptr-type ptr
))
961 (multiple-value-bind (sec min hour day month year
)
962 (decode-universal-time time
)
963 (setf (get-slot-value ptr
'sql-c-timestamp
'second
) sec
964 (get-slot-value ptr
'sql-c-timestamp
'minute
) min
965 (get-slot-value ptr
'sql-c-timestamp
'hour
) hour
966 (get-slot-value ptr
'sql-c-timestamp
'day
) day
967 (get-slot-value ptr
'sql-c-timestamp
'month
) month
968 (get-slot-value ptr
'sql-c-timestamp
'year
) year
969 (get-slot-value ptr
'sql-c-timestamp
'fraction
) fraction
)
972 (defun date-to-universal-time (ptr)
973 (declare (type c-date-ptr-type ptr
))
974 (encode-universal-time
976 (get-slot-value ptr
'sql-c-timestamp
'day
)
977 (get-slot-value ptr
'sql-c-timestamp
'month
)
978 (get-slot-value ptr
'sql-c-timestamp
'year
)))
980 (defun time-to-universal-time (ptr)
981 (declare (type c-time-ptr-type ptr
))
982 (encode-universal-time
983 (get-slot-value ptr
'sql-c-timestamp
'second
)
984 (get-slot-value ptr
'sql-c-timestamp
'minute
)
985 (get-slot-value ptr
'sql-c-timestamp
'hour
)
991 (defun %set-attr-odbc-version
(henv version
)
992 (with-error-handling (:henv henv
)
993 (SQLSetEnvAttr henv $SQL_ATTR_ODBC_VERSION
994 (make-pointer version
:void
) 0)))
996 (defun %list-tables
(hstmt)
997 (with-error-handling (:hstmt hstmt
)
998 (SQLTables hstmt
+null-ptr
+ 0 +null-ptr
+ 0 +null-ptr
+ 0 +null-ptr
+ 0)))
1000 (defun %table-statistics
(table hstmt
&key unique
(ensure t
))
1001 (with-cstrings ((table-cs table
))
1002 (with-error-handling (:hstmt hstmt
)
1008 (if unique $SQL_INDEX_UNIQUE $SQL_INDEX_ALL
)
1009 (if ensure $SQL_ENSURE $SQL_QUICK
)))))
1011 (defun %list-data-sources
(henv)
1012 (let ((dsn (allocate-foreign-string (1+ $SQL_MAX_DSN_LENGTH
)))
1013 (desc (allocate-foreign-string 256))
1016 (with-foreign-objects ((dsn-len :short
)
1018 (let ((res (with-error-handling (:henv henv
)
1019 (SQLDataSources henv $SQL_FETCH_FIRST dsn
1020 (1+ $SQL_MAX_DSN_LENGTH
)
1021 dsn-len desc
256 desc-len
))))
1022 (when (or (eql res $SQL_SUCCESS
)
1023 (eql res $SQL_SUCCESS_WITH_INFO
))
1024 (push (convert-from-foreign-string dsn
) results
))
1026 (do ((res (with-error-handling (:henv henv
)
1027 (SQLDataSources henv $SQL_FETCH_NEXT dsn
1028 (1+ $SQL_MAX_DSN_LENGTH
)
1029 dsn-len desc
256 desc-len
))
1030 (with-error-handling (:henv henv
)
1031 (SQLDataSources henv $SQL_FETCH_NEXT dsn
1032 (1+ $SQL_MAX_DSN_LENGTH
)
1033 dsn-len desc
256 desc-len
))))
1034 ((not (or (eql res $SQL_SUCCESS
)
1035 (eql res $SQL_SUCCESS_WITH_INFO
))))
1036 (push (convert-from-foreign-string dsn
) results
))))
1038 (free-foreign-object dsn
)
1039 (free-foreign-object desc
)))
1040 (nreverse results
)))