(in-package #:clsql-oracle)
-(defmethod database-initialize-database-type
- ((database-type (eql :oracle)))
+(defmethod database-initialize-database-type ((database-type (eql :oracle)))
t)
-;;;; KLUDGE: The original prototype of this code was implemented using
-;;;; lots of special variables holding MAKE-ALIEN values. When I was
-;;;; first converting it to use WITH-ALIEN variables, I was confused
-;;;; about the behavior of MAKE-ALIEN and WITH-ALIEN; I thought that
-;;;; (MAKE-ALIEN TYPEFOO) returned the same type of object as is bound
-;;;; to the name BAR by (WITH-ALIEN ((BAR TYPEFOO)) ..). In fact the
-;;;; value returned by MAKE-ALIEN has an extra level of indirection
-;;;; relative to the value bound by WITH-ALIEN, i.e. (DEREF
-;;;; (MAKE-ALIEN TYPEFOO)) has the same type as the value bound to the
-;;;; name BAR by (WITH-ALIEN ((BAR TYPEFOO)) ..). Laboring under my
-;;;; misunderstanding, I was unable to use ordinary scalars bound by
-;;;; WITH-ALIEN, and I ended up giving up and deciding to work around
-;;;; this apparent bug in CMUCL by using 1-element arrays instead.
-;;;; This "workaround" for my misunderstanding is obviously unnecessary
-;;;; and confusing, but still remains in the code. -- WHN 20000106
-
-
;;;; arbitrary parameters, tunable for performance or other reasons
-(uffi:def-foreign-type void-pointer (* :void))
-
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +errbuf-len+ 512
"the number of characters that we allocate for an error message buffer")
likely that we'll have to worry about the CMUCL limit."))
-;;; utilities for mucking around with C-level stuff
+(uffi:def-type vp-type :pointer-void)
+(uffi:def-type vpp-type (* :pointer-void))
-;; Return the address of ALIEN-OBJECT (like the C operator "&").
-;;
-;; The INDICES argument is useful to give the ALIEN-OBJECT the
-;; expected number of zero indices, especially when we have a bunch of
-;; 1-element arrays running around due to the workaround for the CMUCL
-;; 18b WITH-ALIEN scalar bug.
-
-(defmacro c-& (alien-object type)
- `(uffi:pointer-address (uffi:deref-pointer ,alien-object ,type)))
+(defmacro deref-vp (foreign-object)
+ `(the vp-type (uffi:deref-pointer (the vpp-type ,foreign-object) :pointer-void)))
;; constants - from OCI?
+(defvar +unsigned-char-null-pointer+
+ (uffi:make-null-pointer :unsigned-char))
+(defvar +unsigned-short-null-pointer+
+ (uffi:make-null-pointer :unsigned-short))
+(defvar +unsigned-int-null-pointer+
+ (uffi:make-null-pointer :unsigned-int))
+
(defconstant +var-not-in-list+ 1007)
(defconstant +no-data-found+ 1403)
(defconstant +null-value-returned+ 1405)
(defconstant +field-truncated+ 1406)
(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant SQLT-NUMBER 2)
(defconstant SQLT-INT 3)
- (defconstant SQLT-STR 5)
(defconstant SQLT-FLT 4)
+ (defconstant SQLT-STR 5)
(defconstant SQLT-DATE 12))
;;; Note that despite the suggestive class name (and the way that the
;;; database. Thus, there's no obstacle to having any number of DB
;;; objects referring to the same database.
-(uffi:def-type pointer-pointer-void '(* (* :void)))
+(uffi:def-type pointer-pointer-void '(* :pointer-void))
(defclass oracle-database (database) ; was struct db
((envhp
"Each database connection can be configured with its own date
output format. In order to extract date strings from output buffers
holding multiple date strings in fixed-width fields, we need to know
-the length of that format.")))
+the length of that format.")
+ (server-version
+ :type (or null string)
+ :initarg :server-version
+ :reader server-version
+ :documentation
+ "Version string of Oracle server.")
+ (major-server-version
+ :type (or null fixnum)
+ :initarg :major-server-version
+ :reader major-server-version
+ :documentation
+ "The major version number of the Oracle server, should be 8, 9, or 10")
+ (client-version
+ :type (or null string)
+ :initarg :client-version
+ :reader client-version
+ :documentation
+ "Version string of Oracle client.")
+ (major-client-version
+ :type (or null fixnum)
+ :initarg :major-client-version
+ :reader major-client-version
+ :documentation
+ "The major version number of the Oracle client, should be 8, 9, or 10")))
;;; Handle the messy case of return code=+oci-error+, querying the
(defun handle-oci-error (&key database nulls-ok)
(cond (database
- (with-slots (errhp)
- database
- (uffi:with-foreign-objects ((errbuf (:array :unsigned-char #.+errbuf-len+))
+ (with-slots (errhp) database
+ (uffi:with-foreign-objects ((errbuf '(:array :unsigned-char
+ #.+errbuf-len+))
(errcode :long))
- (setf (uffi:deref-array errbuf '(:array :unsigned-char) 0) (code-char 0)) ; i.e. init to empty string
+ ;; ensure errbuf empty string
+ (setf (uffi:deref-array errbuf '(:array :unsigned-char) 0)
+ (uffi:ensure-char-storable (code-char 0)))
+
(setf (uffi:deref-pointer errcode :long) 0)
- (oci-error-get (uffi:deref-pointer errhp void-pointer) 1
- (uffi:make-null-pointer :unsigned-char)
- errcode errbuf +errbuf-len+ +oci-htype-error+)
+ (uffi:with-cstring (sqlstate nil)
+ (oci-error-get (deref-vp errhp) 1
+ sqlstate
+ errcode
+ (uffi:char-array-to-pointer errbuf)
+ +errbuf-len+ +oci-htype-error+))
(let ((subcode (uffi:deref-pointer errcode :long)))
(unless (and nulls-ok (= subcode +null-value-returned+))
- (error 'clsql-sql-error
+ (error 'sql-database-error
:database database
- :errno subcode
- :expression nil
- :error (uffi:convert-from-foreign-string errbuf)))))))
+ :error-id subcode
+ :message (uffi:convert-from-foreign-string errbuf)))))))
(nulls-ok
- (error 'clsql-sql-error
+ (error 'sql-database-error
:database database
:message "can't handle NULLS-OK without ERRHP"))
(t
- (error 'clsql-sql-error
+ (error 'sql-database-error
:database database
:message "OCI Error (and no ERRHP available to find subcode)"))))
(defun osucc (code)
(declare (type fixnum code))
(unless (= code +oci-success+)
- (error 'dbi-error
- :format-control "unexpected OCI failure, code=~S"
- :format-arguments (list code))))
+ (error 'sql-database-error
+ :message (format nil "unexpected OCI failure, code=~S" code))))
;;; Enabling this can be handy for low-level debugging.
(setf debug::*debug-print-length* nil))
-;;;; the OCI library, part V: converting from OCI representations to Lisp
-;;;; representations
-
;; Return the INDEXth string of the OCI array, represented as Lisp
;; SIMPLE-STRING. SIZE is the size of the fixed-width fields used by
;; Oracle to store strings within the array.
-;; In the wild world of databases, trailing spaces aren't generally
-;; significant, since e.g. "LARRY " and "LARRY " are the same string
-;; stored in different fixed-width fields. OCI drops trailing spaces
-;; for us in some cases but apparently not for fields of fixed
-;; character width, e.g.
-;;
-;; (dbi:sql "create table employees (name char(15), job char(15), city
-;; char(15), rate float)" :db orcl :types :auto)
-;; In order to map the "same string" property above onto Lisp equality,
-;; we drop trailing spaces in all cases:
-
(uffi:def-type string-pointer (* :unsigned-char))
(defun deref-oci-string (arrayptr string-index size)
(declare (type string-pointer arrayptr))
(declare (type (mod #.+n-buf-rows+) string-index))
(declare (type (and unsigned-byte fixnum) size))
- (let* ((raw (uffi:convert-from-foreign-string
- (+ (uffi:pointer-address arrayptr) (* string-index size))))
- (trimmed (string-trim " " raw)))
- (if (equal trimmed "NULL") nil trimmed)))
+ (let ((str (uffi:convert-from-foreign-string
+ (uffi:make-pointer
+ (+ (uffi:pointer-address arrayptr) (* string-index size))
+ :unsigned-char))))
+ (if (string-equal str "NULL") nil str)))
;; the OCI library, part Z: no-longer used logic to convert from
;; Oracle's binary date representation to Common Lisp's native date
#+nil
(defun deref-oci-date (arrayptr index)
- (oci-date->universal-time (uffi:pointer-address (uffi:deref-array arrayptr '(:array :unsigned-char)
- (* index +oci-date-bytes+)))))
+ (oci-date->universal-time (uffi:pointer-address
+ (uffi:deref-array arrayptr
+ '(:array :unsigned-char)
+ (* index +oci-date-bytes+)))))
#+nil
(defun oci-date->universal-time (oci-date)
(declare (type (alien (* :unsigned-char)) oci-date))
(flet (;; a character from OCI-DATE, interpreted as an unsigned byte
(ub (i)
(declare (type (mod #.+oci-date-bytes+) i))
- (mod (uffi:deref-array oci-date string-pointer i) 256)))
+ (mod (uffi:deref-array oci-date string-array i) 256)))
(let* ((century (* (- (ub 0) 100) 100))
(year (+ century (- (ub 1) 100)))
(month (ub 2))
(second (1- (ub 6))))
(encode-universal-time second minute hour day month year))))
-;; Return (VALUES ALL-TABLES COLUMN-NAMES), where ALL-TABLES is a
-;; table containing one row for each table available in DB, and
-;; COLUMN-NAMES is a list of header names for the columns in
-;; ALL-TABLES.
-;;
-;; The Allegro version also accepted a HSTMT argument.
-;(defmethod database-list-tables ((db oracle-database))
-; (sql:query "select '',OWNER,TABLE_NAME,TABLE_TYPE,'' from all_catalog"))
-
+(defmethod database-list-tables ((database oracle-database) &key owner)
+ (let ((query
+ (if owner
+ (format nil
+ "select user_tables.table_name from user_tables,all_tables where user_tables.table_name=all_tables.table_name and all_tables.owner='~:@(~A~)'"
+ owner)
+ "select table_name from user_tables")))
+ (mapcar #'car (database-query query database nil nil))))
-(defmethod list-all-user-database-tables ((db oracle-database))
- (unless db
- (setf db clsql:*default-database*))
- (values (database-query "select TABLE_NAME from all_catalog
- where owner <> 'PUBLIC' and owner <> 'SYSTEM' and owner <> 'SYS'"
- db nil nil)))
+(defmethod database-list-views ((database oracle-database) &key owner)
+ (let ((query
+ (if owner
+ (format nil
+ "select user_views.view_name from user_views,all_views where user_views.view_name=all_views.view_name and all_views.owner='~:@(~A~)'"
+ owner)
+ "select view_name from user_views")))
+ (mapcar #'car
+ (database-query query database nil nil))))
+
+(defmethod database-list-indexes ((database oracle-database)
+ &key (owner nil))
+ (let ((query
+ (if owner
+ (format nil
+ "select user_indexes.index_name from user_indexes,all_indexes where user_indexes.index_name=all_indexes.index_name and all_indexes.owner='~:@(~A~)'"
+ owner)
+ "select index_name from user_indexes")))
+ (mapcar #'car (database-query query database nil nil))))
+
+(defmethod database-list-table-indexes (table (database oracle-database)
+ &key (owner nil))
+ (let ((query
+ (if owner
+ (format nil
+ "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~)'"
+ table owner)
+ (format nil "select index_name from user_indexes where table_name='~A'"
+ table))))
+ (mapcar #'car (database-query query database nil nil))))
-(defmethod database-list-tables ((database oracle-database)
- &key (system-tables nil) owner)
- (if system-tables
- (database-query "select table_name from all_catalog" database nil nil)
- (database-query "select table_name from all_catalog where owner <> 'PUBLIC' and owner <> 'SYSTEM' and owner <> 'SYS'"
- database nil nil)))
-
-;; Return a list of all columns in TABLE.
-;;
-;; The Allegro version of this also returned a second value.
-
-(defmethod list-all-table-columns (table (db oracle-database))
- (declare (type string table))
- (unless db
- (setf db clsql:*default-database*))
- (let* ((sql-stmt (concatenate
- 'simple-string
- "select "
- "'',"
- "all_tables.OWNER,"
- "'',"
- "user_tab_columns.COLUMN_NAME,"
- "user_tab_columns.DATA_TYPE from user_tab_columns,"
- "all_tables where all_tables.table_name = '" table "'"
- " and user_tab_columns.table_name = '" table "'"))
- (preresult (sql sql-stmt :db db :types :auto)))
- ;; PRERESULT is like RESULT except that it has a name instead of
- ;; type codes in the fifth column of each row. To fix this, we
- ;; destructively modify PRERESULT.
- (dolist (preresult-row preresult)
- (setf (fifth preresult-row)
- (if (find (fifth preresult-row)
- #("NUMBER" "DATE")
- :test #'string=)
- 2 ; numeric
- 1))) ; string
- preresult))
(defmethod database-list-attributes (table (database oracle-database) &key owner)
- (let* ((relname (etypecase table
- (clsql-sys::sql-ident
- (string-upcase
- (symbol-name (slot-value table 'clsql-sys::name))))
- (string table))))
- (mapcar #'car
- (database-query
+ (let ((query
+ (if owner
+ (format nil
+ "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~)'"
+ table owner)
+ (format nil
+ "select column_name from user_tab_columns where table_name='~A'"
+ table))))
+ (mapcar #'car (database-query query database nil nil))))
+
+(defmethod database-attribute-type (attribute (table string)
+ (database oracle-database)
+ &key (owner nil))
+ (let ((query
+ (if owner
(format nil
- "select user_tab_columns,column_name from user_tab_columns where user_tab_columns.table_name=~A"
- relname)
- database nil nil))))
-
-
-
+ "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~)'"
+ table attribute owner)
+ (format nil
+ "select data_type,data_length,data_scale,nullable from user_tab_columns where table_name='~A' and column_name='~A'"
+ table attribute))))
+ (destructuring-bind (type length scale nullable) (car (database-query query database :auto nil))
+ (values (ensure-keyword type) length scale
+ (if (char-equal #\Y (schar nullable 0)) 1 0)))))
+
;; Return one row of the table referred to by QC, represented as a
;; list; or if there are no more rows, signal an error if EOF-ERRORP,
;; or return EOF-VALUE otherwise.
;; STREAM which has no more data, and QC is not a STREAM, we signal
;; DBI-ERROR instead.
-(uffi:def-type short-pointer '(* :short))
+(uffi:def-type short-array '(:array :short))
+(uffi:def-type int-pointer '(* :int))
(uffi:def-type double-pointer '(* :double))
;;; the result of a database query: a cursor through a table
(defstruct (oracle-result-set (:print-function print-query-cursor)
(:conc-name qc-)
(:constructor %make-query-cursor))
- (db (error "missing DB") ; db conn. this table is associated with
- :type db
+ (db (error "missing DB") ; db conn. this table is associated with
+ :type oracle-database
:read-only t)
(stmthp (error "missing STMTHP") ; the statement handle used to create
;; :type alien ; this table. owned by the QUERY-CURSOR
;;(declare (optimize (speed 3)))
(cond ((zerop (qc-n-from-oci qc))
(if eof-errorp
- (error 'clsql-error :message
+ (error 'sql-database-error :message
(format nil "no more rows available in ~S" qc))
eof-value))
((>= (qc-n-to-dbi qc)
(let* ((cd (aref cds icd))
(b (foreign-resource-buffer (cd-buffer cd)))
(value
- (let ((arb (foreign-resource-buffer (cd-indicators cd))))
- (declare (type short-pointer arb))
- (unless (= (uffi:deref-array arb '(:array :int) irow) -1)
+ (let* ((arb (foreign-resource-buffer (cd-indicators cd)))
+ (indicator (uffi:deref-array arb '(:array :short) irow)))
+ ;;(declare (type short-array arb))
+ (unless (= indicator -1)
(ecase (cd-oci-data-type cd)
- (#.SQLT-STR (deref-oci-string b irow (cd-sizeof cd)))
- (#.SQLT-FLT (uffi:deref-array b '(:array :double) irow))
- (#.SQLT-INT (uffi:deref-array b '(:array :int) irow))
- (#.SQLT-DATE (deref-oci-string b irow (cd-sizeof cd))))))))
+ (#.SQLT-STR
+ (deref-oci-string b irow (cd-sizeof cd)))
+ (#.SQLT-FLT
+ (uffi:deref-array b '(:array :double) irow))
+ (#.SQLT-INT
+ (uffi:deref-array b '(:array :int) irow))
+ (#.SQLT-DATE
+ (deref-oci-string b irow (cd-sizeof cd))))))))
+ (when (and (eq :string (cd-result-type cd))
+ value
+ (not (stringp value)))
+ (setq value (write-to-string value)))
(push value reversed-result)))
(incf (qc-n-to-dbi qc))
(nreverse reversed-result)))))
(defun refill-qc-buffers (qc)
- (with-slots (errhp)
- (qc-db qc)
+ (with-slots (errhp) (qc-db qc)
(setf (qc-n-to-dbi qc) 0)
(cond ((qc-oci-end-seen-p qc)
(setf (qc-n-from-oci qc) 0))
(t
- (let ((oci-code (%oci-stmt-fetch (uffi:deref-pointer (qc-stmthp qc) void-pointer)
- (uffi:deref-pointer errhp void-pointer)
- +n-buf-rows+
- +oci-fetch-next+ +oci-default+)))
+ (let ((oci-code (%oci-stmt-fetch
+ (deref-vp (qc-stmthp qc))
+ (deref-vp errhp)
+ +n-buf-rows+
+ +oci-fetch-next+ +oci-default+)))
(ecase oci-code
(#.+oci-success+ (values))
(#.+oci-no-data+ (setf (qc-oci-end-seen-p qc) t)
(#.+oci-error+ (handle-oci-error :database (qc-db qc)
:nulls-ok t))))
(uffi:with-foreign-object (rowcount :long)
- (oci-attr-get (uffi:deref-pointer (qc-stmthp qc) void-pointer) +oci-htype-stmt+
+ (oci-attr-get (deref-vp (qc-stmthp qc))
+ +oci-htype-stmt+
rowcount
- (uffi:make-null-pointer :unsigned-long)
+ +unsigned-int-null-pointer+
+oci-attr-row-count+
- (uffi:deref-pointer errhp void-pointer))
+ (deref-vp errhp))
(setf (qc-n-from-oci qc)
- (- (uffi:deref-pointer rowcount :long) (qc-total-n-from-oci qc)))
+ (- (uffi:deref-pointer rowcount :long)
+ (qc-total-n-from-oci qc)))
(when (< (qc-n-from-oci qc) +n-buf-rows+)
(setf (qc-oci-end-seen-p qc) t))
(setf (qc-total-n-from-oci qc)
;; QUERY-CURSOR, and the new QUERY-CURSOR becomes responsible for
;; freeing the STMTHP when it is no longer needed.
-(defun sql-stmt-exec (sql-stmt-string db &key types)
+(defun sql-stmt-exec (sql-stmt-string db result-types field-names)
(with-slots (envhp svchp errhp)
db
- (let ((stmthp (uffi:allocate-foreign-object void-pointer)))
+ (let ((stmthp (uffi:allocate-foreign-object :pointer-void)))
(uffi:with-foreign-object (stmttype :unsigned-short)
- (oci-handle-alloc (uffi:deref-pointer envhp void-pointer)
+ (oci-handle-alloc (deref-vp envhp)
stmthp
+oci-htype-stmt+ 0 +null-void-pointer-pointer+)
- (oci-stmt-prepare (uffi:deref-pointer stmthp void-pointer)
- (uffi:deref-pointer errhp void-pointer)
+ (oci-stmt-prepare (deref-vp stmthp)
+ (deref-vp errhp)
(uffi:convert-to-cstring sql-stmt-string)
(length sql-stmt-string)
+oci-ntv-syntax+ +oci-default+ :database db)
- (oci-attr-get (uffi:deref-pointer stmthp void-pointer)
+ (oci-attr-get (deref-vp stmthp)
+oci-htype-stmt+
stmttype
- (uffi:make-null-pointer :unsigned-int)
+ +unsigned-int-null-pointer+
+oci-attr-stmt-type+
- (uffi:deref-pointer errhp void-pointer)
+ (deref-vp errhp)
:database db)
(let* ((select-p (= (uffi:deref-pointer stmttype :unsigned-short) 1))
(iters (if select-p 0 1)))
- (oci-stmt-execute (uffi:deref-pointer svchp void-pointer)
- (uffi:deref-pointer stmthp void-pointer)
- (uffi:deref-pointer errhp void-pointer)
+ (oci-stmt-execute (deref-vp svchp)
+ (deref-vp stmthp)
+ (deref-vp errhp)
iters 0 +null-void-pointer+ +null-void-pointer+ +oci-default+
:database db)
(cond (select-p
- (make-query-cursor db stmthp types))
+ (make-query-cursor db stmthp result-types field-names))
(t
- (oci-handle-free (uffi:deref-pointer stmthp void-pointer) +oci-htype-stmt+)
+ (oci-handle-free (deref-vp stmthp) +oci-htype-stmt+)
nil)))))))
;; name from the external SQL function, controlling type conversion
;; of the returned arguments.
-(defun make-query-cursor (db stmthp types)
+(defun make-query-cursor (db stmthp result-types field-names)
(let ((qc (%make-query-cursor :db db
:stmthp stmthp
- :cds (make-query-cursor-cds db stmthp types))))
+ :cds (make-query-cursor-cds db stmthp
+ result-types
+ field-names))))
(refill-qc-buffers qc)
qc))
;; debugging only
-(defun make-query-cursor-cds (database stmthp types)
+(uffi:def-type byte-pointer (* :byte))
+(uffi:def-type ulong-pointer (* :unsigned-long))
+(uffi:def-type void-pointer-pointer (* :void-pointer))
+
+(defun make-query-cursor-cds (database stmthp result-types field-names)
(declare (optimize (safety 3) #+nil (speed 3))
(type oracle-database database)
(type pointer-pointer-void stmthp))
- (with-slots (errhp)
- database
- (unless (eq types :auto)
- (error "unsupported TYPES value"))
- (uffi:with-foreign-objects ((dtype :unsigned-short)
- (parmdp (* :void))
- (precision :byte)
- (scale :byte)
- (colname (* :unsigned-char))
- (colnamelen :unsigned-long)
- (colsize :unsigned-long)
- (colsizesize :unsigned-long)
- (defnp (* :void)))
+ (with-slots (errhp) database
+ (uffi:with-foreign-objects ((dtype-foreign :unsigned-short)
+ (parmdp :pointer-void)
+ (precision :byte)
+ (scale :byte)
+ (colname '(* :unsigned-char))
+ (colnamelen :unsigned-long)
+ (colsize :unsigned-long)
+ (colsizesize :unsigned-long)
+ (defnp ':pointer-void))
(let ((buffer nil)
(sizeof nil))
(do ((icolumn 0 (1+ icolumn))
(cds-as-reversed-list nil))
- ((not (eql (oci-param-get (uffi:deref-pointer stmthp void-pointer)
+ ((not (eql (oci-param-get (deref-vp stmthp)
+oci-htype-stmt+
- (uffi:deref-pointer errhp void-pointer)
+ (deref-vp errhp)
parmdp
(1+ icolumn) :database database)
+oci-success+))
(coerce (reverse cds-as-reversed-list) 'simple-vector))
;; Decode type of ICOLUMNth column into a type we're prepared to
;; handle in Lisp.
- (oci-attr-get (uffi:deref-pointer parmdp void-pointer)
+ (oci-attr-get (deref-vp parmdp)
+oci-dtype-param+
- dtype
- (uffi:make-null-pointer :int) +oci-attr-data-type+
- (uffi:deref-pointer errhp void-pointer))
- (case dtype
- (#.SQLT-DATE
- (setf buffer (acquire-foreign-resource :char (* 32 +n-buf-rows+)))
- (setf sizeof 32 dtype #.SQLT-STR))
- (2 ;; number
- ;;(oci-attr-get parmdp +oci-dtype-param+
- ;;(addr precision) nil +oci-attr-precision+
- ;;(uffi:deref-pointer errhp))
- (oci-attr-get (uffi:deref-pointer parmdp void-pointer)
- +oci-dtype-param+
- scale
- (uffi:make-null-pointer :int) +oci-attr-scale+
- (uffi:deref-pointer errhp void-pointer))
- (cond
- ((zerop scale)
- (setf buffer (acquire-foreign-resource :init +n-buf-rows+)
- sizeof 4 ;; sizeof(int)
- dtype #.SQLT-INT))
+ dtype-foreign
+ +unsigned-int-null-pointer+
+ +oci-attr-data-type+
+ (deref-vp errhp))
+ (let ((dtype (uffi:deref-pointer dtype-foreign :unsigned-short)))
+ (declare (fixnum dtype))
+ (case dtype
+ (#.SQLT-DATE
+ (setf buffer (acquire-foreign-resource :unsigned-char
+ (* 32 +n-buf-rows+)))
+ (setf sizeof 32 dtype #.SQLT-STR))
+ (#.SQLT-NUMBER
+ (oci-attr-get (deref-vp parmdp)
+ +oci-dtype-param+
+ precision
+ +unsigned-int-null-pointer+
+ +oci-attr-precision+
+ (deref-vp errhp))
+ (oci-attr-get (deref-vp parmdp)
+ +oci-dtype-param+
+ scale
+ +unsigned-int-null-pointer+
+ +oci-attr-scale+
+ (deref-vp errhp))
+ (let ((*scale (uffi:deref-pointer scale :byte))
+ (*precision (uffi:deref-pointer precision :byte)))
+
+ ;; (format t "scale=~d, precision=~d~%" *scale *precision)
+ (cond
+ ((or (and (zerop *scale) (not (zerop *precision)))
+ (and (minusp *scale) (< *precision 10)))
+ (setf buffer (acquire-foreign-resource :int +n-buf-rows+)
+ sizeof 4 ;; sizeof(int)
+ dtype #.SQLT-INT))
+ (t
+ (setf buffer (acquire-foreign-resource :double +n-buf-rows+)
+ sizeof 8 ;; sizeof(double)
+ dtype #.SQLT-FLT)))))
+ ;; Default to SQL-STR
(t
- (setf buffer (acquire-foreign-resource :double +n-buf-rows+)
- sizeof 8 ;; sizeof(double)
- dtype #.SQLT-FLT))))
- (t ; Default to SQL-STR
- (setf (uffi:deref-pointer colsize :unsigned-long) 0
- dtype #.SQLT-STR)
- (oci-attr-get (uffi:deref-pointer parmdp void-pointer)
- +oci-dtype-param+
- colsize
- (uffi:make-null-pointer :int) ;; (uffi:pointer-address colsizesize)
- +oci-attr-data-size+
- (uffi:deref-pointer errhp void-pointer))
- (let ((colsize-including-null (1+ (uffi:deref-pointer colsize :unsigned-long))))
- (setf buffer (acquire-foreign-resource
- :char (* +n-buf-rows+ colsize-including-null)))
- (setf sizeof colsize-including-null))))
- (let ((retcodes (acquire-foreign-resource :short +n-buf-rows+))
- (indicators (acquire-foreign-resource :short +n-buf-rows+)))
- (push (make-cd :name "col" ;(subseq colname 0 colnamelen)
- :sizeof sizeof
- :buffer buffer
- :oci-data-type dtype
- :retcodes retcodes
- :indicators indicators)
- cds-as-reversed-list)
- (oci-define-by-pos (uffi:deref-pointer stmthp void-pointer)
- defnp
- (uffi:deref-pointer errhp void-pointer)
- (1+ icolumn) ; OCI 1-based indexing again
- (foreign-resource-buffer buffer)
- sizeof
- dtype
- (foreign-resource-buffer indicators)
- (uffi:make-null-pointer :unsigned-short)
- (foreign-resource-buffer retcodes)
- +oci-default+)))))))
-
+ (setf (uffi:deref-pointer colsize :unsigned-long) 0)
+ (setf dtype #.SQLT-STR)
+ (oci-attr-get (deref-vp parmdp)
+ +oci-dtype-param+
+ colsize
+ +unsigned-int-null-pointer+
+ +oci-attr-data-size+
+ (deref-vp errhp))
+ (let ((colsize-including-null (1+ (uffi:deref-pointer colsize :unsigned-long))))
+ (setf buffer (acquire-foreign-resource
+ :unsigned-char (* +n-buf-rows+ colsize-including-null)))
+ (setf sizeof colsize-including-null))))
+ (let ((retcodes (acquire-foreign-resource :unsigned-short +n-buf-rows+))
+ (indicators (acquire-foreign-resource :short +n-buf-rows+))
+ (colname-string ""))
+ (when field-names
+ (oci-attr-get (deref-vp parmdp)
+ +oci-dtype-param+
+ colname
+ colnamelen
+ +oci-attr-name+
+ (deref-vp errhp))
+ (setq colname-string (uffi:convert-from-foreign-string
+ (uffi:deref-pointer colname '(* :unsigned-char))
+ :length (uffi:deref-pointer colnamelen :unsigned-long))))
+ (push (make-cd :name colname-string
+ :sizeof sizeof
+ :buffer buffer
+ :oci-data-type dtype
+ :retcodes retcodes
+ :indicators indicators
+ :result-type (cond
+ ((consp result-types)
+ (nth icolumn result-types))
+ ((null result-types)
+ :string)
+ (t
+ result-types)))
+ cds-as-reversed-list)
+ (oci-define-by-pos (deref-vp stmthp)
+ defnp
+ (deref-vp errhp)
+ (1+ icolumn) ; OCI 1-based indexing again
+ (foreign-resource-buffer buffer)
+ sizeof
+ dtype
+ (foreign-resource-buffer indicators)
+ +unsigned-short-null-pointer+
+ (foreign-resource-buffer retcodes)
+ +oci-default+))))))))
+
;; Release the resources associated with a QUERY-CURSOR.
(defun close-query (qc)
- (oci-handle-free (uffi:deref-pointer (qc-stmthp qc) void-pointer) +oci-htype-stmt+)
+ (oci-handle-free (deref-vp (qc-stmthp qc)) +oci-htype-stmt+)
(let ((cds (qc-cds qc)))
(dotimes (i (length cds))
(release-cd-resources (aref cds i))))
(check-connection-spec connection-spec database-type (dsn user password))
(destructuring-bind (data-source-name user password)
connection-spec
- (let ((envhp (uffi:allocate-foreign-object (* :void)))
- (errhp (uffi:allocate-foreign-object (* :void)))
- (svchp (uffi:allocate-foreign-object (* :void)))
- (srvhp (uffi:allocate-foreign-object (* :void))))
+ (let ((envhp (uffi:allocate-foreign-object :pointer-void))
+ (errhp (uffi:allocate-foreign-object :pointer-void))
+ (svchp (uffi:allocate-foreign-object :pointer-void))
+ (srvhp (uffi:allocate-foreign-object :pointer-void)))
;; Requests to allocate environments and handles should never
;; fail in normal operation, and they're done too early to
;; handle errors very gracefully (since they're part of the
;; error-handling mechanism themselves) so we just assert they
;; work.
- (setf (uffi:deref-pointer envhp void-pointer) +null-void-pointer+)
+ (setf (deref-vp envhp) +null-void-pointer+)
#+oci-8-1-5
(progn
- (oci-env-create envhp +oci-default+ nil nil nil nil 0 nil)
+ (oci-env-create envhp +oci-default+ +null-void-pointer+
+ +null-void-pointer+ +null-void-pointer+
+ +null-void-pointer+ 0 +null-void-pointer-pointer+)
(oci-handle-alloc envhp
- (c-& errhp void-pointer) +oci-htype-error+ 0
+ (deref-vp errhp)
+ +oci-htype-error+ 0
+null-void-pointer-pointer+))
#-oci-8-1-5
(progn
+oci-htype-env+ 0
+null-void-pointer-pointer+)) ;no testing return
(oci-env-init envhp +oci-default+ 0 +null-void-pointer-pointer+)
- (oci-handle-alloc (uffi:deref-pointer envhp void-pointer) errhp
+ (oci-handle-alloc (deref-vp envhp) errhp
+oci-htype-error+ 0 +null-void-pointer-pointer+)
- (oci-handle-alloc (uffi:deref-pointer envhp void-pointer) srvhp
+ (oci-handle-alloc (deref-vp envhp) srvhp
+oci-htype-server+ 0 +null-void-pointer-pointer+)
- (oci-server-attach (uffi:deref-pointer srvhp void-pointer)
- (uffi:deref-pointer errhp void-pointer)
- (uffi:make-null-pointer :unsigned-char)
- 0 +oci-default+)
- (oci-handle-alloc (uffi:deref-pointer envhp void-pointer) svchp
+ (uffi:with-cstring (dblink nil)
+ (oci-server-attach (deref-vp srvhp)
+ (deref-vp errhp)
+ dblink
+ 0 +oci-default+))
+ (oci-handle-alloc (deref-vp envhp) svchp
+oci-htype-svcctx+ 0 +null-void-pointer-pointer+)
- (oci-attr-set (uffi:deref-pointer svchp void-pointer)
+ (oci-attr-set (deref-vp svchp)
+oci-htype-svcctx+
- (uffi:deref-pointer srvhp void-pointer) 0 +oci-attr-server+
- (uffi:deref-pointer errhp void-pointer))
+ (deref-vp srvhp) 0 +oci-attr-server+
+ (deref-vp errhp))
;; oci-handle-alloc((dvoid *)encvhp, (dvoid **)&stmthp, OCI_HTYPE_STMT, 0, 0);
;;#+nil
)
- (let ((db (make-instance 'oracle-database
- :name (database-name-from-spec connection-spec
- database-type)
- :envhp envhp
- :errhp errhp
- :database-type :oracle
- :svchp svchp
- :dsn data-source-name
- :user user)))
- (oci-logon (uffi:deref-pointer envhp void-pointer)
- (uffi:deref-pointer errhp void-pointer)
+ ;; Actually, oci-server-version returns the client version, not the server versions
+ ;; will use "SELECT VERSION FROM V$INSTANCE" to get actual server version.
+ (let (db server-version client-version)
+ (declare (ignorable server-version))
+ (uffi:with-foreign-object (buf '(:array :unsigned-char #.+errbuf-len+))
+ (oci-server-version (deref-vp svchp)
+ (deref-vp errhp)
+ (uffi:char-array-to-pointer buf)
+ +errbuf-len+ +oci-htype-svcctx+)
+ (setf client-version (uffi:convert-from-foreign-string buf))
+ ;; This returns the client version, not the server version, so diable it
+ #+ignore
+ (oci-server-version (deref-vp srvhp)
+ (deref-vp errhp)
+ (uffi:char-array-to-pointer buf)
+ +errbuf-len+ +oci-htype-server+)
+ #+ignore
+ (setf server-version (uffi:convert-from-foreign-string buf)))
+ (setq db (make-instance 'oracle-database
+ :name (database-name-from-spec connection-spec
+ database-type)
+ :connection-spec connection-spec
+ :envhp envhp
+ :errhp errhp
+ :database-type :oracle
+ :svchp svchp
+ :dsn data-source-name
+ :user user
+ :client-version client-version
+ :server-version server-version
+ :major-client-version (major-client-version-from-string
+ client-version)
+ :major-server-version (major-client-version-from-string
+ server-version)))
+ (oci-logon (deref-vp envhp)
+ (deref-vp errhp)
svchp
(uffi:convert-to-cstring user) (length user)
(uffi:convert-to-cstring password) (length password)
;; :date-format-length (1+ (length date-format)))))
(setf (slot-value db 'clsql-sys::state) :open)
(database-execute-command
- (format nil "alter session set NLS_DATE_FORMAT='~A'" (date-format db)) db)
+ (format nil "ALTER SESSION SET NLS_DATE_FORMAT='~A'" (date-format db)) db)
+ (let ((server-version
+ (caar (database-query
+ "SELECT BANNER FROM V$VERSION WHERE BANNER LIKE '%Oracle%'" db nil nil))))
+ (setf (slot-value db 'server-version) server-version
+ (slot-value db 'major-server-version) (major-client-version-from-string
+ server-version)))
db))))
+(defun major-client-version-from-string (str)
+ (cond
+ ((search " 10g " str)
+ 10)
+ ((search "Oracle9i " str)
+ 9)
+ ((search "Oracle8" str)
+ 8)))
+
+(defun major-server-version-from-string (str)
+ (when (> (length str) 2)
+ (cond
+ ((string= "10." (subseq str 0 3))
+ 10)
+ ((string= "9." (subseq str 0 2))
+ 9)
+ ((string= "8." (subseq str 0 2))
+ 8))))
+
+
;; Close a database connection.
(defmethod database-disconnect ((database oracle-database))
- (osucc (oci-logoff (uffi:deref-pointer (svchp database) void-pointer)
- (uffi:deref-pointer (errhp database) void-pointer)))
- (osucc (oci-handle-free (uffi:deref-pointer (envhp database) void-pointer)
- +oci-htype-env+))
+ (osucc (oci-logoff (deref-vp (svchp database))
+ (deref-vp (errhp database))))
+ (osucc (oci-handle-free (deref-vp (envhp database)) +oci-htype-env+))
;; Note: It's neither required nor allowed to explicitly deallocate the
;; ERRHP handle here, since it's owned by the ENVHP deallocated above,
;; and was therefore automatically deallocated at the same time.
;;; values for this argument, but we only support :AUTO.
(defmethod database-query (query-expression (database oracle-database) result-types field-names)
- (let ((cursor (sql-stmt-exec query-expression database :types :auto)))
+ (let ((cursor (sql-stmt-exec query-expression database result-types field-names)))
;; (declare (type (or query-cursor null) cursor))
(if (null cursor) ; No table was returned.
(values)
(row (fetch-row cursor nil eof-value)))
(when (eq row eof-value)
(close-query cursor)
- (return (nreverse reversed-result)))
+ (if field-names
+ (return (values (nreverse reversed-result)
+ (loop for cd across (qc-cds cursor)
+ collect (cd-name cd))))
+ (return (nreverse reversed-result))))
(push row reversed-result))))))
-(defmethod database-create-sequence
- (sequence-name (database oracle-database))
+(defmethod database-create-sequence (sequence-name (database oracle-database))
(execute-command
- (concatenate 'string "CREATE SEQUENCE "
- (sql-escape sequence-name))
+ (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
:database database))
-(defmethod database-drop-sequence
- (sequence-name (database oracle-database))
+(defmethod database-drop-sequence (sequence-name (database oracle-database))
(execute-command
- (concatenate 'string "DROP SEQUENCE "
- (sql-escape sequence-name))
+ (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name))
:database database))
(defmethod database-sequence-next (sequence-name (database oracle-database))
(caar
- (query
+ (database-query
(concatenate 'string "SELECT "
(sql-escape sequence-name)
".NEXTVAL FROM dual"
- ) :database database)))
-
+ )
+ database :auto nil)))
+
+(defmethod database-set-sequence-position (name position (database oracle-database))
+ (without-interrupts
+ (let* ((next (database-sequence-next name database))
+ (incr (- position next)))
+ (database-execute-command
+ (format nil "ALTER SEQUENCE ~A INCREMENT BY ~D" name incr)
+ database)
+ (database-sequence-next name database)
+ (database-execute-command
+ (format nil "ALTER SEQUENCE ~A INCREMENT BY 1" name)
+ database))))
+
+(defmethod database-list-sequences ((database oracle-database) &key owner)
+ (let ((query
+ (if owner
+ (format nil
+ "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~)'"
+ owner)
+ "select sequence_name from user_sequences")))
+ (mapcar #'car (database-query query database nil nil))))
(defmethod database-execute-command (sql-expression (database oracle-database))
(database-query sql-expression database nil nil)
- ;; HACK HACK HACK
- (database-query "commit" database nil nil)
+ (when (database-autocommit database)
+ (oracle-commit database))
t)
-;;; a column descriptor: metadata about the data in a table
(defstruct (cd (:constructor make-cd)
(:print-function print-cd))
+ "a column descriptor: metadata about the data in a table"
+
;; name of this column
(name (error "missing NAME") :type simple-string :read-only t)
;; the size in bytes of a single element
;; the OCI code for the data type of a single element
(oci-data-type (error "missing OCI-DATA-TYPE")
:type fixnum
- :read-only t))
+ :read-only t)
+ (result-type (error "missing RESULT-TYPE")
+ :read-only t))
(defun print-cd (cd stream depth)
(defmethod database-query-result-set ((query-expression string)
(database oracle-database)
&key full-set result-types)
- )
+ (let ((cursor (sql-stmt-exec query-expression database result-types nil)))
+ (if full-set
+ (values cursor (length (qc-cds cursor)) nil)
+ (values cursor (length (qc-cds cursor))))))
+
(defmethod database-dump-result-set (result-set (database oracle-database))
- )
+ (close-query result-set))
(defmethod database-store-next-row (result-set (database oracle-database) list)
- )
+ (let* ((eof-value :eof)
+ (row (fetch-row result-set nil eof-value)))
+ (unless (eq eof-value row)
+ (loop for i from 0 below (length row)
+ do (setf (nth i list) (nth i row)))
+ list)))
+
+(defmethod database-start-transaction ((database oracle-database))
+ (call-next-method)
+ ;; Not needed with simple transaction
+ #+ignore
+ (with-slots (svchp errhp) database
+ (oci-trans-start (deref-vp svchp)
+ (deref-vp errhp)
+ 60
+ +oci-trans-new+))
+ t)
-(defmethod clsql-sys::database-start-transaction ((database oracle-database))
- (call-next-method))
-;;(with-slots (svchp errhp) database
-;; (osucc (oci-trans-start (uffi:deref-pointer svchp)
-;; (uffi:deref-pointer errhp)
-;; 60
-;; +oci-trans-new+)))
-;; t)
-
+(defun oracle-commit (database)
+ (with-slots (svchp errhp) database
+ (osucc (oci-trans-commit (deref-vp svchp)
+ (deref-vp errhp)
+ 0))))
-(defmethod clsql-sys::database-commit-transaction ((database oracle-database))
+(defmethod database-commit-transaction ((database oracle-database))
(call-next-method)
- (with-slots (svchp errhp) database
- (osucc (oci-trans-commit (uffi:deref-pointer svchp void-pointer)
- (uffi:deref-pointer errhp void-pointer)
- 0)))
+ (oracle-commit database)
t)
-(defmethod clsql-sys::database-abort-transaction ((database oracle-database))
+(defmethod database-abort-transaction ((database oracle-database))
(call-next-method)
- (osucc (oci-trans-rollback (uffi:deref-pointer (svchp database) void-pointer)
- (uffi:deref-pointer (errhp database) void-pointer)
- 0))
+ (osucc (oci-trans-rollback (deref-vp (svchp database))
+ (deref-vp (errhp database))
+ 0))
t)
-(defparameter *constraint-types*
- '(("NOT-NULL" . "NOT NULL")))
-
-(defmethod database-output-sql ((str string) (database oracle-database))
- (if (and (null (position #\' str))
- (null (position #\\ str)))
- (format nil "'~A'" str)
- (let* ((l (length str))
- (buf (make-string (+ l 3))))
- (setf (aref buf 0) #\')
- (do ((i 0 (incf i))
- (j 1 (incf j)))
- ((= i l) (setf (aref buf j) #\'))
- (if (= j (- (length buf) 1))
- (setf buf (adjust-array buf (+ (length buf) 1))))
- (cond ((eql (aref str i) #\')
- (setf (aref buf j) #\')
- (incf j)))
- (setf (aref buf j) (aref str i)))
- buf)))
+;; Specifications
+
+(defmethod db-type-has-bigint? ((type (eql :oracle)))
+ nil)
+
+(defmethod db-type-has-fancy-math? ((db-type (eql :oracle)))
+ t)
+(defmethod db-type-has-boolean-where? ((db-type (eql :oracle)))
+ nil)
+(when (clsql-sys:database-type-library-loaded :oracle)
+ (clsql-sys:initialize-database-type :database-type :oracle))
projects / clsql.git / blobdiff