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