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