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