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