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