From: Kevin M. Rosenberg Date: Thu, 20 May 2004 08:42:57 +0000 (+0000) Subject: r9408: 19 May 2004 Kevin Rosenberg (kevin@rosenberg.net) X-Git-Tag: v3.8.6~427 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=3a3ccc7a171dc4c6c10bc7e3fea8461fca6dc51b r9408: 19 May 2004 Kevin Rosenberg (kevin@rosenberg.net) * sql/db-interface.lisp: Add more default methods * sql/objects.lisp: Add explicit table name to order-by parameters in find-all when only one table to avoid selecting a duplicate row. Fix error in FIND-ALL when using :order-by such as (([foo] :asc)) as previous logic was adding two fields (foo asc) to SELECT query. * db-oracle/*.lisp: Much improvements, now passes 90% of test suite --- diff --git a/ChangeLog b/ChangeLog index 6ba7890..f14ea77 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +19 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * sql/db-interface.lisp: Add more default methods + * sql/objects.lisp: Add explicit table name to order-by parameters + in find-all when only one table to avoid selecting a duplicate row. + Fix error in FIND-ALL when using :order-by such as (([foo] :asc)) + as previous logic was adding two fields (foo asc) to SELECT query. + * db-oracle/*.lisp: Much improvements, now passes 90% of test suite + 19 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) * sql/recording.lisp: reworked docstrings. * sql/syntax.lisp: reworked docstrings. diff --git a/db-oracle/oracle-api.lisp b/db-oracle/oracle-api.lisp index dbbc5dc..ff24e2d 100644 --- a/db-oracle/oracle-api.lisp +++ b/db-oracle/oracle-api.lisp @@ -30,7 +30,7 @@ (defvar +null-void-pointer+ (uffi:make-null-pointer :void)) -(defvar +null-void-pointer-pointer+ (uffi:make-null-pointer ':pointer-void)) +(defvar +null-void-pointer-pointer+ (uffi:make-null-pointer :pointer-void)) ;;; Check an OCI return code for erroricity and signal a reasonably ;;; informative condition if so. @@ -261,11 +261,9 @@ (hndltype :short)) -#+nil -(progn -;;; Low-level functions which don't use return checking -;;; -;;; KMR: These are currently unused by the backend + +;;; Low-level routines that don't do error checking. They are used +;;; for setting up global environment. (uffi:def-function "OCIInitialize" ((mode :unsigned-long) ; ub4 @@ -282,9 +280,6 @@ (usermempp (* :pointer-void))) :returning :int) -(def-oci-routine ("OCIHandleAlloc" oci-handle-alloc) - :int -) (uffi:def-function "OCIHandleAlloc" ((parenth :pointer-void) ; const dvoid * diff --git a/db-oracle/oracle-objects.lisp b/db-oracle/oracle-objects.lisp index d9ac4a8..581f7f9 100644 --- a/db-oracle/oracle-objects.lisp +++ b/db-oracle/oracle-objects.lisp @@ -22,8 +22,14 @@ (declare (ignore type args)) (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")")) +(defmethod database-get-type-specifier ((type (eql 'integer)) args (database oracle-database)) + (if args + (format nil "NUMBER(~A,~A)" + (or (first args) 38) (or (second args) 0)) + "INTEGER")) + (defmethod database-get-type-specifier - ((type (eql 'integer)) args (database oracle-database)) + ((type (eql 'bigint)) args (database oracle-database)) (if args (format nil "NUMBER(~A,~A)" (or (first args) 38) (or (second args) 0)) diff --git a/db-oracle/oracle-sql.lisp b/db-oracle/oracle-sql.lisp index ea990b5..0a704d2 100644 --- a/db-oracle/oracle-sql.lisp +++ b/db-oracle/oracle-sql.lisp @@ -32,17 +32,8 @@ Setting this constant to a moderate value should make it less likely that we'll have to worry about the CMUCL limit.")) -;;; utilities for mucking around with C-level stuff - -;; 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) + `(uffi:deref-pointer ,foreign-object void-pointer)) ;; constants - from OCI? @@ -52,6 +43,7 @@ likely that we'll have to worry about the CMUCL limit.")) (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) @@ -128,7 +120,8 @@ the length of that format.") (cond (database (with-slots (errhp) database - (uffi:with-foreign-objects ((errbuf :unsigned-char +errbuf-len+) + (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) @@ -209,7 +202,7 @@ the length of that format.") (+ (uffi:pointer-address arrayptr) (* string-index size)) :unsigned-char))) (trimmed (string-trim " " raw))) - (if (equal trimmed "NULL") nil trimmed))) + (if (equal trimmed "NULL") nil trimmed))) ;; the OCI library, part Z: no-longer used logic to convert from ;; Oracle's binary date representation to Common Lisp's native date @@ -243,17 +236,6 @@ the length of that format.") (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) (mapcar #'car (database-query "select table_name from user_tables" @@ -306,11 +288,23 @@ the length of that format.") (mapcar #'car (database-query (format nil - "select user_tab_columns,column_name from user_tab_columns where user_tab_columns.table_name='~A'" + "select column_name from user_tab_columns where table_name='~A'" table) database nil nil))) - +(defmethod database-attribute-type (attribute (table string) + (database oracle-database) + &key (owner nil)) + (let ((rows + (database-query + (format nil + "select data_type,data_length,data_precision,data_scale,nullable from user_tab_columns where table_name='~A' and column_name='~A'" + table attribute) + database :auto nil))) + (destructuring-bind (type length precision scale nullable) (car rows) + (values (ensure-keyword type) length precision 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. @@ -384,9 +378,10 @@ the length of that format.") (let* ((cd (aref cds icd)) (b (foreign-resource-buffer (cd-buffer cd))) (value - (let ((arb (foreign-resource-buffer (cd-indicators cd)))) - (declare (type int-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-pointer arb)) + (unless (= indicator -1) (ecase (cd-oci-data-type cd) (#.SQLT-STR (deref-oci-string b irow (cd-sizeof cd))) @@ -398,6 +393,10 @@ the length of that format.") (uffi:deref-array bi '(: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))))) @@ -409,8 +408,8 @@ the length of that format.") (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) + (deref-vp (qc-stmthp qc)) + (deref-vp errhp) +n-buf-rows+ +oci-fetch-next+ +oci-default+))) (ecase oci-code @@ -420,12 +419,12 @@ the length of that format.") (#.+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-attr-get (deref-vp (qc-stmthp qc)) +oci-htype-stmt+ rowcount (uffi:make-null-pointer :unsigned-long) +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))) @@ -450,39 +449,39 @@ the length of that format.") ;; 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))) (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) +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))))))) @@ -491,10 +490,12 @@ the length of that format.") ;; 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)) @@ -560,14 +561,11 @@ the length of that format.") ;; debugging only -(defun make-query-cursor-cds (database stmthp types) +(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")) + (with-slots (errhp) database (uffi:with-foreign-objects ((dtype-foreign :unsigned-short) (parmdp ':pointer-void) (precision :byte) @@ -581,68 +579,97 @@ the length of that format.") (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-foreign - (uffi:make-null-pointer :int) +oci-attr-data-type+ - (uffi:deref-pointer errhp void-pointer)) + (uffi:make-null-pointer :int) + +oci-attr-data-type+ + (deref-vp errhp)) (let ((dtype (uffi:deref-pointer dtype-foreign :unsigned-short))) (case dtype (#.SQLT-DATE - (setf buffer (acquire-foreign-resource :char (* 32 +n-buf-rows+))) + (setf buffer (acquire-foreign-resource :unsigned-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) + (#.SQLT-NUMBER + (oci-attr-get (deref-vp parmdp) + +oci-dtype-param+ + precision + (uffi:make-null-pointer :int) + +oci-attr-precision+ + (deref-vp errhp)) + (oci-attr-get (deref-vp parmdp) +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 + (uffi:make-null-pointer :int) + +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 (zerop *scale) + (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 (uffi:deref-pointer colsize :unsigned-long) 0 dtype #.SQLT-STR) - (oci-attr-get (uffi:deref-pointer parmdp void-pointer) + (oci-attr-get (deref-vp parmdp) +oci-dtype-param+ colsize (uffi:make-null-pointer :int) ;; (uffi:pointer-address colsizesize) +oci-attr-data-size+ - (uffi:deref-pointer errhp void-pointer)) + (deref-vp errhp)) (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) + (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) + :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 (uffi:deref-pointer stmthp void-pointer) + (oci-define-by-pos (deref-vp stmthp) defnp - (uffi:deref-pointer errhp void-pointer) + (deref-vp errhp) (1+ icolumn) ; OCI 1-based indexing again (foreign-resource-buffer buffer) sizeof @@ -655,7 +682,7 @@ the length of that format.") ;; 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)))) @@ -691,14 +718,15 @@ the length of that format.") ;; 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+ +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 @@ -708,27 +736,27 @@ the length of that format.") +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) + (oci-server-attach (deref-vp srvhp) + (deref-vp errhp) (uffi:make-null-pointer :unsigned-char) 0 +oci-default+) - (oci-handle-alloc (uffi:deref-pointer envhp void-pointer) svchp + (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 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) + (oci-server-version (deref-vp svchp) + (deref-vp errhp) buf +errbuf-len+ +oci-htype-svcctx+) (setf server-version (uffi:convert-from-foreign-string buf))) (setq db (make-instance 'oracle-database @@ -744,8 +772,8 @@ the length of that format.") :major-version-number (major-version-from-string server-version))) - (oci-logon (uffi:deref-pointer envhp void-pointer) - (uffi:deref-pointer errhp void-pointer) + (oci-logon (deref-vp envhp) + (deref-vp errhp) svchp (uffi:convert-to-cstring user) (length user) (uffi:convert-to-cstring password) (length password) @@ -769,10 +797,9 @@ the length of that format.") ;; 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. @@ -791,7 +818,7 @@ the length of that format.") ;;; 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) @@ -801,7 +828,11 @@ the length of that format.") (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)))))) @@ -838,9 +869,10 @@ the length of that format.") 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 @@ -861,7 +893,9 @@ the length of that format.") ;; 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) @@ -882,15 +916,24 @@ the length of that format.") (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) - ) - -(defmethod clsql-sys::database-start-transaction ((database oracle-database)) + (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 clsql-sys:database-start-transaction ((database oracle-database)) (call-next-method)) ;;(with-slots (svchp errhp) database @@ -901,19 +944,19 @@ the length of that format.") ;; t) -(defmethod clsql-sys::database-commit-transaction ((database oracle-database)) +(defmethod clsql-sys: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) + (osucc (oci-trans-commit (deref-vp svchp) + (deref-vp errhp) 0))) t) -(defmethod clsql-sys::database-abort-transaction ((database oracle-database)) +(defmethod clsql-sys: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* @@ -943,5 +986,11 @@ the length of that format.") (defmethod db-type-has-bigint? ((type (eql :oracle))) nil) -(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql))) +(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)) diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index 8e1798b..d6352e9 100644 --- a/db-sqlite/sqlite-sql.lisp +++ b/db-sqlite/sqlite-sql.lisp @@ -162,9 +162,10 @@ (handler-case (sqlite:sqlite-finalize (sqlite-result-set-vm result-set)) (sqlite:sqlite-error (err) - (error 'clsql-simple-error - :format-control "Error finalizing SQLite VM: ~A" - :format-arguments (list (sqlite:sqlite-error-message err)))))) + (error 'sql-database-error + :message + (format nil "Error finalizing SQLite VM: ~A" + (sqlite:sqlite-error-message err)))))) (defmethod database-store-next-row (result-set (database sqlite-database) list) (let ((n-col (sqlite-result-set-n-col result-set)) @@ -184,12 +185,12 @@ (return-from database-store-next-row nil) (setf row new-row))) (sqlite:sqlite-error (err) - (error 'clsql-simple-error - :format-control "Error in sqlite-step: ~A" - :format-arguments - (list (sqlite:sqlite-error-message err))))) + (error 'sql-database-error + :message + (format nil "Error in sqlite-step: ~A" + (sqlite:sqlite-error-message err))))) - ;; Use the row previously read by database-query-result-set. + ;; Use the row previously read by database-query-result-set. (setf (sqlite-result-set-first-row result-set) (sqlite:make-null-row))) (loop for i = 0 then (1+ i) diff --git a/sql/conditions.lisp b/sql/conditions.lisp index 6270f91..413eae6 100644 --- a/sql/conditions.lisp +++ b/sql/conditions.lisp @@ -39,7 +39,7 @@ set to :error to signal an error or :ignore/nil to silently ignore the warning." :initform nil :reader sql-error-database)) (:report (lambda (c stream) - (format stream "A database error occurred: ~A / ~A~% ~A" + (format stream "A database error occurred~A: ~A / ~A~% ~A" (if (sql-error-database c) (format nil " on database ~A" (sql-error-database c)) "") @@ -93,7 +93,7 @@ set to :error to signal an error or :ignore/nil to silently ignore the warning." (defun signal-no-database-error (database) (error 'sql-database-error - :message "Not a database: ~A." database)) + :message (format nil "Not a database: ~A." database))) ;;; CLSQL Extensions diff --git a/sql/database.lisp b/sql/database.lisp index 704029f..066d348 100644 --- a/sql/database.lisp +++ b/sql/database.lisp @@ -61,11 +61,11 @@ simply returned." (if (or (not errorp) (= count 1)) (values (car matches) count) (cerror "Return nil." - 'clsql-simple-error - :format-control "There exists ~A database called ~A." - :format-arguments - (list (if (zerop count) "no" "more than one") - database))))))) + 'sql-database-error + :message + (format nil "There exists ~A database called ~A." + (if (zerop count) "no" "more than one") + database))))))) (defun connect (connection-spec diff --git a/sql/db-interface.lisp b/sql/db-interface.lisp index 385e08b..7699841 100644 --- a/sql/db-interface.lisp +++ b/sql/db-interface.lisp @@ -174,32 +174,59 @@ if unable to destory.")) (defgeneric database-get-type-specifier (type args database) (:documentation "Return the type SQL type specifier as a string, for -the given lisp type and parameters.")) +the given lisp type and parameters.") + (:method (type args (database t)) + (declare (ignore type args)) + (signal-no-database-error database))) (defgeneric database-list-tables (database &key owner) - (:documentation "List all tables in the given database")) + (:documentation "List all tables in the given database") + (:method ((database t) &key owner) + (declare (ignore owner)) + (signal-no-database-error database))) (defgeneric database-list-views (database &key owner) - (:documentation "List all views in the DATABASE.")) + (:documentation "List all views in the DATABASE.") + (:method ((database t) &key owner) + (declare (ignore owner)) + (signal-no-database-error database))) (defgeneric database-list-indexes (database &key owner) - (:documentation "List all indexes in the DATABASE.")) + (:documentation "List all indexes in the DATABASE.") + (:method ((database t) &key owner) + (declare (ignore owner)) + (signal-no-database-error database))) (defgeneric database-list-table-indexes (table database &key owner) - (:documentation "List all indexes for a table in the DATABASE.")) + (:documentation "List all indexes for a table in the DATABASE.") + (:method (table (database t) &key owner) + (declare (ignore table owner)) + (signal-no-database-error database))) (defgeneric database-list-attributes (table database &key owner) - (:documentation "List all attributes in TABLE.")) + (:documentation "List all attributes in TABLE.") + (:method (table (database t) &key owner) + (declare (ignore table owner)) + (signal-no-database-error database))) (defgeneric database-attribute-type (attribute table database &key owner) (:documentation "Return the type of ATTRIBUTE in TABLE. Returns multiple values -of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.")) +of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.") + (:method (attribute table (database t) &key owner) + (declare (ignore attribute table owner)) + (signal-no-database-error database))) (defgeneric database-add-attribute (table attribute database) - (:documentation "Add the attribute to the table.")) + (:documentation "Add the attribute to the table.") + (:method (table attribute (database t)) + (declare (ignore table attribute)) + (signal-no-database-error database))) (defgeneric database-rename-attribute (table oldatt newname database) - (:documentation "Rename the attribute in the table to NEWNAME.")) + (:documentation "Rename the attribute in the table to NEWNAME.") + (:method (table oldatt newname (database t)) + (declare (ignore table oldatt newname)) + (signal-no-database-error database))) (defgeneric oid (object) (:documentation "Return the unique ID of a database object.")) diff --git a/sql/objects.lisp b/sql/objects.lisp index 1c30975..5e36e75 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -852,6 +852,7 @@ superclass of the newly-defined View Class." :operator 'in :sub-expressions (list (sql-expression :attribute foreign-key) keys)) + :result-types :auto :flatp t))) (dolist (object objects) (when (or force-p (not (slot-boundp object slotdef-name))) @@ -1013,13 +1014,25 @@ superclass of the newly-defined View Class." jcs)) immediate-join-classes) sel-tables) - :test #'tables-equal)))) - (dolist (ob (listify order-by)) + :test #'tables-equal))) + (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob))) + (listify order-by)))) + + + (when (and order-by-slots (= 1 (length tables))) + ;; Add explicity table name if not specified and only one selected table + (let ((table-name (sql-output (car tables) database))) + (loop for i from 0 below (length order-by-slots) + do (when (typep (nth i order-by-slots) 'sql-ident-attribute) + (unless (slot-value (nth i order-by-slots) 'qualifier) + (setf (slot-value (nth i order-by-slots) 'qualifier) table-name)))))) + + (dolist (ob order-by-slots) (when (and ob (not (member ob (mapcar #'cdr fullsels) :test #'ref-equal))) (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) + (append fullsels (mapcar #'(lambda (att) (cons nil att)) + order-by-slots))))) (dolist (ob (listify distinct)) (when (and (typep ob 'sql-ident) (not (member ob (mapcar #'cdr fullsels) @@ -1114,24 +1127,28 @@ ENABLE-SQL-READER-SYNTAX." (cond ((select-objects target-args) (let ((caching (getf qualifier-args :caching t)) + (result-types (getf qualifier-args :result-types :auto)) (refresh (getf qualifier-args :refresh nil)) (database (or (getf qualifier-args :database) *default-database*))) (remf qualifier-args :caching) (remf qualifier-args :refresh) + (remf qualifier-args :result-types) (cond ((null caching) - (apply #'find-all target-args qualifier-args)) + (apply #'find-all target-args + (append qualifier-args (list :result-types result-types)))) (t (let ((cached (records-cache-results target-args qualifier-args database))) (cond ((and cached (not refresh)) cached) ((and cached refresh) - (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached))))) + (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto))))) (setf (records-cache-results target-args qualifier-args database) results) results)) (t - (let ((results (apply #'find-all target-args qualifier-args))) + (let ((results (apply #'find-all target-args (append qualifier-args + '(:result-types :auto))))) (setf (records-cache-results target-args qualifier-args database) results) results)))))))) (t diff --git a/sql/package.lisp b/sql/package.lisp index 29c109d..438beaf 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -229,7 +229,6 @@ #:sql-error-database-message ;; CLSQL Extensions - #:sql-error-database #:sql-database-warning #:sql-warning #:sql-condition diff --git a/sql/sql.lisp b/sql/sql.lisp index 0a0d2f3..79bf6cd 100644 --- a/sql/sql.lisp +++ b/sql/sql.lisp @@ -243,10 +243,11 @@ condition is true." (if (or (null thing) (eq 'null thing)) "NULL" - (error 'clsql-simple-error - :format-control - "No type conversion to SQL for ~A is defined for DB ~A." - :format-arguments (list (type-of thing) (type-of database))))) + (error 'sql-user-error + :message + (format nil + "No type conversion to SQL for ~A is defined for DB ~A." + (type-of thing) (type-of database))))) (defmethod output-sql-hash-key ((arg vector) database) diff --git a/tests/test-fddl.lisp b/tests/test-fddl.lisp index a8cc0fd..ab3da3b 100644 --- a/tests/test-fddl.lisp +++ b/tests/test-fddl.lisp @@ -81,7 +81,7 @@ ;; Attribute types are vendor specific so need to test a range (deftest :fddl/attributes/3 - (and (member (clsql:attribute-type [emplid] [employee]) '(:int :integer :int4)) t) + (and (member (clsql:attribute-type [emplid] [employee]) '(:int :integer :int4 :number)) t) t) (deftest :fddl/attributes/4 diff --git a/tests/test-init.lisp b/tests/test-init.lisp index 35b08e2..6738c1d 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -468,7 +468,7 @@ *** CLSQL ~A begun at ~A *** ~A *** ~A on ~A -*** Database ~A backend~A. +*** Database ~:@(~A~) backend~A. ****************************************************************************** " report-type diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index 3cde0a7..1d8c694 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -110,8 +110,8 @@ (clsql:select 'employee :order-by '(([emplid] :asc)) :flatp t)) (mapcar #'(lambda (x) (slot-value x 'emplid)) - (clsql:select 'employee :order-by '(([emplid] :desc)) - :flatp t))) + (clsql:select 'employee :order-by '(([emplid] :desc)) + :flatp t))) (1 2 3 4 5 6 7 8 9 10) (10 9 8 7 6 5 4 3 2 1)) @@ -154,7 +154,7 @@ (deftest :oodm/retrieval/8 (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) - (select 'employee-address :flatp t :order-by [aaddressid] :caching nil)) + (select 'employee-address :flatp t :order-by [ea_join aaddressid] :caching nil)) (10 10 nil nil nil)) (deftest :oodm/retrieval/9