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