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