db-oracle/oracle-sql.lisp

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