From 5c67b804b62d2970685ebd8d28c88446457be975 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 25 May 2004 00:58:07 +0000 Subject: [PATCH] r9461: 24 May 2004 Kevin Rosenberg * db-oracle/oracle-sql.lisp: Add declaration so that SBCL runs efficiently. * tests/test-init.lisp: capitalize odbc backend name in banner * CONTRIBUTORS: Add note about Marcus' excellent work --- CONTRIBUTORS | 4 +- ChangeLog | 9 +++- db-oracle/foreign-resources.lisp | 4 +- db-oracle/oracle-api.lisp | 2 +- db-oracle/oracle-sql.lisp | 84 +++++++++----------------------- tests/test-init.lisp | 2 +- 6 files changed, 37 insertions(+), 68 deletions(-) diff --git a/CONTRIBUTORS b/CONTRIBUTORS index 1a4efda..6f95d36 100644 --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -1,10 +1,10 @@ CLSQL Contributors ------------------ Kevin Rosenberg (main author CLSQL) +Marcus Pearce (initial port of USQL to CLSQL, many excellent commits) Pierre Mai (original author MaiSQL from which CLSQL was based) -Marcus Pearce (initial port of USQL to CLSQL) Aurelio Bignoli (SQLite backend) -Marc Battyani +Marc Battyani (Large object support for postgresql, initial connection pool code) USQL Contributors diff --git a/ChangeLog b/ChangeLog index 1965c5b..6099d11 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +24 May 2004 Kevin Rosenberg + * db-oracle/oracle-sql.lisp: Add declaration so that SBCL runs efficiently. + * tests/test-init.lisp: capitalize odbc backend name in banner + * CONTRIBUTORS: Add note about Marcus' excellent work + 24 May 2004: Marcus Pearce (m.t.pearce@city.ac.uk) * db-postgresql-socket/postgresql-socket-sql.lisp: replace CLSQL-SIMPLE-WARNING with SQL-WARNING. @@ -23,7 +28,7 @@ * sql/ooddl.lisp: NEW FILE: ooddl from objects.lisp (deleted). * sql/oodml.lisp: NEW FILE: oodml from objects.lisp (deleted). -23 May 2004 Kevin Rosenberg +23 May 2004 Kevin Rosenberg * Version 2.10.22 released * sql/kmr-mop.lisp, sql/objects.lisp: Since SBCL is the only implementation that has reversed class slots, change the default for ordered-class-slots so that slots @@ -35,7 +40,7 @@ in many cases expects integers. * test/test-fdml.lisp: Accomodate that Oracle returns doubles for computed columns -22 May 2004 Kevin Rosenberg +22 May 2004 Kevin Rosenberg * Version 2.10.21 released * sql/sequences.lisp: Move generic sequence functions here from db-sqlite, db-odbc, and db-aodbc. diff --git a/db-oracle/foreign-resources.lisp b/db-oracle/foreign-resources.lisp index 8756f58..919a211 100644 --- a/db-oracle/foreign-resources.lisp +++ b/db-oracle/foreign-resources.lisp @@ -39,10 +39,10 @@ (cons res (gethash type *foreign-resource-hash*))))) (defmacro acquire-foreign-resource (type &optional size) - `(let ((res (%get-resource ',type ,size))) + `(let ((res (%get-resource ,type ,size))) (unless res (setf res (make-foreign-resource - :type ',type :sizeof ,size + :type ,type :sizeof ,size :buffer (uffi:allocate-foreign-object ,type ,size))) (%insert-foreign-resource ',type res)) (claim-foreign-resource res))) diff --git a/db-oracle/oracle-api.lisp b/db-oracle/oracle-api.lisp index e63351f..4b2bc0b 100644 --- a/db-oracle/oracle-api.lisp +++ b/db-oracle/oracle-api.lisp @@ -220,7 +220,7 @@ (valuep :pointer-void) (value_sz :long) (dty :unsigned-short) - (indp :pointer-void) + (indp (* :short)) (rlenp (* :unsigned-short)) (rcodep (* :unsigned-short)) (mode :unsigned-long)) diff --git a/db-oracle/oracle-sql.lisp b/db-oracle/oracle-sql.lisp index f71b7f7..dfc3a15 100644 --- a/db-oracle/oracle-sql.lisp +++ b/db-oracle/oracle-sql.lisp @@ -31,8 +31,11 @@ Setting this constant to a moderate value should make it less likely that we'll have to worry about the CMUCL limit.")) +(uffi:def-type vp-type :pointer-void) +(uffi:def-type vpp-type (* :pointer-void)) + (defmacro deref-vp (foreign-object) - `(uffi:deref-pointer ,foreign-object :pointer-void)) + `(the vp-type (uffi:deref-pointer (the vpp-type ,foreign-object) :pointer-void))) ;; constants - from OCI? @@ -298,30 +301,6 @@ the length of that format.") table)))) (mapcar #'car (database-query query database nil nil)))) -(defmethod list-all-table-columns (table (db oracle-database)) - (declare (string table)) - (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 (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. - (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 ((query @@ -603,20 +582,24 @@ the length of that format.") ;; debugging only +(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 (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)) + (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)) @@ -637,6 +620,7 @@ the length of that format.") +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 @@ -668,11 +652,11 @@ the length of that format.") (t (setf buffer (acquire-foreign-resource :double +n-buf-rows+) sizeof 8 ;; sizeof(double) - dtype #.SQLT-FLT)))) ) + dtype #.SQLT-FLT))))) ;; Default to SQL-STR - (t - (setf (uffi:deref-pointer colsize :unsigned-long) 0 - dtype #.SQLT-STR) + (t + (setf (uffi:deref-pointer colsize :unsigned-long) 0) + (setf dtype #.SQLT-STR) (oci-attr-get (deref-vp parmdp) +oci-dtype-param+ colsize @@ -842,7 +826,9 @@ the length of that 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) - (let ((server-version (caar (database-query "SELECT BANNER FROM V$VERSION WHERE BANNER LIKE '%Oracle%'" db nil nil)))) + (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))) @@ -1049,28 +1035,6 @@ the length of that format.") 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))) diff --git a/tests/test-init.lisp b/tests/test-init.lisp index 9af59da..981046e 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -482,7 +482,7 @@ (machine-type) db-type (if (not (eq db-type *test-database-underlying-type*)) - (format nil " with underlying type ~A" + (format nil " with underlying type ~:@(~A~)" *test-database-underlying-type*) "") )) -- 2.34.1