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