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