(in-package #:clsql-oracle)
-(defvar *oracle-server-version* nil
- "Version string of Oracle server.")
-
(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")
;;; 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 string
+ :initarg :server-version
+ :reader server-version
+ :documentation
+ "Version string of Oracle server.")
+ (major-version-number
+ :type (or null fixnum)
+ :initarg :major-version-number
+ :reader major-version-number
+ :documentation
+ "The major version number of Oracle, should be 8, 9, or 10")))
;;; Handle the messy case of return code=+oci-error+, querying the
(cond (database
(with-slots (errhp)
database
- (uffi:with-foreign-objects ((errbuf (:array :unsigned-char #.+errbuf-len+))
+ (uffi:with-foreign-objects ((errbuf :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+)
(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)"))))
(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))))
+ (uffi:make-pointer
+ (+ (uffi:pointer-address arrayptr) (* string-index size))
+ :unsigned-char)))
(trimmed (string-trim " " raw)))
(if (equal trimmed "NULL") nil trimmed)))
#+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))
; (sql:query "select '',OWNER,TABLE_NAME,TABLE_TYPE,'' from all_catalog"))
-(defmethod database-list-tables ((db oracle-database) &key owner)
+(defmethod database-list-tables ((database oracle-database) &key owner)
+ (mapcar #'car
+ (database-query "select table_name from user_tables"
+ database nil nil))
+ #+nil
(values (database-query "select TABLE_NAME from all_catalog
where owner not in ('PUBLIC','SYSTEM','SYS','WMSYS','EXFSYS','CTXSYS','WKSYS','WK_TEST','MDSYS','DMSYS','OLAPSYS','ORDSYS','XDB')"
db nil nil)))
(defmethod database-list-views ((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)))
+ &key owner)
+ ;; (database-query "select table_name from all_catalog" database nil nil)
+ (mapcar #'car
+ (database-query "select view_name from user_views" database nil nil)))
-;; Return a list of all columns in TABLE.
-;;
-;; The Allegro version of this also returned a second value.
+
+(defmethod database-list-indexes ((database oracle-database)
+ &key (owner nil))
+ (mapcar #'car
+ (database-query "select index_name from user_indexes" database nil nil)))
(defmethod list-all-table-columns (table (db oracle-database))
- (declare (type string table))
- (unless db
- (setf db clsql:*default-database*))
+ (declare (string table))
(let* ((sql-stmt (concatenate
'simple-string
"select "
"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 (database-query sql-stmt db :auto nil)))
;; 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.
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
- (format nil
- "select user_tab_columns,column_name from user_tab_columns where user_tab_columns.table_name='~A'"
- relname)
- database nil nil))))
+(defmethod database-list-attributes (table (database oracle-database) &key owner)
+ (mapcar #'car
+ (database-query
+ (format nil
+ "select user_tab_columns,column_name from user_tab_columns where user_tab_columns.table_name='~A'"
+ table)
+ database nil nil)))
;; Return one row of the table referred to by QC, represented as a
;; DBI-ERROR instead.
(uffi:def-type short-pointer '(* :short))
+(uffi:def-type int-pointer '(* :int))
(uffi:def-type double-pointer '(* :double))
;;; the result of a database query: a cursor through a table
(:conc-name qc-)
(:constructor %make-query-cursor))
(db (error "missing DB") ; db conn. this table is associated with
- :type db
+ :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
(b (foreign-resource-buffer (cd-buffer cd)))
(value
(let ((arb (foreign-resource-buffer (cd-indicators cd))))
- (declare (type short-pointer arb))
+ (declare (type int-pointer arb))
(unless (= (uffi:deref-array arb '(:array :int) irow) -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:with-cast-pointer (bd b :double)
+ (uffi:deref-array bd '(:array :double) irow)))
+ (#.SQLT-INT
+ (uffi:with-cast-pointer (bi b :int)
+ (uffi:deref-array bi '(:array :int) irow)))
+ (#.SQLT-DATE
+ (deref-oci-string b irow (cd-sizeof cd))))))))
(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
+ (uffi:deref-pointer (qc-stmthp qc) void-pointer)
+ (uffi:deref-pointer errhp void-pointer)
+ +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 (uffi:deref-pointer (qc-stmthp qc) void-pointer)
+ +oci-htype-stmt+
rowcount
(uffi:make-null-pointer :unsigned-long)
+oci-attr-row-count+
(uffi:deref-pointer errhp void-pointer))
(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)
(unless (eq types :auto)
(error "unsupported TYPES value"))
(uffi:with-foreign-objects ((dtype-foreign :unsigned-short)
- (parmdp (* :void))
+ (parmdp ':pointer-void)
(precision :byte)
(scale :byte)
- (colname (* :unsigned-char))
+ (colname '(* :unsigned-char))
(colnamelen :unsigned-long)
(colsize :unsigned-long)
(colsizesize :unsigned-long)
- (defnp (* :void)))
+ (defnp ':pointer-void))
(let ((buffer nil)
(sizeof nil))
(do ((icolumn 0 (1+ icolumn))
(uffi:make-null-pointer :int) +oci-attr-scale+
(uffi:deref-pointer errhp void-pointer))
(cond
- ((zerop scale)
+ ((zerop (uffi:deref-pointer scale :byte))
(setf buffer (acquire-foreign-resource :init +n-buf-rows+)
sizeof 4 ;; sizeof(int)
dtype #.SQLT-INT))
(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
(setf (uffi:deref-pointer envhp void-pointer) +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
+null-void-pointer-pointer+))
;; 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)))
+ (let (db server-version)
+ (uffi:with-foreign-object (buf '(:array :unsigned-char #.+errbuf-len+))
+ (oci-server-version (uffi:deref-pointer svchp void-pointer)
+ (uffi:deref-pointer errhp void-pointer)
+ buf +errbuf-len+ +oci-htype-svcctx+)
+ (setf server-version (uffi:convert-from-foreign-string buf)))
+ (setq 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
+ :server-version server-version
+ :major-version-number (major-version-from-string
+ server-version)))
+
(oci-logon (uffi:deref-pointer envhp void-pointer)
(uffi:deref-pointer errhp void-pointer)
svchp
(uffi:convert-to-cstring data-source-name) (length data-source-name)
:database db)
;; :date-format-length (1+ (length date-format)))))
- (uffi:with-foreign-object (buf (:array :unsigned-char 512))
- (oci-server-version (uffi:deref-pointer svchp void-pointer)
- (uffi:deref-pointer errhp void-pointer)
- buf
- 512
- +oci-htype-svcctx+)
- (setf *oracle-server-version* (uffi:convert-from-foreign-string buf)))
-
(setf (slot-value db 'clsql-sys::state) :open)
(database-execute-command
(format nil "alter session set NLS_DATE_FORMAT='~A'" (date-format db)) db)
db))))
+(defun major-version-from-string (str)
+ (cond
+ ((search " 10g " str)
+ 10)
+ ((search " 9g " str)
+ 10)))
+
+
;; Close a database connection.
(defmethod database-disconnect ((database oracle-database))
".NEXTVAL FROM dual"
) :database database)))
+(defmethod database-list-sequences ((database oracle-database) &key owner)
+ (mapcar #'car (database-query "select sequence_name from user_sequences"
+ database nil nil)))
(defmethod database-execute-command (sql-expression (database oracle-database))
(database-query sql-expression database nil nil)
(defmethod db-type-has-bigint? ((type (eql :oracle)))
nil)
+
+(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql)))
+ t)
projects / clsql.git / blobdiff