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