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