Merge branch 'master' of git://git.b9.com/clsql
[clsql/s11.git] / db-oracle / oracle-sql.lisp
blobb0f5457417af9918874c9a138a4d830604d05bce
1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
4 ;;;;
5 ;;;; Name: oracle-sql.lisp
6 ;;;;
7 ;;;; $Id$
8 ;;;;
9 ;;;; This file is part of CLSQL.
10 ;;;;
11 ;;;; CLSQL users are granted the rights to distribute and use this software
12 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
13 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
14 ;;;; *************************************************************************
16 (in-package #:clsql-oracle)
18 (defmethod database-initialize-database-type ((database-type (eql :oracle)))
21 ;;;; arbitrary parameters, tunable for performance or other reasons
23 (eval-when (:compile-toplevel :load-toplevel :execute)
24 (defconstant +errbuf-len+ 512
25 "the number of characters that we allocate for an error message buffer")
26 (defconstant +n-buf-rows+ 200
27 "the number of table rows that we buffer at once when reading a table.
28 CMUCL has a compiled-in limit on how much C data can be allocated
29 (through malloc() and friends) at any given time, typically 8 Mb.
30 Setting this constant to a moderate value should make it less
31 likely that we'll have to worry about the CMUCL limit."))
34 (uffi:def-type vp-type :pointer-void)
35 (uffi:def-type vpp-type (* :pointer-void))
37 (defmacro deref-vp (foreign-object)
38 `(the vp-type (uffi:deref-pointer (the vpp-type ,foreign-object) :pointer-void)))
40 (uffi:def-pointer-var +unsigned-char-null-pointer+
41 (uffi:make-null-pointer :unsigned-char))
42 (uffi:def-pointer-var +unsigned-short-null-pointer+
43 (uffi:make-null-pointer :unsigned-short))
44 (uffi:def-pointer-var +unsigned-int-null-pointer+
45 (uffi:make-null-pointer :unsigned-int))
47 ;; constants - from OCI?
49 (defconstant +var-not-in-list+ 1007)
50 (defconstant +no-data-found+ 1403)
51 (defconstant +null-value-returned+ 1405)
52 (defconstant +field-truncated+ 1406)
54 (eval-when (:compile-toplevel :load-toplevel :execute)
55 (defconstant SQLT-NUMBER 2)
56 (defconstant SQLT-INT 3)
57 (defconstant SQLT-FLT 4)
58 (defconstant SQLT-STR 5)
59 (defconstant SQLT-DATE 12))
61 ;;; Note that despite the suggestive class name (and the way that the
62 ;;; *DEFAULT-DATABASE* variable holds an object of this class), a DB
63 ;;; object is not actually a database but is instead a connection to a
64 ;;; database. Thus, there's no obstacle to having any number of DB
65 ;;; objects referring to the same database.
67 (uffi:def-type pointer-pointer-void (* :pointer-void))
69 (defclass oracle-database (database) ; was struct db
70 ((envhp
71 :reader envhp
72 :initarg :envhp
73 :type pointer-pointer-void
74 :documentation
75 "OCI environment handle")
76 (errhp
77 :reader errhp
78 :initarg :errhp
79 :type pointer-pointer-void
80 :documentation
81 "OCI error handle")
82 (svchp
83 :reader svchp
84 :initarg :svchp
85 :type pointer-pointer-void
86 :documentation
87 "OCI service context handle")
88 (data-source-name
89 :initarg :dsn
90 :initform nil
91 :documentation
92 "optional data source name (used only for debugging/printing)")
93 (user
94 :initarg :user
95 :reader user
96 :type string
97 :documentation
98 "the \"user\" value given when data source connection was made")
99 (date-format
100 :initarg :date-format
101 :reader date-format
102 :initform "YYYY-MM-DD HH24:MI:SS\".0\"")
103 (date-format-length
104 :type number
105 :documentation
106 "Each database connection can be configured with its own date
107 output format. In order to extract date strings from output buffers
108 holding multiple date strings in fixed-width fields, we need to know
109 the length of that format.")
110 (server-version
111 :type (or null string)
112 :initarg :server-version
113 :reader server-version
114 :documentation
115 "Version string of Oracle server.")
116 (major-server-version
117 :type (or null fixnum)
118 :initarg :major-server-version
119 :reader major-server-version
120 :documentation
121 "The major version number of the Oracle server, should be 8, 9, or 10")))
123 ;;; Handle a non-successful result from an OCI function.
124 (defun handle-oci-result (result database nulls-ok)
125 (case result
126 (#.+oci-success+
127 +oci-success+)
128 (#.+oci-error+
129 (handle-oci-error :database database :nulls-ok nulls-ok))
130 (#.+oci-no-data+
131 (error 'sql-database-error :message "OCI No Data Found"))
132 (#.+oci-success-with-info+
133 (error 'sql-database-error :message "internal error: unexpected +oci-success-with-info"))
134 (#.+oci-invalid-handle+
135 (error 'sql-database-error :message "OCI Invalid Handle"))
136 (#.+oci-need-data+
137 (error 'sql-database-error :message "OCI Need Data"))
138 (#.+oci-still-executing+
139 (error 'sql-temporary-error :message "OCI Still Executing"))
140 (#.+oci-continue+
141 (error 'sql-database-error :message "OCI Continue"))
142 (1804
143 (error 'sql-database-error :message "Check ORACLE_HOME and NLS settings."))
145 (error 'sql-database-error
146 :message
147 (format nil "OCI unknown error, code=~A" result)))))
149 ;;; Handle the messy case of return code=+oci-error+, querying the
150 ;;; system for subcodes and reporting them as appropriate. ERRHP and
151 ;;; NULLS-OK are as in the OERR function.
153 (defun handle-oci-error (&key database nulls-ok)
154 (cond
155 (database
156 (with-slots (errhp) database
157 (let ((errcode (uffi:allocate-foreign-object 'sb4))
158 (errbuf (uffi:allocate-foreign-string #.+errbuf-len+)))
159 ;; ensure errbuf empty string
160 (setf (uffi:deref-array errbuf '(:array :unsigned-char) 0)
161 (uffi:ensure-char-storable (code-char 0)))
162 (setf (uffi:deref-pointer errcode 'sb4) 0)
164 (uffi:with-cstring (sqlstate nil)
165 (oci-error-get (deref-vp errhp) 1
166 sqlstate
167 errcode
168 (uffi:char-array-to-pointer errbuf)
169 +errbuf-len+ +oci-htype-error+))
170 (let ((subcode (uffi:deref-pointer errcode 'sb4))
171 (errstr (uffi:convert-from-foreign-string errbuf)))
172 (uffi:free-foreign-object errcode)
173 (uffi:free-foreign-object errbuf)
174 (unless (and nulls-ok (= subcode +null-value-returned+))
175 (error 'sql-database-error
176 :database database
177 :error-id subcode
178 :message errstr))))))
179 (nulls-ok
180 (error 'sql-database-error
181 :database database
182 :message "can't handle NULLS-OK without ERRHP"))
184 (error 'sql-database-error
185 :database database
186 :message "OCI Error (and no ERRHP available to find subcode)"))))
188 ;;; Require an OCI success code.
190 ;;; (The ordinary OCI error reporting mechanisms uses a fair amount of
191 ;;; machinery (environments and other handles). In order to get to
192 ;;; where we can use these mechanisms, we have to be able to allocate
193 ;;; the machinery. The functions for allocating the machinery can
194 ;;; return errors (e.g. out of memory) but shouldn't. Wrapping this function
195 ;;; around function calls to such have-to-succeed functions enforces
196 ;;; this condition.)
198 (defun osucc (code)
199 (declare (type fixnum code))
200 (unless (= code +oci-success+)
201 (error 'sql-database-error
202 :message (format nil "unexpected OCI failure, code=~S" code))))
205 ;;; Enabling this can be handy for low-level debugging.
206 #+nil
207 (progn
208 (trace #-oci7 oci-env-create oci-initialize oci-handle-alloc oci-logon
209 oci-error-get oci-stmt-prepare oci-stmt-execute
210 oci-param-get oci-logon oci-attr-get oci-define-by-pos oci-stmt-fetch)
211 (setf debug::*debug-print-length* nil))
214 ;; Return the INDEXth string of the OCI array, represented as Lisp
215 ;; SIMPLE-STRING. SIZE is the size of the fixed-width fields used by
216 ;; Oracle to store strings within the array.
218 (uffi:def-type string-pointer (* :unsigned-char))
220 (defun deref-oci-string (arrayptr string-index size)
221 (declare (type string-pointer arrayptr))
222 (declare (type (mod #.+n-buf-rows+) string-index))
223 (declare (type (and unsigned-byte fixnum) size))
224 (let ((str (uffi:convert-from-foreign-string
225 (uffi:make-pointer
226 (+ (uffi:pointer-address arrayptr) (* string-index size))
227 :unsigned-char))))
228 (if (string-equal str "NULL") nil str)))
230 ;; the OCI library, part Z: no-longer used logic to convert from
231 ;; Oracle's binary date representation to Common Lisp's native date
232 ;; representation
234 #+nil
235 (defvar +oci-date-bytes+ 7)
237 ;;; Return the INDEXth date in the OCI array, represented as
238 ;;; a Common Lisp "universal time" (i.e. seconds since 1900).
240 #+nil
241 (defun deref-oci-date (arrayptr index)
242 (oci-date->universal-time (uffi:pointer-address
243 (uffi:deref-array arrayptr
244 '(:array :unsigned-char)
245 (* index +oci-date-bytes+)))))
246 #+nil
247 (defun oci-date->universal-time (oci-date)
248 (declare (type (alien (* :unsigned-char)) oci-date))
249 (flet (;; a character from OCI-DATE, interpreted as an unsigned byte
250 (ub (i)
251 (declare (type (mod #.+oci-date-bytes+) i))
252 (mod (uffi:deref-array oci-date string-array i) 256)))
253 (let* ((century (* (- (ub 0) 100) 100))
254 (year (+ century (- (ub 1) 100)))
255 (month (ub 2))
256 (day (ub 3))
257 (hour (1- (ub 4)))
258 (minute (1- (ub 5)))
259 (second (1- (ub 6))))
260 (encode-universal-time second minute hour day month year))))
263 (defmethod database-list-tables ((database oracle-database) &key owner)
264 (let ((query
265 (cond ((null owner)
266 "select table_name from user_tables")
267 ((eq owner :all)
268 "select table_name from all_tables")
270 (format nil
271 "select user_tables.table_name from user_tables,all_tables where user_tables.table_name=all_tables.table_name and all_tables.owner='~:@(~A~)'"
272 owner)))))
273 (mapcar #'car (database-query query database nil nil))))
276 (defmethod database-list-views ((database oracle-database) &key owner)
277 (let ((query
278 (cond ((null owner)
279 "select view_name from user_views")
280 ((eq owner :all)
281 "select view_name from all_views")
283 (format nil
284 "select user_views.view_name from user_views,all_views where user_views.view_name=all_views.view_name and all_views.owner='~:@(~A~)'"
285 owner)))))
286 (mapcar #'car
287 (database-query query database nil nil))))
289 (defmethod database-list-indexes ((database oracle-database)
290 &key (owner nil))
291 (let ((query
292 (cond ((null owner)
293 "select index_name from user_indexes")
294 ((eq owner :all)
295 "select index_name from all_indexes")
296 (t (format nil
297 "select user_indexes.index_name from user_indexes,all_indexes where user_indexes.index_name=all_indexes.index_name and all_indexes.owner='~:@(~A~)'"
298 owner)))))
299 (mapcar #'car (database-query query database nil nil))))
301 (defmethod database-list-table-indexes (table (database oracle-database)
302 &key (owner nil))
303 (let ((query
304 (cond ((null owner)
305 (format nil "select index_name from user_indexes where table_name='~A'"
306 table))
307 ((eq owner :all)
308 (format nil "select index_name from all_indexes where table_name='~A'"
309 table))
311 (format nil
312 "select user_indexes.index_name from user_indexes,all_indexes where user_indexes.table_name='~A' and user_indexes.index_name=all_indexes.index_name and all_indexes.owner='~:@(~A~)'"
313 table owner)))))
314 (mapcar #'car (database-query query database nil nil))))
317 (defmethod database-list-attributes (table (database oracle-database) &key owner)
318 (let ((query
319 (cond ((null owner)
320 (format nil "select column_name from user_tab_columns where table_name='~A'"
321 table))
322 ((eq owner :all)
323 (format nil "select column_name from all_tab_columns where table_name='~A'"
324 table))
326 (format nil
327 "select user_tab_columns.column_name from user_tab_columns,all_tables where user_tab_columns.table_name='~A' and all_tables.table_name=user_tab_columns.table_name and all_tables.owner='~:@(~A~)'"
328 table owner)))))
329 (mapcar #'car (database-query query database nil nil))))
331 (defmethod database-attribute-type (attribute (table string)
332 (database oracle-database)
333 &key (owner nil))
334 (let ((query
335 (cond ((null owner)
336 (format nil
337 "select data_type,data_length,data_scale,nullable from user_tab_columns where table_name='~A' and column_name='~A'"
338 table attribute))
339 ((eq owner :all)
340 (format nil
341 "select data_type,data_length,data_scale,nullable from all_tab_columns where table_name='~A' and column_name='~A'"
342 table attribute))
344 (format nil
345 "select data_type,data_length,data_scale,nullable from user_tab_columns,all_tables where user_tab_columns.table_name='~A' and column_name='~A' and all_tables.table_name=user_tab_columns.table_name and all_tables.owner='~:@(~A~)'"
346 table attribute owner)))))
347 (destructuring-bind (type length scale nullable) (car (database-query query database :auto nil))
348 (values (ensure-keyword type) length scale
349 (if (char-equal #\Y (schar nullable 0)) 1 0)))))
351 ;; Return one row of the table referred to by QC, represented as a
352 ;; list; or if there are no more rows, signal an error if EOF-ERRORP,
353 ;; or return EOF-VALUE otherwise.
355 ;; KLUDGE: This CASE statement is a strong sign that the code would be
356 ;; cleaner if CD were made into an abstract class, we made variant
357 ;; classes for CD-for-column-of-strings, CD-for-column-of-floats,
358 ;; etc., and defined virtual functions to handle operations like
359 ;; get-an-element-from-column. (For a small special purpose module
360 ;; like this, would arguably be overkill, so I'm not going to do it
361 ;; now, but if this code ends up getting more complicated in
362 ;; maintenance, it would become a really good idea.)
364 ;; Arguably this would be a good place to signal END-OF-FILE, but
365 ;; since the ANSI spec specifically says that END-OF-FILE means a
366 ;; STREAM which has no more data, and QC is not a STREAM, we signal
367 ;; DBI-ERROR instead.
369 (uffi:def-type short-array (* :short))
370 (uffi:def-type int-array (* :int))
371 (uffi:def-type double-array (* :double))
372 (uffi:def-type int-pointer (* :int))
373 (uffi:def-type double-pointer (* :double))
375 ;;; the result of a database query: a cursor through a table
376 (defstruct (oracle-result-set (:print-function print-query-cursor)
377 (:conc-name qc-)
378 (:constructor %make-query-cursor))
379 (db (error "missing DB") ; db conn. this table is associated with
380 :type oracle-database
381 :read-only t)
382 (stmthp (error "missing STMTHP") ; the statement handle used to create
383 ;; :type alien ; this table. owned by the QUERY-CURSOR
384 :read-only t) ; object, deallocated on CLOSE-QUERY
385 (cds) ; (error "missing CDS") ; column descriptors
386 ; :type (simple-array cd 1)
387 ; :read-only t)
388 (n-from-oci
389 0 ; buffered rows: number of rows recv'd
390 :type (integer 0 #.+n-buf-rows+)) ; from the database on the last read
391 (n-to-dbi
392 0 ; number of buffered rows returned, i.e.
393 :type (integer 0 #.+n-buf-rows+)) ; the index, within the buffered rows,
394 ; of the next row which hasn't already
395 ; been returned
396 (total-n-from-oci
397 0 ; total number of bytes recv'd from OCI
398 :type unsigned-byte) ; in all reads
399 (oci-end-seen-p nil)) ; Have we seen the end of OCI
400 ; data, i.e. OCI returning
401 ; less data than we requested?
402 ; OCI doesn't seem to like us
403 ; to try to read more data
404 ; from it after that..
407 (defun fetch-row (qc &optional (eof-errorp t) eof-value)
408 (declare (optimize (speed 3)))
409 (cond ((zerop (qc-n-from-oci qc))
410 (if eof-errorp
411 (error 'sql-database-error :message
412 (format nil "no more rows available in ~S" qc))
413 eof-value))
414 ((>= (qc-n-to-dbi qc)
415 (qc-n-from-oci qc))
416 (refill-qc-buffers qc)
417 (fetch-row qc nil eof-value))
419 (let ((cds (qc-cds qc))
420 (reversed-result nil)
421 (irow (qc-n-to-dbi qc)))
422 (dotimes (icd (length cds))
423 (let* ((cd (aref cds icd))
424 (b (foreign-resource-buffer (cd-buffer cd)))
425 (value
426 (let* ((arb (foreign-resource-buffer (cd-indicators cd)))
427 (indicator (uffi:deref-array arb '(:array :short) irow)))
428 (declare (type short-array arb))
429 (unless (= indicator -1)
430 (ecase (cd-oci-data-type cd)
431 (#.SQLT-STR
432 (deref-oci-string b irow (cd-sizeof cd)))
433 (#.SQLT-FLT
434 (locally
435 (declare (type double-array b))
436 (uffi:deref-array b '(:array :double) irow)))
437 (#.SQLT-INT
438 (ecase (cd-sizeof cd)
440 (locally
441 (declare (type int-array b))
442 (uffi:deref-array b '(:array :int) irow)))))
443 (#.SQLT-DATE
444 (deref-oci-string b irow (cd-sizeof cd))))))))
445 (when (and (eq :string (cd-result-type cd))
446 value
447 (not (stringp value)))
448 (setq value (write-to-string value)))
449 (push value reversed-result)))
450 (incf (qc-n-to-dbi qc))
451 (nreverse reversed-result)))))
453 (defun refill-qc-buffers (qc)
454 (with-slots (errhp) (qc-db qc)
455 (setf (qc-n-to-dbi qc) 0)
456 (cond ((qc-oci-end-seen-p qc)
457 (setf (qc-n-from-oci qc) 0))
459 (let ((oci-code (%oci-stmt-fetch
460 (deref-vp (qc-stmthp qc))
461 (deref-vp errhp)
462 +n-buf-rows+
463 +oci-fetch-next+ +oci-default+)))
464 (ecase oci-code
465 (#.+oci-success+ (values))
466 (#.+oci-no-data+ (setf (qc-oci-end-seen-p qc) t)
467 (values))
468 (#.+oci-error+ (handle-oci-error :database (qc-db qc)
469 :nulls-ok t))))
470 (uffi:with-foreign-object (rowcount 'ub4)
471 (oci-attr-get (deref-vp (qc-stmthp qc))
472 +oci-htype-stmt+
473 rowcount
474 +unsigned-int-null-pointer+
475 +oci-attr-row-count+
476 (deref-vp errhp))
477 (setf (qc-n-from-oci qc)
478 (- (uffi:deref-pointer rowcount 'ub4)
479 (qc-total-n-from-oci qc)))
480 (when (< (qc-n-from-oci qc) +n-buf-rows+)
481 (setf (qc-oci-end-seen-p qc) t))
482 (setf (qc-total-n-from-oci qc)
483 (uffi:deref-pointer rowcount 'ub4)))))
484 (values)))
486 ;; the guts of the SQL function
488 ;; (like the SQL function, but with the QUERY argument hardwired to T, so
489 ;; that the return value is always a cursor instead of a list)
491 ;; Is this a SELECT statement? SELECT statements are handled
492 ;; specially by OCIStmtExecute(). (Non-SELECT statements absolutely
493 ;; require a nonzero iteration count, while the ordinary choice for a
494 ;; SELECT statement is a zero iteration count.
496 ;; SELECT statements are the only statements which return tables. We
497 ;; don't free STMTHP in this case, but instead give it to the new
498 ;; QUERY-CURSOR, and the new QUERY-CURSOR becomes responsible for
499 ;; freeing the STMTHP when it is no longer needed.
501 (defun sql-stmt-exec (sql-stmt-string db result-types field-names)
502 (with-slots (envhp svchp errhp) db
503 (uffi:with-foreign-strings ((c-stmt-string sql-stmt-string))
504 (let ((stmthp (uffi:allocate-foreign-object :pointer-void))
505 select-p)
507 (uffi:with-foreign-object (stmttype :unsigned-short)
508 (unwind-protect
509 (progn
510 (oci-handle-alloc (deref-vp envhp)
511 stmthp
512 +oci-htype-stmt+ 0 +null-void-pointer-pointer+)
513 (oci-stmt-prepare (deref-vp stmthp)
514 (deref-vp errhp)
515 c-stmt-string
516 (length sql-stmt-string)
517 +oci-ntv-syntax+ +oci-default+ :database db)
518 (oci-attr-get (deref-vp stmthp)
519 +oci-htype-stmt+
520 stmttype
521 +unsigned-int-null-pointer+
522 +oci-attr-stmt-type+
523 (deref-vp errhp)
524 :database db)
526 (setq select-p (= (uffi:deref-pointer stmttype :unsigned-short) 1))
527 (let ((iters (if select-p 0 1)))
529 (oci-stmt-execute (deref-vp svchp)
530 (deref-vp stmthp)
531 (deref-vp errhp)
532 iters 0 +null-void-pointer+ +null-void-pointer+ +oci-default+
533 :database db)))
534 ;; free resources unless a query
535 (unless select-p
536 (oci-handle-free (deref-vp stmthp) +oci-htype-stmt+)
537 (uffi:free-foreign-object stmthp))))
539 (cond
540 (select-p
541 (make-query-cursor db stmthp result-types field-names))
543 nil))))))
546 ;; Return a QUERY-CURSOR representing the table returned from the OCI
547 ;; operation done through STMTHP. TYPES is the argument of the same
548 ;; name from the external SQL function, controlling type conversion
549 ;; of the returned arguments.
551 (defun make-query-cursor (db stmthp result-types field-names)
552 (let ((qc (%make-query-cursor :db db
553 :stmthp stmthp
554 :cds (make-query-cursor-cds db stmthp
555 result-types
556 field-names))))
557 (refill-qc-buffers qc)
558 qc))
561 ;; the hairy part of MAKE-QUERY-CURSOR: Ask OCI for information
562 ;; about table columns, translate the information into a Lisp
563 ;; vector of column descriptors, and return it.
565 ;; Allegro defines several flavors of type conversion, but this
566 ;; implementation only supports the :AUTO flavor.
568 ;; A note of explanation: OCI's internal number format uses 21
569 ;; bytes (42 decimal digits). 2 separate (?) one-byte fields,
570 ;; scale and precision, are used to deduce the nature of these
571 ;; 21 bytes. See pp. 3-10, 3-26, and 6-13 of OCI documentation
572 ;; for more details.
574 ;; Mac OS X Note: According to table 6-8 in the Oracle 9i OCI
575 ;; documentation, PRECISION may actually be an sb2 instead of a
576 ;; single byte if performing an "implicit describe". Using a
577 ;; signed short instead of an unsigned byte fixes a Mac OS X bug
578 ;; where PRECISION is always zero. -- JJB 20040713
580 ;; When calling OCI C code to handle the conversion, we have
581 ;; only two numeric types available to pass the return value:
582 ;; double-float and signed-long. It would be possible to
583 ;; bypass the OCI conversion functions and write Lisp code
584 ;; which reads the 21-byte field directly and decodes
585 ;; it. However this is left as an exercise for the reader. :-)
587 ;; The following table describes the mapping, based on the implicit
588 ;; assumption that C's "signed long" type is a 32-bit integer.
590 ;; Internal Values SQL Type C Return Type
591 ;; =============== ======== =============
592 ;; Precision > 0 SCALE = -127 FLOAT --> double-float
593 ;; Precision > 0 && <=9 SCALE = 0 INTEGER --> signed-long
594 ;; Precision = 0 || > 9 SCALE = 0 BIG INTEGER --> double-float
595 ;; Precision > 0 SCALE > 0 DECIMAL --> double-float
597 ;; (OCI uses 1-based indexing here.)
599 ;; KLUDGE: This should work for all other data types except those
600 ;; which don't actually fit in their fixed-width field (BLOBs and the
601 ;; like). As Winton says, we (Cadabra) don't need to worry much about
602 ;; those, since we can't reason with them, so we don't use them. But
603 ;; for a more general application it'd be good to have a more
604 ;; selective and rigorously correct test here for whether we can
605 ;; actually handle the given DEREF-DTYPE value. -- WHN 20000106
607 ;; Note: The OCI documentation doesn't seem to say whether the COLNAME
608 ;; value returned here is a newly-allocated copy which we're
609 ;; responsible for freeing, or a pointer into some system copy which
610 ;; will be freed when the system itself is shut down. But judging
611 ;; from the way that the result is used in the cdemodsa.c example
612 ;; program, it looks like the latter: we should make our own copy of
613 ;; the value, but not try to free it.
615 ;; WORKAROUND: OCI seems to return ub2 values for the
616 ;; +oci-attr-data-size+ attribute even though its documentation claims
617 ;; that it returns a ub4, and even though the associated "sizep" value
618 ;; is 4, not 2. In order to make the code here work reliably, without
619 ;; having to patch it later if OCI is ever fixed to match its
620 ;; documentation, we pre-zero COLSIZE before making the call into OCI.
622 ;; To exercise the weird OCI behavior (thereby blowing up the code
623 ;; below, beware!) try setting this value into COLSIZE, calling OCI,
624 ;; then looking at the value in COLSIZE. (setf colsize #x12345678)
625 ;; debugging only
627 ;; Mac OS X Note: This workaround fails on a bigendian platform so
628 ;; I've changed the data type of COLNAME to :unsigned-short as per
629 ;; the Oracle 9i OCI documentation. -- JJB 20040713
631 (uffi:def-type byte-pointer (* :byte))
632 (uffi:def-type void-pointer-pointer (* :void-pointer))
634 (defun make-query-cursor-cds (database stmthp result-types field-names)
635 (declare (optimize (safety 3) #+nil (speed 3))
636 (type oracle-database database)
637 (type pointer-pointer-void stmthp))
638 (with-slots (errhp) database
639 (uffi:with-foreign-objects ((dtype-foreign :unsigned-short)
640 (parmdp :pointer-void)
641 (precision :short)
642 (scale :byte)
643 (colname '(* :unsigned-char))
644 (colnamelen 'ub4)
645 (colsize 'ub2)
646 (defnp ':pointer-void))
647 (let ((buffer nil)
648 (sizeof nil))
649 (do ((icolumn 0 (1+ icolumn))
650 (cds-as-reversed-list nil))
651 ((not (eql (oci-param-get (deref-vp stmthp)
652 +oci-htype-stmt+
653 (deref-vp errhp)
654 parmdp
655 (1+ icolumn) :database database)
656 +oci-success+))
657 (coerce (reverse cds-as-reversed-list) 'simple-vector))
658 ;; Decode type of ICOLUMNth column into a type we're prepared to
659 ;; handle in Lisp.
660 (oci-attr-get (deref-vp parmdp)
661 +oci-dtype-param+
662 dtype-foreign
663 +unsigned-int-null-pointer+
664 +oci-attr-data-type+
665 (deref-vp errhp))
666 (let ((dtype (uffi:deref-pointer dtype-foreign :unsigned-short)))
667 (declare (fixnum dtype))
668 (case dtype
669 (#.SQLT-DATE
670 (setf buffer (acquire-foreign-resource :unsigned-char
671 (* 32 +n-buf-rows+)))
672 (setf sizeof 32 dtype #.SQLT-STR))
673 (#.SQLT-NUMBER
674 (oci-attr-get (deref-vp parmdp)
675 +oci-dtype-param+
676 precision
677 +unsigned-int-null-pointer+
678 +oci-attr-precision+
679 (deref-vp errhp))
680 (oci-attr-get (deref-vp parmdp)
681 +oci-dtype-param+
682 scale
683 +unsigned-int-null-pointer+
684 +oci-attr-scale+
685 (deref-vp errhp))
686 (let ((*scale (uffi:deref-pointer scale :byte))
687 (*precision (uffi:deref-pointer precision :short)))
689 ;;(format t "scale=~d, precision=~d~%" *scale *precision)
690 (cond
691 ((or (and (minusp *scale) (zerop *precision))
692 (and (zerop *scale) (plusp *precision)))
693 (setf buffer (acquire-foreign-resource :int +n-buf-rows+)
694 sizeof 4 ;; sizeof(int)
695 dtype #.SQLT-INT))
697 (setf buffer (acquire-foreign-resource :double +n-buf-rows+)
698 sizeof 8 ;; sizeof(double)
699 dtype #.SQLT-FLT)))))
700 ;; Default to SQL-STR
702 (setf (uffi:deref-pointer colsize :unsigned-short) 0)
703 (setf dtype #.SQLT-STR)
704 (oci-attr-get (deref-vp parmdp)
705 +oci-dtype-param+
706 colsize
707 +unsigned-int-null-pointer+
708 +oci-attr-data-size+
709 (deref-vp errhp))
710 (let ((colsize-including-null (1+ (uffi:deref-pointer colsize :unsigned-short))))
711 (setf buffer (acquire-foreign-resource
712 :unsigned-char (* +n-buf-rows+ colsize-including-null)))
713 (setf sizeof colsize-including-null))))
714 (let ((retcodes (acquire-foreign-resource :unsigned-short +n-buf-rows+))
715 (indicators (acquire-foreign-resource :short +n-buf-rows+))
716 (colname-string ""))
717 (when field-names
718 (oci-attr-get (deref-vp parmdp)
719 +oci-dtype-param+
720 colname
721 colnamelen
722 +oci-attr-name+
723 (deref-vp errhp))
724 (setq colname-string (uffi:convert-from-foreign-string
725 (uffi:deref-pointer colname '(* :unsigned-char))
726 :length (uffi:deref-pointer colnamelen 'ub4))))
727 (push (make-cd :name colname-string
728 :sizeof sizeof
729 :buffer buffer
730 :oci-data-type dtype
731 :retcodes retcodes
732 :indicators indicators
733 :result-type (cond
734 ((consp result-types)
735 (nth icolumn result-types))
736 ((null result-types)
737 :string)
739 result-types)))
740 cds-as-reversed-list)
741 (oci-define-by-pos (deref-vp stmthp)
742 defnp
743 (deref-vp errhp)
744 (1+ icolumn) ; OCI 1-based indexing again
745 (foreign-resource-buffer buffer)
746 sizeof
747 dtype
748 (foreign-resource-buffer indicators)
749 +unsigned-short-null-pointer+
750 (foreign-resource-buffer retcodes)
751 +oci-default+))))))))
753 ;; Release the resources associated with a QUERY-CURSOR.
755 (defun close-query (qc)
756 (oci-handle-free (deref-vp (qc-stmthp qc)) +oci-htype-stmt+)
757 (uffi:free-foreign-object (qc-stmthp qc))
758 (let ((cds (qc-cds qc)))
759 (dotimes (i (length cds))
760 (release-cd-resources (aref cds i))))
761 (values))
764 ;; Release the resources associated with a column description.
766 (defun release-cd-resources (cd)
767 (free-foreign-resource (cd-buffer cd))
768 (free-foreign-resource (cd-retcodes cd))
769 (free-foreign-resource (cd-indicators cd))
770 (values))
773 (defmethod database-name-from-spec (connection-spec (database-type (eql :oracle)))
774 (check-connection-spec connection-spec database-type (dsn user password))
775 (destructuring-bind (dsn user password) connection-spec
776 (declare (ignore password))
777 (concatenate 'string dsn "/" user)))
780 (defmethod database-connect (connection-spec (database-type (eql :oracle)))
781 (check-connection-spec connection-spec database-type (dsn user password))
782 (destructuring-bind (data-source-name user password)
783 connection-spec
784 (let ((envhp (uffi:allocate-foreign-object :pointer-void))
785 (errhp (uffi:allocate-foreign-object :pointer-void))
786 (svchp (uffi:allocate-foreign-object :pointer-void))
787 (srvhp (uffi:allocate-foreign-object :pointer-void)))
788 ;; Requests to allocate environments and handles should never
789 ;; fail in normal operation, and they're done too early to
790 ;; handle errors very gracefully (since they're part of the
791 ;; error-handling mechanism themselves) so we just assert they
792 ;; work.
794 (setf (deref-vp envhp) +null-void-pointer+)
796 #-oci7
797 (oci-env-create envhp +oci-default+ +null-void-pointer+
798 +null-void-pointer+ +null-void-pointer+
799 +null-void-pointer+ 0 +null-void-pointer-pointer+)
801 #+oci7
802 (progn
803 (oci-initialize +oci-object+ +null-void-pointer+ +null-void-pointer+
804 +null-void-pointer+ +null-void-pointer-pointer+)
805 (ignore-errors (oci-handle-alloc +null-void-pointer+ envhp
806 +oci-htype-env+ 0
807 +null-void-pointer-pointer+)) ;no testing return
808 (oci-env-init envhp +oci-default+ 0 +null-void-pointer-pointer+))
810 (oci-handle-alloc (deref-vp envhp) errhp
811 +oci-htype-error+ 0 +null-void-pointer-pointer+)
812 (oci-handle-alloc (deref-vp envhp) srvhp
813 +oci-htype-server+ 0 +null-void-pointer-pointer+)
815 (let ((db (make-instance 'oracle-database
816 :name (database-name-from-spec connection-spec
817 database-type)
818 :connection-spec connection-spec
819 :envhp envhp
820 :errhp errhp
821 :database-type :oracle
822 :svchp svchp
823 :dsn data-source-name
824 :user user)))
825 (uffi:with-foreign-strings ((c-user user)
826 (c-password password)
827 (c-data-source-name data-source-name))
828 (oci-logon (deref-vp envhp)
829 (deref-vp errhp)
830 svchp
831 c-user (length user)
832 c-password (length password)
833 c-data-source-name (length data-source-name)
834 :database db))
835 ;; :date-format-length (1+ (length date-format)))))
836 (setf (slot-value db 'clsql-sys::state) :open)
837 (database-execute-command
838 (format nil "ALTER SESSION SET NLS_DATE_FORMAT='~A'" (date-format db)) db)
839 (let ((server-version
840 (caar (database-query
841 "SELECT BANNER FROM V$VERSION WHERE BANNER LIKE '%Oracle%'" db nil nil))))
842 (setf (slot-value db 'server-version) server-version
843 (slot-value db 'major-server-version) (major-client-version-from-string
844 server-version)))
845 db))))
848 (defun major-client-version-from-string (str)
849 (cond
850 ((search " 10g " str)
852 ((search "Oracle9i " str)
854 ((search "Oracle8" str)
855 8)))
857 (defun major-server-version-from-string (str)
858 (when (> (length str) 2)
859 (cond
860 ((string= "10." (subseq str 0 3))
862 ((string= "9." (subseq str 0 2))
864 ((string= "8." (subseq str 0 2))
865 8))))
868 ;; Close a database connection.
870 (defmethod database-disconnect ((database oracle-database))
871 (osucc (oci-logoff (deref-vp (svchp database))
872 (deref-vp (errhp database))))
873 (osucc (oci-handle-free (deref-vp (envhp database)) +oci-htype-env+))
874 ;; Note: It's neither required nor allowed to explicitly deallocate the
875 ;; ERRHP handle here, since it's owned by the ENVHP deallocated above,
876 ;; and was therefore automatically deallocated at the same time.
879 ;;; Do the database operation described in SQL-STMT-STRING on database
880 ;;; DB and, if the command is a SELECT, return a representation of the
881 ;;; resulting table. The representation of the table is controlled by the
882 ;;; QUERY argument:
883 ;;; * If QUERY is NIL, the table is returned as a list of rows, with
884 ;;; each row represented by a list.
885 ;;; * If QUERY is non-NIL, the result is returned as a QUERY-CURSOR
886 ;;; suitable for FETCH-ROW and CLOSE-QUERY
887 ;;; The TYPES argument controls the type conversion method used
888 ;;; to construct the table. The Allegro version supports several possible
889 ;;; values for this argument, but we only support :AUTO.
891 (defmethod database-query (query-expression (database oracle-database) result-types field-names)
892 (let ((cursor (sql-stmt-exec query-expression database result-types field-names)))
893 ;; (declare (type (or query-cursor null) cursor))
894 (if (null cursor) ; No table was returned.
895 (values)
896 (do ((reversed-result nil))
897 (nil)
898 (let* ((eof-value :eof)
899 (row (fetch-row cursor nil eof-value)))
900 (when (eq row eof-value)
901 (close-query cursor)
902 (if field-names
903 (return (values (nreverse reversed-result)
904 (loop for cd across (qc-cds cursor)
905 collect (cd-name cd))))
906 (return (nreverse reversed-result))))
907 (push row reversed-result))))))
910 (defmethod database-create-sequence (sequence-name (database oracle-database))
911 (execute-command
912 (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
913 :database database))
915 (defmethod database-drop-sequence (sequence-name (database oracle-database))
916 (execute-command
917 (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name))
918 :database database))
920 (defmethod database-sequence-next (sequence-name (database oracle-database))
921 (caar (database-query
922 (concatenate 'string "SELECT "
923 (sql-escape sequence-name)
924 ".NEXTVAL FROM dual")
925 database :auto nil)))
927 (defmethod database-sequence-last (sequence-name (database oracle-database))
928 (caar (database-query
929 (concatenate 'string "SELECT "
930 (sql-escape sequence-name)
931 ".CURRVAL FROM dual")
932 database :auto nil)))
934 (defmethod database-set-sequence-position (name position (database oracle-database))
935 (without-interrupts
936 (let* ((next (database-sequence-next name database))
937 (incr (- position next)))
938 (unless (zerop incr)
939 (database-execute-command
940 (format nil "ALTER SEQUENCE ~A INCREMENT BY ~D" name incr)
941 database))
942 (database-sequence-next name database)
943 (database-execute-command
944 (format nil "ALTER SEQUENCE ~A INCREMENT BY 1" name)
945 database))))
947 (defmethod database-list-sequences ((database oracle-database) &key owner)
948 (let ((query
949 (cond ((null owner)
950 "select sequence_name from user_sequences")
951 ((eq owner :all)
952 "select sequence_name from all_sequences")
954 (format nil
955 "select user_sequences.sequence_name from user_sequences,all_sequences where user_sequences.sequence_name=all_sequences.sequence_name and all_sequences.sequence_owner='~:@(~A~)'"
956 owner)))))
957 (mapcar #'car (database-query query database nil nil))))
959 (defmethod database-execute-command (sql-expression (database oracle-database))
960 (database-query sql-expression database nil nil)
961 (when (database-autocommit database)
962 (oracle-commit database))
966 (defstruct (cd (:constructor make-cd)
967 (:print-function print-cd))
968 "a column descriptor: metadata about the data in a table"
970 ;; name of this column
971 (name (error "missing NAME") :type simple-string :read-only t)
972 ;; the size in bytes of a single element
973 (sizeof (error "missing SIZE") :type fixnum :read-only t)
974 ;; an array of +N-BUF-ROWS+ elements in C representation
975 (buffer (error "Missing BUFFER")
976 :type foreign-resource
977 :read-only t)
978 ;; an array of +N-BUF-ROWS+ OCI return codes in C representation.
979 ;; (There must be one return code for every element of every
980 ;; row in order to be able to represent nullness.)
981 (retcodes (error "Missing RETCODES")
982 :type foreign-resource
983 :read-only t)
984 (indicators (error "Missing INDICATORS")
985 :type foreign-resource
986 :read-only t)
987 ;; the OCI code for the data type of a single element
988 (oci-data-type (error "missing OCI-DATA-TYPE")
989 :type fixnum
990 :read-only t)
991 (result-type (error "missing RESULT-TYPE")
992 :read-only t))
995 (defun print-cd (cd stream depth)
996 (declare (ignore depth))
997 (print-unreadable-object (cd stream :type t)
998 (format stream
999 ":NAME ~S :OCI-DATA-TYPE ~S :OCI-DATA-SIZE ~S"
1000 (cd-name cd)
1001 (cd-oci-data-type cd)
1002 (cd-sizeof cd))))
1004 (defun print-query-cursor (qc stream depth)
1005 (declare (ignore depth))
1006 (print-unreadable-object (qc stream :type t :identity t)
1007 (prin1 (qc-db qc) stream)))
1010 (defmethod database-query-result-set ((query-expression string)
1011 (database oracle-database)
1012 &key full-set result-types)
1013 (let ((cursor (sql-stmt-exec query-expression database result-types nil)))
1014 (if full-set
1015 (values cursor (length (qc-cds cursor)) nil)
1016 (values cursor (length (qc-cds cursor))))))
1019 (defmethod database-dump-result-set (result-set (database oracle-database))
1020 (close-query result-set))
1022 (defmethod database-store-next-row (result-set (database oracle-database) list)
1023 (let* ((eof-value :eof)
1024 (row (fetch-row result-set nil eof-value)))
1025 (unless (eq eof-value row)
1026 (loop for i from 0 below (length row)
1027 do (setf (nth i list) (nth i row)))
1028 list)))
1030 (defmethod database-start-transaction ((database oracle-database))
1031 (call-next-method)
1032 ;; Not needed with simple transaction
1033 #+ignore
1034 (with-slots (svchp errhp) database
1035 (oci-trans-start (deref-vp svchp)
1036 (deref-vp errhp)
1038 +oci-trans-new+))
1042 (defun oracle-commit (database)
1043 (with-slots (svchp errhp) database
1044 (osucc (oci-trans-commit (deref-vp svchp)
1045 (deref-vp errhp)
1046 0))))
1048 (defmethod database-commit-transaction ((database oracle-database))
1049 (call-next-method)
1050 (oracle-commit database)
1053 (defmethod database-abort-transaction ((database oracle-database))
1054 (call-next-method)
1055 (osucc (oci-trans-rollback (deref-vp (svchp database))
1056 (deref-vp (errhp database))
1060 ;; Specifications
1062 (defmethod db-type-has-bigint? ((type (eql :oracle)))
1063 nil)
1065 (defmethod db-type-has-fancy-math? ((db-type (eql :oracle)))
1068 (defmethod db-type-has-boolean-where? ((db-type (eql :oracle)))
1069 nil)
1071 (when (clsql-sys:database-type-library-loaded :oracle)
1072 (clsql-sys:initialize-database-type :database-type :oracle))