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