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