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