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