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