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