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
))
104 (progn ,result-code
,@body
))
105 (#.$SQL_SUCCESS_WITH_INFO
107 (multiple-value-bind (error-message sql-state
)
108 (handle-error (or ,henv
+null-handle-ptr
+)
109 (or ,hdbc
+null-handle-ptr
+)
110 (or ,hstmt
+null-handle-ptr
+))
112 (format *info-output
* "[ODBC info ~A] ~A state: ~A"
113 ,result-code error-message
115 (progn ,result-code
,@body
))
116 (#.$SQL_INVALID_HANDLE
118 'clsql-sys
:sql-database-error
119 :message
"ODBC: Invalid handle"))
120 (#.$SQL_STILL_EXECUTING
122 'clsql-sys
:sql-temporary-error
123 :message
"ODBC: Still executing"))
125 (multiple-value-bind (error-message sql-state
)
126 (handle-error (or ,henv
+null-handle-ptr
+)
127 (or ,hdbc
+null-handle-ptr
+)
128 (or ,hstmt
+null-handle-ptr
+))
130 'clsql-sys
:sql-database-error
131 :message error-message
132 :secondary-error-id sql-state
)))
133 (#.$SQL_NO_DATA_FOUND
134 (progn ,result-code
,@body
))
135 ;; work-around for Allegro 7.0beta AMD64 which
136 ;; has for negative numbers
138 (multiple-value-bind (error-message sql-state
)
139 (handle-error (or ,henv
+null-handle-ptr
+)
140 (or ,hdbc
+null-handle-ptr
+)
141 (or ,hstmt
+null-handle-ptr
+))
143 'clsql-sys
:sql-database-error
144 :message error-message
145 :secondary-error-id sql-state
))
147 (progn ,result-code
,@body
))))))
149 (defun %new-environment-handle
()
151 (with-foreign-object (phenv 'sql-handle
)
154 (SQLAllocHandle $SQL_HANDLE_ENV
+null-handle-ptr
+ phenv
)
155 (deref-pointer phenv
'sql-handle
)))))
156 (%set-attr-odbc-version henv $SQL_OV_ODBC3
)
160 (defun %sql-free-environment
(henv)
165 (defun %new-db-connection-handle
(henv)
166 (with-foreign-object (phdbc 'sql-handle
)
167 (setf (deref-pointer phdbc
'sql-handle
) +null-handle-ptr
+)
170 (SQLAllocHandle $SQL_HANDLE_DBC henv phdbc
)
171 (deref-pointer phdbc
'sql-handle
))))
173 (defun %free-statement
(hstmt option
)
181 (:unbind $SQL_UNBIND
)
182 (:reset $SQL_RESET_PARAMS
)))))
184 (defmacro with-statement-handle
((hstmt hdbc
) &body body
)
185 `(let ((,hstmt
(%new-statement-handle
,hdbc
)))
188 (%free-statement
,hstmt
:drop
))))
190 ;; functional interface
192 (defun %sql-connect
(hdbc server uid pwd
)
193 (with-cstrings ((server-ptr server
)
198 (SQLConnect hdbc server-ptr $SQL_NTS uid-ptr
199 $SQL_NTS pwd-ptr $SQL_NTS
))))
201 (defun %sql-driver-connect
(hdbc connection-string completion window-handle
)
202 (with-cstring (connection-ptr connection-string
)
203 (let ((completed-connection-string (allocate-foreign-string $SQL_MAX_CONN_OUT
)))
205 (with-foreign-object (completed-connection-length :short
)
208 (SQLDriverConnect hdbc
210 connection-ptr $SQL_NTS
211 completed-connection-string $SQL_MAX_CONN_OUT
212 completed-connection-length
214 (free-foreign-object completed-connection-string
)))))
216 (defun %disconnect
(hdbc)
219 (SQLDisconnect hdbc
)))
221 (defun %commit
(henv hdbc
)
223 (:henv henv
:hdbc hdbc
)
225 henv hdbc $SQL_COMMIT
)))
227 (defun %rollback
(henv hdbc
)
229 (:henv henv
:hdbc hdbc
)
231 henv hdbc $SQL_ROLLBACK
)))
233 ; col-nr is zero-based in Lisp
234 ; col-nr = :bookmark retrieves a bookmark.
235 (defun %bind-column
(hstmt column-nr c-type data-ptr precision out-len-ptr
)
239 (if (eq column-nr
:bookmark
) 0 (1+ column-nr
))
240 c-type data-ptr precision out-len-ptr
)))
242 ; parameter-nr is zero-based in Lisp
243 (defun %sql-bind-parameter
(hstmt parameter-nr parameter-type c-type
244 sql-type precision scale data-ptr
245 max-value out-len-ptr
)
248 (SQLBindParameter hstmt
(1+ parameter-nr
)
249 parameter-type
;$SQL_PARAM_INPUT
251 sql-type
;$SQL_VARCHAR
252 precision
;(1- (length str))
256 out-len-ptr
;#.+null-ptr+
259 (defun %sql-fetch
(hstmt)
264 (defun %new-statement-handle
(hdbc)
265 (let ((statement-handle
266 (with-foreign-object (phstmt 'sql-handle
)
269 (SQLAllocHandle $SQL_HANDLE_STMT hdbc phstmt
)
270 (deref-pointer phstmt
'sql-handle
)))))
271 (if (uffi:null-pointer-p statement-handle
)
272 (error 'clsql
:sql-database-error
:message
"Received null statement handle.")
275 (defun %sql-get-info
(hdbc info-type
)
277 ;; those return string
278 ((#.$SQL_ACCESSIBLE_PROCEDURES
279 #.$SQL_ACCESSIBLE_TABLES
281 #.$SQL_DATA_SOURCE_NAME
282 #.$SQL_DATA_SOURCE_READ_ONLY
286 #.$SQL_DRIVER_ODBC_VER
288 #.$SQL_EXPRESSIONS_IN_ORDERBY
289 #.$SQL_IDENTIFIER_QUOTE_CHAR
291 #.$SQL_LIKE_ESCAPE_CLAUSE
292 #.$SQL_MAX_ROW_SIZE_INCLUDES_LONG
293 #.$SQL_MULT_RESULT_SETS
294 #.$SQL_MULTIPLE_ACTIVE_TXN
295 #.$SQL_NEED_LONG_DATA_LEN
296 #.$SQL_ODBC_SQL_OPT_IEF
298 #.$SQL_ORDER_BY_COLUMNS_IN_SELECT
301 #.$SQL_PROCEDURE_TERM
303 #.$SQL_QUALIFIER_NAME_SEPARATOR
304 #.$SQL_QUALIFIER_TERM
306 #.$SQL_SEARCH_PATTERN_ESCAPE
308 #.$SQL_SPECIAL_CHARACTERS
311 (let ((info-ptr (allocate-foreign-string 1024)))
312 (with-foreign-object (info-length-ptr :short
)
315 (SQLGetInfo hdbc info-type info-ptr
1023 info-length-ptr
)
316 (let ((info (convert-from-foreign-string info-ptr
)))
317 (free-foreign-object info-ptr
)
319 ;; those returning a word
320 ((#.$SQL_ACTIVE_CONNECTIONS
321 #.$SQL_ACTIVE_STATEMENTS
322 #.$SQL_CONCAT_NULL_BEHAVIOR
323 #.$SQL_CORRELATION_NAME
324 #.$SQL_CURSOR_COMMIT_BEHAVIOR
325 #.$SQL_CURSOR_ROLLBACK_BEHAVIOR
326 #.$SQL_MAX_COLUMN_NAME_LEN
327 #.$SQL_MAX_COLUMNS_IN_GROUP_BY
328 #.$SQL_MAX_COLUMNS_IN_INDEX
329 #.$SQL_MAX_COLUMNS_IN_ORDER_BY
330 #.$SQL_MAX_COLUMNS_IN_SELECT
331 #.$SQL_MAX_COLUMNS_IN_TABLE
332 #.$SQL_MAX_CURSOR_NAME_LEN
333 #.$SQL_MAX_OWNER_NAME_LEN
334 #.$SQL_MAX_PROCEDURE_NAME_LEN
335 #.$SQL_MAX_QUALIFIER_NAME_LEN
336 #.$SQL_MAX_TABLE_NAME_LEN
337 #.$SQL_MAX_TABLES_IN_SELECT
338 #.$SQL_MAX_USER_NAME_LEN
339 #.$SQL_NON_NULLABLE_COLUMNS
340 #.$SQL_NULL_COLLATION
341 #.$SQL_ODBC_API_CONFORMANCE
342 #.$SQL_ODBC_SAG_CLI_CONFORMANCE
343 #.$SQL_ODBC_SQL_CONFORMANCE
344 #.$SQL_QUALIFIER_LOCATION
345 #.$SQL_QUOTED_IDENTIFIER_CASE
347 (with-foreign-objects ((info-ptr :short
)
348 (info-length-ptr :short
))
356 (deref-pointer info-ptr
:short
)))
358 ;; those returning a long bitmask
360 #.$SQL_BOOKMARK_PERSISTENCE
361 #.$SQL_CONVERT_BIGINT
362 #.$SQL_CONVERT_BINARY
366 #.$SQL_CONVERT_DECIMAL
367 #.$SQL_CONVERT_DOUBLE
369 #.$SQL_CONVERT_INTEGER
370 #.$SQL_CONVERT_LONGVARCHAR
371 #.$SQL_CONVERT_NUMERIC
373 #.$SQL_CONVERT_SMALLINT
375 #.$SQL_CONVERT_TIMESTAMP
376 #.$SQL_CONVERT_TINYINT
377 #.$SQL_CONVERT_VARBINARY
378 #.$SQL_CONVERT_VARCHAR
379 #.$SQL_CONVERT_LONGVARBINARY
380 #.$SQL_CONVERT_FUNCTIONS
381 #.$SQL_FETCH_DIRECTION
383 #.$SQL_GETDATA_EXTENSIONS
385 #.$SQL_MAX_INDEX_SIZE
387 #.$SQL_MAX_STATEMENT_LEN
388 #.$SQL_NUMERIC_FUNCTIONS
390 #.$SQL_POS_OPERATIONS
391 #.$SQL_POSITIONED_STATEMENTS
392 #.$SQL_QUALIFIER_USAGE
393 #.$SQL_SCROLL_CONCURRENCY
394 #.$SQL_SCROLL_OPTIONS
395 #.$SQL_STATIC_SENSITIVITY
396 #.$SQL_STRING_FUNCTIONS
398 #.$SQL_SYSTEM_FUNCTIONS
399 #.$SQL_TIMEDATE_ADD_INTERVALS
400 #.$SQL_TIMEDATE_DIFF_INTERVALS
401 #.$SQL_TIMEDATE_FUNCTIONS
402 #.$SQL_TXN_ISOLATION_OPTION
404 (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE
)
405 (info-length-ptr :short
))
413 (deref-pointer info-ptr
#.$ODBC-LONG-TYPE
)))
415 ;; those returning a long integer
416 ((#.$SQL_DEFAULT_TXN_ISOLATION
422 #.$SQL_IDENTIFIER_CASE
423 #.$SQL_MAX_BINARY_LITERAL_LEN
424 #.$SQL_MAX_CHAR_LITERAL_LEN
425 #.$SQL_ACTIVE_ENVIRONMENTS
427 (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE
)
428 (info-length-ptr :short
))
431 (SQLGetInfo hdbc info-type info-ptr
255 info-length-ptr
)
432 (deref-pointer info-ptr
#.$ODBC-LONG-TYPE
))))))
434 (defun %sql-exec-direct
(sql hstmt henv hdbc
)
435 (with-cstring (sql-ptr sql
)
437 (:hstmt hstmt
:henv henv
:hdbc hdbc
)
438 (SQLExecDirect hstmt sql-ptr $SQL_NTS
))))
440 (defun %sql-cancel
(hstmt)
445 (defun %sql-execute
(hstmt)
450 (defun result-columns-count (hstmt)
451 (with-foreign-objects ((columns-nr-ptr :short
))
452 (with-error-handling (:hstmt hstmt
)
453 (SQLNumResultCols hstmt columns-nr-ptr
)
454 (deref-pointer columns-nr-ptr
:short
))))
456 (defun result-rows-count (hstmt)
457 (with-foreign-objects ((row-count-ptr #.$ODBC-LONG-TYPE
))
458 (with-error-handling (:hstmt hstmt
)
459 (SQLRowCount hstmt row-count-ptr
)
460 (deref-pointer row-count-ptr
#.$ODBC-LONG-TYPE
))))
462 ;; column counting is 1-based
463 (defun %describe-column
(hstmt column-nr
)
464 (let ((column-name-ptr (allocate-foreign-string 256)))
465 (with-foreign-objects ((column-name-length-ptr :short
)
466 (column-sql-type-ptr :short
)
467 (column-precision-ptr #.$ODBC-ULONG-TYPE
)
468 (column-scale-ptr :short
)
469 (column-nullable-p-ptr :short
))
470 (with-error-handling (:hstmt hstmt
)
471 (SQLDescribeCol hstmt column-nr column-name-ptr
256
472 column-name-length-ptr
476 column-nullable-p-ptr
)
477 (let ((column-name (convert-from-foreign-string column-name-ptr
)))
478 (free-foreign-object column-name-ptr
)
481 (deref-pointer column-sql-type-ptr
:short
)
482 (deref-pointer column-precision-ptr
#.$ODBC-ULONG-TYPE
)
483 (deref-pointer column-scale-ptr
:short
)
484 (deref-pointer column-nullable-p-ptr
:short
)))))))
486 ;; parameter counting is 1-based
487 (defun %describe-parameter
(hstmt parameter-nr
)
488 (with-foreign-objects ((column-sql-type-ptr :short
)
489 (column-precision-ptr #.$ODBC-ULONG-TYPE
)
490 (column-scale-ptr :short
)
491 (column-nullable-p-ptr :short
))
494 (SQLDescribeParam hstmt parameter-nr
498 column-nullable-p-ptr
)
500 (deref-pointer column-sql-type-ptr
:short
)
501 (deref-pointer column-precision-ptr
#.$ODBC-ULONG-TYPE
)
502 (deref-pointer column-scale-ptr
:short
)
503 (deref-pointer column-nullable-p-ptr
:short
)))))
505 (defun %column-attributes
(hstmt column-nr descriptor-type
)
506 (let ((descriptor-info-ptr (allocate-foreign-string 256)))
507 (with-foreign-objects ((descriptor-length-ptr :short
)
508 (numeric-descriptor-ptr #.$ODBC-LONG-TYPE
))
511 (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr
512 256 descriptor-length-ptr
513 numeric-descriptor-ptr
)
514 (let ((desc (convert-from-foreign-string descriptor-info-ptr
)))
515 (free-foreign-object descriptor-info-ptr
)
518 (deref-pointer numeric-descriptor-ptr
#.$ODBC-LONG-TYPE
)))))))
520 (defun %prepare-describe-columns
(hstmt table-qualifier table-owner
521 table-name column-name
)
522 (with-cstrings ((table-qualifier-ptr table-qualifier
)
523 (table-owner-ptr table-owner
)
524 (table-name-ptr table-name
)
525 (column-name-ptr column-name
))
529 table-qualifier-ptr
(length table-qualifier
)
530 table-owner-ptr
(length table-owner
)
531 table-name-ptr
(length table-name
)
532 column-name-ptr
(length column-name
)))))
534 (defun %describe-columns
(hdbc table-qualifier table-owner
535 table-name column-name
)
536 (with-statement-handle (hstmt hdbc
)
537 (%prepare-describe-columns hstmt table-qualifier table-owner
538 table-name column-name
)
539 (fetch-all-rows hstmt
)))
541 (defun %sql-data-sources
(henv &key
(direction :first
))
542 (let ((name-ptr (allocate-foreign-string (1+ $SQL_MAX_DSN_LENGTH
)))
543 (description-ptr (allocate-foreign-string 1024)))
544 (with-foreign-objects ((name-length-ptr :short
)
545 (description-length-ptr :short
))
546 (let ((res (with-error-handling
550 (:first $SQL_FETCH_FIRST
)
551 (:next $SQL_FETCH_NEXT
))
553 (1+ $SQL_MAX_DSN_LENGTH
)
557 description-length-ptr
))))
559 ((= res $SQL_NO_DATA_FOUND
)
560 (let ((name (convert-from-foreign-string name-ptr
))
561 (desc (convert-from-foreign-string description-ptr
)))
562 (free-foreign-object name-ptr
)
563 (free-foreign-object description-ptr
)
568 (free-foreign-object name-ptr
)
569 (free-foreign-object description-ptr
)
574 (defun sql-to-c-type (sql-type)
576 ((#.$SQL_CHAR
#.$SQL_VARCHAR
#.$SQL_LONGVARCHAR
577 #.$SQL_NUMERIC
#.$SQL_DECIMAL
#.$SQL_BIGINT -
8 -
9 -
10) $SQL_C_CHAR
) ;; Added -10 for MSSQL ntext type
578 (#.$SQL_INTEGER $SQL_C_SLONG
)
579 (#.$SQL_SMALLINT $SQL_C_SSHORT
)
580 (#.$SQL_DOUBLE $SQL_C_DOUBLE
)
581 (#.$SQL_FLOAT $SQL_C_DOUBLE
)
582 (#.$SQL_REAL $SQL_C_FLOAT
)
583 (#.$SQL_DATE $SQL_C_DATE
)
584 (#.$SQL_TIME $SQL_C_TIME
)
585 (#.$SQL_TIMESTAMP $SQL_C_TIMESTAMP
)
586 (#.$SQL_TYPE_DATE $SQL_C_TYPE_DATE
)
587 (#.$SQL_TYPE_TIME $SQL_C_TYPE_TIME
)
588 (#.$SQL_TYPE_TIMESTAMP $SQL_C_TYPE_TIMESTAMP
)
589 ((#.$SQL_BINARY
#.$SQL_VARBINARY
#.$SQL_LONGVARBINARY
) $SQL_C_BINARY
)
590 (#.$SQL_TINYINT $SQL_C_STINYINT
)
591 (#.$SQL_BIT $SQL_C_BIT
)))
593 (def-type byte-pointer-type
(* :byte
))
594 (def-type short-pointer-type
(* :short
))
595 (def-type int-pointer-type
(* :int
))
596 (def-type long-pointer-type
(* #.$ODBC-LONG-TYPE
))
597 (def-type float-pointer-type
(* :float
))
598 (def-type double-pointer-type
(* :double
))
599 (def-type string-pointer-type
(* :unsigned-char
))
601 (defun get-cast-byte (ptr)
602 (locally (declare (type byte-pointer-type ptr
))
603 (deref-pointer ptr
:byte
)))
605 (defun get-cast-short (ptr)
606 (locally (declare (type short-pointer-type ptr
))
607 (deref-pointer ptr
:short
)))
609 (defun get-cast-int (ptr)
610 (locally (declare (type int-pointer-type ptr
))
611 (deref-pointer ptr
:int
)))
613 (defun get-cast-long (ptr)
614 (locally (declare (type long-pointer-type ptr
))
615 (deref-pointer ptr
#.$ODBC-LONG-TYPE
)))
617 (defun get-cast-single-float (ptr)
618 (locally (declare (type float-pointer-type ptr
))
619 (deref-pointer ptr
:float
)))
621 (defun get-cast-double-float (ptr)
622 (locally (declare (type double-pointer-type ptr
))
623 (deref-pointer ptr
:double
)))
625 (defun get-cast-foreign-string (ptr)
626 (locally (declare (type string-pointer-type ptr
))
627 (convert-from-foreign-string ptr
)))
629 (defun get-cast-binary (ptr len format
)
630 "FORMAT is one of :unsigned-byte-vector, :bit-vector (:string, :hex-string)"
631 (with-cast-pointer (casted ptr
:byte
)
633 (:unsigned-byte-vector
634 (let ((vector (make-array len
:element-type
'(unsigned-byte 8))))
636 (setf (aref vector i
)
637 (deref-array casted
'(:array
:byte
) i
)))
640 (let ((vector (make-array (ash len
3) :element-type
'bit
)))
642 (let ((byte (deref-array casted
'(:array
:byte
) i
)))
644 (setf (bit vector
(+ (ash i
3) j
))
645 (logand (ash byte
(- j
7)) 1)))))
649 (defun read-data (data-ptr c-type sql-type out-len-ptr result-type
)
650 (declare (type long-ptr-type out-len-ptr
))
651 (let* ((out-len (deref-pointer out-len-ptr
#.$ODBC-LONG-TYPE
))
653 (cond ((= out-len $SQL_NULL_DATA
)
657 ;; SQL extended datatypes
658 (#.$SQL_TINYINT
(get-cast-byte data-ptr
))
659 (#.$SQL_C_STINYINT
(get-cast-byte data-ptr
)) ;; ?
660 (#.$SQL_C_SSHORT
(get-cast-short data-ptr
)) ;; ?
661 (#.$SQL_SMALLINT
(get-cast-short data-ptr
)) ;; ??
662 (#.$SQL_INTEGER
(get-cast-int data-ptr
))
663 (#.$SQL_BIGINT
(read-from-string
664 (get-cast-foreign-string data-ptr
)))
666 (let ((*read-base
* 10))
667 (read-from-string (get-cast-foreign-string data-ptr
))))
668 (#.$SQL_BIT
(get-cast-byte data-ptr
))
671 ((#.$SQL_C_DATE
#.$SQL_C_TYPE_DATE
)
672 (funcall *time-conversion-function
* (date-to-universal-time data-ptr
)))
673 ((#.$SQL_C_TIME
#.$SQL_C_TYPE_TIME
)
674 (multiple-value-bind (universal-time frac
) (time-to-universal-time data-ptr
)
675 (funcall *time-conversion-function
* universal-time frac
)))
676 ((#.$SQL_C_TIMESTAMP
#.$SQL_C_TYPE_TIMESTAMP
)
677 (multiple-value-bind (universal-time frac
) (timestamp-to-universal-time data-ptr
)
678 (funcall *time-conversion-function
* universal-time frac
)))
680 (get-cast-int data-ptr
))
682 (get-cast-single-float data-ptr
))
684 (get-cast-double-float data-ptr
))
686 (get-cast-long data-ptr
))
688 (#.$SQL_C_BIT
; encountered only in Access
689 (get-cast-byte data-ptr
))
691 (get-cast-binary data-ptr out-len
*binary-format
*))
692 ((#.$SQL_C_SSHORT
#.$SQL_C_STINYINT
) ; LMH short ints
693 (get-cast-short data-ptr
)) ; LMH
696 (code-char (get-cast-short data-ptr
)))
698 (get-cast-foreign-string data-ptr
)))))))))
700 ;; FIXME: this could be better optimized for types which use READ-FROM-STRING above
702 (if (and (or (eq result-type t
) (eq result-type
:string
))
704 (not (stringp value
)))
705 (write-to-string value
)
708 ;; which value is appropriate?
709 (defparameter +max-precision
+ 4001)
711 (defvar *break-on-unknown-data-type
* t
)
713 ;; C. Stacy's idea to factor this out
714 ;; "Make it easy to add new datatypes by making new subroutine %ALLOCATE-BINDINGS,
715 ;; so that I don't have to remember to make changes in more than one place.
716 ;; Just keep it in synch with READ-DATA."
717 (defun %allocate-bindings
(sql-type precision
)
718 (let* ((c-type (sql-to-c-type sql-type
))
719 (size (if (zerop precision
)
720 +max-precision
+ ;; if the precision cannot be determined
721 (min precision
+max-precision
+)))
722 (long-p (= size
+max-precision
+))
724 (case c-type
;; add more?
725 (#.$SQL_C_SLONG
(uffi:allocate-foreign-object
#.$ODBC-LONG-TYPE
))
726 ((#.$SQL_C_DATE
#.$SQL_C_TYPE_DATE
) (allocate-foreign-object 'sql-c-date
))
727 ((#.$SQL_C_TIME
#.$SQL_C_TYPE_TIME
) (allocate-foreign-object 'sql-c-time
))
728 ((#.$SQL_C_TIMESTAMP
#.$SQL_C_TYPE_TIMESTAMP
) (allocate-foreign-object 'sql-c-timestamp
))
729 (#.$SQL_C_FLOAT
(uffi:allocate-foreign-object
:float
))
730 (#.$SQL_C_DOUBLE
(uffi:allocate-foreign-object
:double
))
731 (#.$SQL_C_BIT
(uffi:allocate-foreign-object
:byte
))
732 (#.$SQL_C_STINYINT
(uffi:allocate-foreign-object
:byte
))
733 (#.$SQL_C_SSHORT
(uffi:allocate-foreign-object
:short
))
734 (#.$SQL_C_CHAR
(uffi:allocate-foreign-string
(1+ size
)))
735 (#.$SQL_C_BINARY
(uffi:allocate-foreign-string
(1+ (* 2 size
))))
737 ;; Maybe should signal a restartable condition for this?
738 (when *break-on-unknown-data-type
*
739 (break "SQL type is ~A, precision ~D, size ~D, C type is ~A"
740 sql-type precision size c-type
))
741 (uffi:allocate-foreign-object
:byte
(1+ size
)))))
742 (out-len-ptr (uffi:allocate-foreign-object
#.$ODBC-LONG-TYPE
)))
743 (values c-type data-ptr out-len-ptr size long-p
)))
745 (defun fetch-all-rows (hstmt &key free-option flatp
)
746 (let ((column-count (result-columns-count hstmt
)))
747 (unless (zerop column-count
)
748 (let ((names (make-array column-count
))
749 (sql-types (make-array column-count
:element-type
'fixnum
))
750 (c-types (make-array column-count
:element-type
'fixnum
))
751 (precisions (make-array column-count
:element-type
'fixnum
))
752 (data-ptrs (make-array column-count
:initial-element nil
))
753 (out-len-ptrs (make-array column-count
:initial-element nil
))
754 (scales (make-array column-count
:element-type
'fixnum
))
755 (nullables-p (make-array column-count
:element-type
'fixnum
)))
759 (dotimes (col-nr column-count
)
760 ;; get column information
761 (multiple-value-bind (name sql-type precision scale nullable-p
)
762 (%describe-column hstmt
(1+ col-nr
))
763 ;; allocate space to bind result rows to
764 (multiple-value-bind (c-type data-ptr out-len-ptr
)
765 (%allocate-bindings sql-type precision
)
766 (%bind-column hstmt col-nr c-type data-ptr
(1+ precision
) out-len-ptr
)
767 (setf (svref names col-nr
) name
768 (aref sql-types col-nr
) sql-type
769 (aref c-types col-nr
) (sql-to-c-type sql-type
)
770 (aref precisions col-nr
) (if (zerop precision
) 0 precision
)
771 (aref scales col-nr
) scale
772 (aref nullables-p col-nr
) nullable-p
773 (aref data-ptrs col-nr
) data-ptr
774 (aref out-len-ptrs col-nr
) out-len-ptr
))))
778 (when (> column-count
1)
779 (error 'clsql
:sql-database-error
780 :message
"If more than one column is to be fetched, flatp has to be nil."))
781 (loop until
(= (%sql-fetch hstmt
) $SQL_NO_DATA_FOUND
)
783 (read-data (aref data-ptrs
0)
786 (aref out-len-ptrs
0)
789 (loop until
(= (%sql-fetch hstmt
) $SQL_NO_DATA_FOUND
)
791 (loop for col-nr from
0 to
(1- column-count
)
793 (read-data (aref data-ptrs col-nr
)
794 (aref c-types col-nr
)
795 (aref sql-types col-nr
)
796 (aref out-len-ptrs col-nr
)
799 ;; dispose of memory etc
800 (when free-option
(%free-statement hstmt free-option
))
801 (dotimes (col-nr column-count
)
802 (let ((data-ptr (aref data-ptrs col-nr
))
803 (out-len-ptr (aref out-len-ptrs col-nr
)))
804 (when data-ptr
(free-foreign-object data-ptr
)) ; we *did* allocate them
805 (when out-len-ptr
(free-foreign-object out-len-ptr
)))))))))
807 ;; to do: factor out common parts, put the sceleton (the obligatory macro part)
808 ;; of %do-fetch into sql package (has been done)
810 (defun %sql-prepare
(hstmt sql
)
811 (with-cstring (sql-ptr sql
)
812 (with-error-handling (:hstmt hstmt
)
813 (SQLPrepare hstmt sql-ptr $SQL_NTS
))))
815 ;; depending on option, we return a long int or a string; string not implemented
816 (defun get-connection-option (hdbc option
)
817 (with-foreign-object (param-ptr #.$ODBC-LONG-TYPE
)
818 (with-error-handling (:hdbc hdbc
)
819 (SQLGetConnectOption hdbc option param-ptr
)
820 (deref-pointer param-ptr
#.$ODBC-LONG-TYPE
))))
822 (defun set-connection-option (hdbc option param
)
823 (with-error-handling (:hdbc hdbc
)
824 (SQLSetConnectOption hdbc option param
)))
826 (defun disable-autocommit (hdbc)
827 (set-connection-option hdbc $SQL_AUTOCOMMIT $SQL_AUTOCOMMIT_OFF
))
829 (defun enable-autocommit (hdbc)
830 (set-connection-option hdbc $SQL_AUTOCOMMIT $SQL_AUTOCOMMIT_ON
))
832 (defun %sql-set-pos
(hstmt row option lock
)
835 (SQLSetPos hstmt row option lock
)))
837 (defun %sql-extended-fetch
(hstmt fetch-type row
)
838 (with-foreign-objects ((row-count-ptr #.$ODBC-ULONG-TYPE
)
839 (row-status-ptr :short
))
840 (with-error-handling (:hstmt hstmt
)
841 (SQLExtendedFetch hstmt fetch-type row row-count-ptr
843 (values (deref-pointer row-count-ptr
#.$ODBC-ULONG-TYPE
)
844 (deref-pointer row-status-ptr
:short
)))))
846 ; column-nr is zero-based
847 (defun %sql-get-data
(hstmt column-nr c-type data-ptr precision out-len-ptr
)
849 (:hstmt hstmt
:print-info nil
)
850 (SQLGetData hstmt
(if (eq column-nr
:bookmark
) 0 (1+ column-nr
))
851 c-type data-ptr precision out-len-ptr
)))
853 (defun %sql-param-data
(hstmt param-ptr
)
854 (with-error-handling (:hstmt hstmt
:print-info t
) ;; nil
855 (SQLParamData hstmt param-ptr
)))
857 (defun %sql-put-data
(hstmt data-ptr size
)
859 (:hstmt hstmt
:print-info t
) ;; nil
860 (SQLPutData hstmt data-ptr size
)))
862 (defconstant $sql-data-truncated
(intern "01004" :keyword
))
864 (defun read-data-in-chunks (hstmt column-nr data-ptr c-type sql-type
865 out-len-ptr result-type
)
866 (declare (type long-ptr-type out-len-ptr
)
867 (ignore result-type
))
868 (let* ((res (%sql-get-data hstmt column-nr c-type data-ptr
869 +max-precision
+ out-len-ptr
))
870 (out-len (deref-pointer out-len-ptr
#.$ODBC-LONG-TYPE
))
872 (result (case out-len
874 (return-from read-data-in-chunks
*null
*))
875 (#.$SQL_NO_TOTAL
;; don't know how long it is going to be
876 (let ((str (make-array 0 :element-type
'character
:adjustable t
)))
877 (loop do
(if (= c-type
#.$SQL_CHAR
)
878 (let ((data-length (foreign-string-length data-ptr
)))
879 (adjust-array str
(+ offset data-length
)
880 :initial-element
#\?)
881 (setf offset
(%cstring-into-vector
885 (error 'clsql
:sql-database-error
:message
"wrong type. preliminary."))
886 while
(and (= res $SQL_SUCCESS_WITH_INFO
)
887 (equal (sql-state +null-handle-ptr
+ +null-handle-ptr
+ hstmt
)
889 do
(setf res
(%sql-get-data hstmt column-nr c-type data-ptr
890 +max-precision
+ out-len-ptr
)))
891 (setf str
(coerce str
'string
))
892 (if (= sql-type $SQL_DECIMAL
)
893 (let ((*read-base
* 10))
894 (read-from-string str
))
897 (let ((str (make-string out-len
)))
898 (loop do
(if (= c-type
#.$SQL_CHAR
)
899 (setf offset
(%cstring-into-vector
;string
902 (min out-len
(1- +max-precision
+))))
903 (error 'clsql
:sql-database-error
:message
"wrong type. preliminary."))
905 (and (= res $SQL_SUCCESS_WITH_INFO
)
906 #+ingore
(eq (sql-state +null-handle-ptr
+ +null-handle-ptr
+ hstmt
)
908 (equal (sql-state +null-handle-ptr
+ +null-handle-ptr
+ hstmt
)
910 do
(setf res
(%sql-get-data hstmt column-nr c-type data-ptr
911 +max-precision
+ out-len-ptr
)
912 out-len
(deref-pointer out-len-ptr
#.$ODBC-LONG-TYPE
)))
913 (if (= sql-type $SQL_DECIMAL
)
914 (let ((*read-base
* 10))
915 (read-from-string str
))
917 (setf (deref-pointer out-len-ptr
#.$ODBC-LONG-TYPE
) #.$SQL_NO_TOTAL
) ;; reset the out length for the next row
920 (def-type c-timestamp-ptr-type
(* (:struct sql-c-timestamp
)))
921 (def-type c-time-ptr-type
(* (:struct sql-c-time
)))
922 (def-type c-date-ptr-type
(* (:struct sql-c-date
)))
924 (defun timestamp-to-universal-time (ptr)
925 (declare (type c-timestamp-ptr-type ptr
))
927 (encode-universal-time
928 (get-slot-value ptr
'sql-c-timestamp
'second
)
929 (get-slot-value ptr
'sql-c-timestamp
'minute
)
930 (get-slot-value ptr
'sql-c-timestamp
'hour
)
931 (get-slot-value ptr
'sql-c-timestamp
'day
)
932 (get-slot-value ptr
'sql-c-timestamp
'month
)
933 (get-slot-value ptr
'sql-c-timestamp
'year
))
934 (get-slot-value ptr
'sql-c-timestamp
'fraction
)))
936 (defun universal-time-to-timestamp (time &optional
(fraction 0))
937 (multiple-value-bind (sec min hour day month year
)
938 (decode-universal-time time
)
939 (let ((ptr (allocate-foreign-object 'sql-c-timestamp
)))
940 (setf (get-slot-value ptr
'sql-c-timestamp
'second
) sec
941 (get-slot-value ptr
'sql-c-timestamp
'minute
) min
942 (get-slot-value ptr
'sql-c-timestamp
'hour
) hour
943 (get-slot-value ptr
'sql-c-timestamp
'day
) day
944 (get-slot-value ptr
'sql-c-timestamp
'month
) month
945 (get-slot-value ptr
'sql-c-timestamp
'year
) year
946 (get-slot-value ptr
'sql-c-timestamp
'fraction
) fraction
)
949 (defun %put-timestamp
(ptr time
&optional
(fraction 0))
950 (declare (type c-timestamp-ptr-type ptr
))
951 (multiple-value-bind (sec min hour day month year
)
952 (decode-universal-time time
)
953 (setf (get-slot-value ptr
'sql-c-timestamp
'second
) sec
954 (get-slot-value ptr
'sql-c-timestamp
'minute
) min
955 (get-slot-value ptr
'sql-c-timestamp
'hour
) hour
956 (get-slot-value ptr
'sql-c-timestamp
'day
) day
957 (get-slot-value ptr
'sql-c-timestamp
'month
) month
958 (get-slot-value ptr
'sql-c-timestamp
'year
) year
959 (get-slot-value ptr
'sql-c-timestamp
'fraction
) fraction
)
962 (defun date-to-universal-time (ptr)
963 (declare (type c-date-ptr-type ptr
))
964 (encode-universal-time
966 (get-slot-value ptr
'sql-c-timestamp
'day
)
967 (get-slot-value ptr
'sql-c-timestamp
'month
)
968 (get-slot-value ptr
'sql-c-timestamp
'year
)))
970 (defun time-to-universal-time (ptr)
971 (declare (type c-time-ptr-type ptr
))
972 (encode-universal-time
973 (get-slot-value ptr
'sql-c-timestamp
'second
)
974 (get-slot-value ptr
'sql-c-timestamp
'minute
)
975 (get-slot-value ptr
'sql-c-timestamp
'hour
)
981 (defun %set-attr-odbc-version
(henv version
)
982 (with-error-handling (:henv henv
)
983 (SQLSetEnvAttr henv $SQL_ATTR_ODBC_VERSION
984 (make-pointer version
:void
) 0)))
986 (defun %list-tables
(hstmt)
987 (with-error-handling (:hstmt hstmt
)
988 (SQLTables hstmt
+null-ptr
+ 0 +null-ptr
+ 0 +null-ptr
+ 0 +null-ptr
+ 0)))
990 (defun %table-statistics
(table hstmt
&key unique
(ensure t
))
991 (with-cstrings ((table-cs table
))
992 (with-error-handling (:hstmt hstmt
)
998 (if unique $SQL_INDEX_UNIQUE $SQL_INDEX_ALL
)
999 (if ensure $SQL_ENSURE $SQL_QUICK
)))))
1001 (defun %list-data-sources
(henv)
1002 (let ((dsn (allocate-foreign-string (1+ $SQL_MAX_DSN_LENGTH
)))
1003 (desc (allocate-foreign-string 256))
1006 (with-foreign-objects ((dsn-len :short
)
1008 (let ((res (with-error-handling (:henv henv
)
1009 (SQLDataSources henv $SQL_FETCH_FIRST dsn
1010 (1+ $SQL_MAX_DSN_LENGTH
)
1011 dsn-len desc
256 desc-len
))))
1012 (when (or (eql res $SQL_SUCCESS
)
1013 (eql res $SQL_SUCCESS_WITH_INFO
))
1014 (push (convert-from-foreign-string dsn
) results
))
1016 (do ((res (with-error-handling (:henv henv
)
1017 (SQLDataSources henv $SQL_FETCH_NEXT dsn
1018 (1+ $SQL_MAX_DSN_LENGTH
)
1019 dsn-len desc
256 desc-len
))
1020 (with-error-handling (:henv henv
)
1021 (SQLDataSources henv $SQL_FETCH_NEXT dsn
1022 (1+ $SQL_MAX_DSN_LENGTH
)
1023 dsn-len desc
256 desc-len
))))
1024 ((not (or (eql res $SQL_SUCCESS
)
1025 (eql res $SQL_SUCCESS_WITH_INFO
))))
1026 (push (convert-from-foreign-string dsn
) results
))))
1028 (free-foreign-object dsn
)
1029 (free-foreign-object desc
)))
1030 (nreverse results
)))