db-oracle/oracle-sql.lisp

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