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