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