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