(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+
(defvar +unsigned-int-null-pointer+
(uffi:make-null-pointer :unsigned-int))
+;; constants - from OCI?
+
(defconstant +var-not-in-list+ 1007)
(defconstant +no-data-found+ 1403)
(defconstant +null-value-returned+ 1405)
: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")))
+ "The major version number of the Oracle server, should be 8, 9, or 10")))
;;; Handle the messy case of return code=+oci-error+, querying the
;;; NULLS-OK are as in the OERR function.
(defun handle-oci-error (&key database nulls-ok)
- (cond (database
- (with-slots (errhp) database
- (uffi:with-foreign-objects ((errbuf '(:array :unsigned-char
- #.+errbuf-len+))
- (errcode :long))
- ;; 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)
- (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 'sql-database-error
- :database database
- :error-id subcode
- :message (uffi:convert-from-foreign-string errbuf)))))))
- (nulls-ok
- (error 'sql-database-error
- :database database
- :message "can't handle NULLS-OK without ERRHP"))
- (t
- (error 'sql-database-error
- :database database
- :message "OCI Error (and no ERRHP available to find subcode)"))))
+ (cond
+ (database
+ (with-slots (errhp) database
+ (uffi:with-foreign-object (errcode :long)
+ (let ((errbuf (uffi:allocate-foreign-string #.+errbuf-len+)))
+ ;; 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)
+
+ (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 'sql-database-error
+ :database database
+ :error-id subcode
+ :message (uffi:convert-from-foreign-string errbuf))))
+ (uffi:free-foreign-object errbuf)))))
+ (nulls-ok
+ (error 'sql-database-error
+ :database database
+ :message "can't handle NULLS-OK without ERRHP"))
+ (t
+ (error 'sql-database-error
+ :database database
+ :message "OCI Error (and no ERRHP available to find subcode)"))))
;;; Require an OCI success code.
;;;
;;; Enabling this can be handy for low-level debugging.
#+nil
(progn
- (trace oci-initialize #+oci-8-1-5 oci-env-create oci-handle-alloc oci-logon
+ (trace #-oci7 oci-env-create oci-initialize oci-handle-alloc oci-logon
oci-error-get oci-stmt-prepare oci-stmt-execute
oci-param-get oci-logon oci-attr-get oci-define-by-pos oci-stmt-fetch)
(setf debug::*debug-print-length* nil))
(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")))
+ (cond ((null owner)
+ "select table_name from user_tables")
+ ((eq owner :all)
+ "select table_name from all_tables")
+ (t
+ (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)))))
(mapcar #'car (database-query query database 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")))
+ (cond ((null owner)
+ "select view_name from user_views")
+ ((eq owner :all)
+ "select view_name from all_views")
+ (t
+ (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)))))
(mapcar #'car
- (database-query query database nil nil))))
+ (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")))
+ (cond ((null owner)
+ "select index_name from user_indexes")
+ ((eq owner :all)
+ "select index_name from all_indexes")
+ (t (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)))))
(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))))
+ (cond ((null owner)
+ (format nil "select index_name from user_indexes where table_name='~A'"
+ table))
+ ((eq owner :all)
+ (format nil "select index_name from all_indexes where table_name='~A'"
+ table))
+ (t
+ (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)))))
(mapcar #'car (database-query query database nil nil))))
(defmethod database-list-attributes (table (database oracle-database) &key owner)
(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))))
+ (cond ((null owner)
+ (format nil "select column_name from user_tab_columns where table_name='~A'"
+ table))
+ ((eq owner :all)
+ (format nil "select column_name from all_tab_columns where table_name='~A'"
+ table))
+ (t
+ (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)))))
(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 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))))
+ (cond ((null 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))
+ ((eq owner :all)
+ (format nil
+ "select data_type,data_length,data_scale,nullable from all_tab_columns where table_name='~A' and column_name='~A'"
+ table attribute))
+ (t
+ (format 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)))))
(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)))))
;; 21 bytes. See pp. 3-10, 3-26, and 6-13 of OCI documentation
;; for more details.
+;; Mac OS X Note: According to table 6-8 in the Oracle 9i OCI
+;; documentation, PRECISION may actually be an sb2 instead of a
+;; single byte if performing an "implicit describe". Using a
+;; signed short instead of an unsigned byte fixes a Mac OS X bug
+;; where PRECISION is always zero. -- JJB 20040713
+
;; When calling OCI C code to handle the conversion, we have
;; only two numeric types available to pass the return value:
;; double-float and signed-long. It would be possible to
;; below, beware!) try setting this value into COLSIZE, calling OCI,
;; then looking at the value in COLSIZE. (setf colsize #x12345678)
;; debugging only
-
+
+;; Mac OS X Note: This workaround fails on a bigendian platform so
+;; I've changed the data type of COLNAME to :unsigned-short as per
+;; the Oracle 9i OCI documentation. -- JJB 20040713
(uffi:def-type byte-pointer (* :byte))
(uffi:def-type ulong-pointer (* :unsigned-long))
(with-slots (errhp) database
(uffi:with-foreign-objects ((dtype-foreign :unsigned-short)
(parmdp :pointer-void)
- (precision :byte)
+ (precision :short)
(scale :byte)
(colname '(* :unsigned-char))
(colnamelen :unsigned-long)
- (colsize :unsigned-long)
+ (colsize :unsigned-short)
(colsizesize :unsigned-long)
(defnp ':pointer-void))
(let ((buffer nil)
+oci-attr-scale+
(deref-vp errhp))
(let ((*scale (uffi:deref-pointer scale :byte))
- (*precision (uffi:deref-pointer precision :byte)))
+ (*precision (uffi:deref-pointer precision :short)))
;;(format t "scale=~d, precision=~d~%" *scale *precision)
(cond
dtype #.SQLT-FLT)))))
;; Default to SQL-STR
(t
- (setf (uffi:deref-pointer colsize :unsigned-long) 0)
+ (setf (uffi:deref-pointer colsize :unsigned-short) 0)
(setf dtype #.SQLT-STR)
(oci-attr-get (deref-vp parmdp)
+oci-dtype-param+
+unsigned-int-null-pointer+
+oci-attr-data-size+
(deref-vp errhp))
- (let ((colsize-including-null (1+ (uffi:deref-pointer colsize :unsigned-long))))
+ (let ((colsize-including-null (1+ (uffi:deref-pointer colsize :unsigned-short))))
(setf buffer (acquire-foreign-resource
:unsigned-char (* +n-buf-rows+ colsize-including-null)))
(setf sizeof colsize-including-null))))
;; handle errors very gracefully (since they're part of the
;; error-handling mechanism themselves) so we just assert they
;; work.
+
(setf (deref-vp envhp) +null-void-pointer+)
- #+oci-8-1-5
- (progn
- (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
- (deref-vp errhp)
- +oci-htype-error+ 0
- +null-void-pointer-pointer+))
- #-oci-8-1-5
+
+ #-oci7
+ (oci-env-create envhp +oci-default+ +null-void-pointer+
+ +null-void-pointer+ +null-void-pointer+
+ +null-void-pointer+ 0 +null-void-pointer-pointer+)
+ #+oci7
(progn
(oci-initialize +oci-object+ +null-void-pointer+ +null-void-pointer+
+null-void-pointer+ +null-void-pointer-pointer+)
(ignore-errors (oci-handle-alloc +null-void-pointer+ envhp
+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 (deref-vp envhp) errhp
- +oci-htype-error+ 0 +null-void-pointer-pointer+)
- (oci-handle-alloc (deref-vp envhp) srvhp
- +oci-htype-server+ 0 +null-void-pointer-pointer+)
- (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 (deref-vp svchp)
- +oci-htype-svcctx+
- (deref-vp srvhp) 0 +oci-attr-server+
- (deref-vp errhp))
- ;; oci-handle-alloc((dvoid *)encvhp, (dvoid **)&stmthp, OCI_HTYPE_STMT, 0, 0);
- ;;#+nil
- )
- ;; 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-env-init envhp +oci-default+ 0 +null-void-pointer-pointer+))
+ (oci-handle-alloc (deref-vp envhp) errhp
+ +oci-htype-error+ 0 +null-void-pointer-pointer+)
+ (oci-handle-alloc (deref-vp envhp) srvhp
+ +oci-htype-server+ 0 +null-void-pointer-pointer+)
+
+ #+ignore ;; not used since CLSQL uses the OCILogon function instead
+ (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 (deref-vp svchp)
+ +oci-htype-svcctx+
+ (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)
+ :connection-spec connection-spec
+ :envhp envhp
+ :errhp errhp
+ :database-type :oracle
+ :svchp svchp
+ :dsn data-source-name
+ :user user)))
(oci-logon (deref-vp envhp)
(deref-vp errhp)
svchp
(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")))
+ (cond ((null owner)
+ "select sequence_name from user_sequences")
+ ((eq owner :all)
+ "select sequence_name from all_sequences")
+ (t
+ (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)))))
(mapcar #'car (database-query query database nil nil))))
(defmethod database-execute-command (sql-expression (database oracle-database))
projects / clsql.git / blobdiff