((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)) 1 "" (c-& errcode :unsigned-char)
- (c-& errbuf :unsigned-char) +errbuf-len+ +oci-htype-error+)
+ (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
:database database
:errno subcode
- :expression (uffi:convert-from-foreign-string errbuf)))))))
+ :expression nil
+ :error (uffi:convert-from-foreign-string errbuf)))))))
(nulls-ok
(error 'clsql-sql-error
:database database
(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 (uffi:deref-array arrayptr '(:array :unsigned-char) (* 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 list-all-user-database-tables ((db oracle-database))
- (unless db
- (setf db clsql:*default-database*))
+(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 <> 'PUBLIC' and owner <> 'SYSTEM' and owner <> 'SYS'"
+ where owner not in ('PUBLIC','SYSTEM','SYS','WMSYS','EXFSYS','CTXSYS','WKSYS','WK_TEST','MDSYS','DMSYS','OLAPSYS','ORDSYS','XDB')"
db 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)))
+(defmethod database-list-views ((database oracle-database)
+ &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
(defun fetch-row (qc &optional (eof-errorp t) eof-value)
- (declare (optimize (speed 3)))
+ ;;(declare (optimize (speed 3)))
(cond ((zerop (qc-n-from-oci qc))
(if eof-errorp
(error 'clsql-error :message
(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 :int irow) -1)
+ (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+
- (c-& rowcount :long) nil +oci-attr-row-count+
+ (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)
(defun sql-stmt-exec (sql-stmt-string db &key types)
(with-slots (envhp svchp errhp)
db
- (let ((stmthp (uffi:allocate-foreign-object (* :void))))
+ (let ((stmthp (uffi:allocate-foreign-object void-pointer)))
(uffi:with-foreign-object (stmttype :unsigned-short)
- (oci-handle-alloc (uffi:deref-pointer envhp void-pointer) (c-& stmthp void-pointer) +oci-htype-stmt+ 0 nil)
- (oci-stmt-prepare (uffi:deref-pointer stmthp void-pointer) (uffi:deref-pointer errhp void-pointer)
- sql-stmt-string (length sql-stmt-string)
+ (oci-handle-alloc (uffi:deref-pointer envhp void-pointer)
+ stmthp
+ +oci-htype-stmt+ 0 +null-void-pointer-pointer+)
+ (oci-stmt-prepare (uffi:deref-pointer stmthp void-pointer)
+ (uffi:deref-pointer errhp void-pointer)
+ (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-htype-stmt+
- (c-& stmttype :unsigned-short) nil +oci-attr-stmt-type+
- (uffi:deref-pointer errhp void-pointer) :database db)
+ (oci-attr-get (uffi:deref-pointer stmthp void-pointer)
+ +oci-htype-stmt+
+ stmttype
+ (uffi:make-null-pointer :unsigned-int)
+ +oci-attr-stmt-type+
+ (uffi:deref-pointer errhp void-pointer)
+ :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)
+ (oci-stmt-execute (uffi:deref-pointer svchp void-pointer)
+ (uffi:deref-pointer stmthp void-pointer)
(uffi:deref-pointer errhp void-pointer)
- iters 0 nil nil +oci-default+ :database db)
+ iters 0 +null-void-pointer+ +null-void-pointer+ +oci-default+
+ :database db)
(cond (select-p
(make-query-cursor db stmthp types))
(t
(defun make-query-cursor-cds (database stmthp types)
- (declare (optimize (speed 3))
+ (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))
+ (uffi:with-foreign-objects ((dtype-foreign :unsigned-short)
+ (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))
(cds-as-reversed-list nil))
- ((not (eql (oci-param-get (uffi:deref-pointer stmthp void-pointer) +oci-htype-stmt+
+ ((not (eql (oci-param-get (uffi:deref-pointer stmthp void-pointer)
+ +oci-htype-stmt+
(uffi:deref-pointer errhp void-pointer)
- (uffi:pointer-address parmdp)
+ 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 parmdp +oci-dtype-param+ (uffi:pointer-address dtype)
- nil +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 parmdp +oci-dtype-param+
- (uffi:pointer-address scale) nil +oci-attr-scale+
- (uffi:deref-pointer errhp void-pointer))
- (cond
- ((zerop scale)
- (setf buffer (acquire-foreign-resource signed +n-buf-rows+)
- sizeof 4 ;; sizeof(int)
- dtype #.SQLT-INT))
- (t
- (setf buffer (acquire-foreign-resource double-float +n-buf-rows+)
- sizeof 8 ;; sizeof(double)
- dtype #.SQLT-FLT))))
- (t ; Default to SQL-STR
- (setf colsize 0
- dtype #.SQLT-STR)
- (oci-attr-get parmdp +oci-dtype-param+ (uffi:pointer-address colsize)
- (uffi:pointer-address colsizesize) +oci-attr-data-size+
- (uffi:deref-pointer errhp void-pointer))
- (let ((colsize-including-null (1+ colsize)))
- (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)
- (uffi:pointer-address defnp)
- (uffi:deref-pointer errhp void-pointer)
- (1+ icolumn) ; OCI 1-based indexing again
- (foreign-resource-buffer buffer)
- sizeof
- dtype
- (foreign-resource-buffer indicators)
- nil
- (foreign-resource-buffer retcodes)
- +oci-default+)))))))
-
+ (oci-attr-get (uffi:deref-pointer parmdp void-pointer)
+ +oci-dtype-param+
+ dtype-foreign
+ (uffi:make-null-pointer :int) +oci-attr-data-type+
+ (uffi:deref-pointer errhp void-pointer))
+ (let ((dtype (uffi:deref-pointer dtype-foreign :unsigned-short)))
+ (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 (uffi:deref-pointer scale :byte))
+ (setf buffer (acquire-foreign-resource :init +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))))
+ (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+))))))))
+
;; Release the resources associated with a QUERY-CURSOR.
(defun close-query (qc)
(values))
-(defmethod print-object ((db oracle-database) stream)
- (print-unreadable-object (db stream :type t :identity t)
- (format stream "\"/~a/~a\""
- (slot-value db 'data-source-name)
- (slot-value db 'user))))
-
-
(defmethod database-name-from-spec (connection-spec (database-type (eql :oracle)))
- (check-connection-spec connection-spec database-type (user password dsn))
- (destructuring-bind (user password dsn)
- connection-spec
+ (check-connection-spec connection-spec database-type (dsn user password))
+ (destructuring-bind (dsn user password) connection-spec
(declare (ignore password))
- (concatenate 'string "/" dsn "/" user)))
+ (concatenate 'string dsn "/" user)))
(defmethod database-connect (connection-spec (database-type (eql :oracle)))
- (check-connection-spec connection-spec database-type (user password dsn))
+ (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 (c-& envhp void-pointer) +oci-default+ nil nil nil nil 0 nil)
- (oci-handle-alloc (uffi:deref-pointer envhp void-pointer)
- (c-& errhp void-pointer) +oci-htype-error+ 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-8-1-5
(progn
- (oci-initialize +oci-object+ +null-void-pointer+ +null-void-pointer+ +null-void-pointer+ +null-void-pointer+)
- (ignore-errors (oci-handle-alloc nil envhp +oci-htype-env+ 0 +null-void-pointer+)) ;no testing return
- (oci-env-init envhp +oci-default+ 0 +null-void-pointer+)
- (oci-handle-alloc (uffi:deref-pointer envhp void-pointer) errhp +oci-htype-error+ 0 +null-void-pointer+)
- (oci-handle-alloc (uffi:deref-pointer envhp void-pointer) srvhp +oci-htype-server+ 0 +null-void-pointer+)
- ;;(osucc (oci-server-attach srvhp errhp nil 0 +oci-default+))
- (oci-handle-alloc (uffi:deref-pointer envhp void-pointer) svchp +oci-htype-svcctx+ 0 +null-void-pointer+)
+ (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 (uffi:deref-pointer envhp void-pointer) errhp
+ +oci-htype-error+ 0 +null-void-pointer-pointer+)
+ (oci-handle-alloc (uffi:deref-pointer envhp void-pointer) 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
+ +oci-htype-svcctx+ 0 +null-void-pointer-pointer+)
+ (oci-attr-set (uffi:deref-pointer svchp void-pointer)
+ +oci-htype-svcctx+
+ (uffi:deref-pointer srvhp void-pointer) 0 +oci-attr-server+
+ (uffi:deref-pointer errhp void-pointer))
;; oci-handle-alloc((dvoid *)encvhp, (dvoid **)&stmthp, OCI_HTYPE_STMT, 0, 0);
- #+nil
- (oci-attr-set svchp +oci-htype-svcctx+
- srvhp 0 +oci-attr-server+ errhp)
+ ;;#+nil
)
- #+nil
- (format t "Logging in as user '~A' to database ~A~%"
- user password data-source-name)
- (oci-logon (uffi:deref-pointer envhp void-pointer) (uffi:deref-pointer errhp void-pointer) (c-& svchp void-pointer)
- (uffi:convert-to-cstring user) (length user)
- (uffi:convert-to-cstring password) (length password)
- (uffi:convert-to-cstring data-source-name) (length data-source-name))
- (let ((db (make-instance 'oracle-database
- :name (database-name-from-spec connection-spec
- database-type)
- :envhp envhp
- :errhp errhp
- :db-type :oracle
- :svchp svchp
- :dsn data-source-name
- :user user)))
- ;; :date-format-length (1+ (length date-format)))))
- (clsql:execute-command
- (format nil "alter session set NLS_DATE_FORMAT='~A'"
- (date-format db)) :database db)
+ (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 user) (length user)
+ (uffi:convert-to-cstring password) (length password)
+ (uffi:convert-to-cstring data-source-name) (length data-source-name)
+ :database db)
+ ;; :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)
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))
(defmethod database-query (query-expression (database oracle-database) result-types field-names)
(let ((cursor (sql-stmt-exec query-expression database :types :auto)))
- (declare (type (or query-cursor null) cursor))
+ ;; (declare (type (or query-cursor null) cursor))
(if (null cursor) ; No table was returned.
(values)
(do ((reversed-result nil))
".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))
+(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)
buf)))
+;; Specifications
+
+(defmethod db-type-has-bigint? ((type (eql :oracle)))
+ nil)
+
+(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql)))
+ t)
projects / clsql.git / blobdiff