From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Mon, 3 May 2004 18:03:39 +0000 (+0000)
Subject: r9211: add *backend-warning-behavior
X-Git-Tag: v3.8.6~544
X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=1dda729b250779079efbdc1d3f6bbb3ae4a20ba4

r9211: add *backend-warning-behavior
---

diff --git a/ChangeLog b/ChangeLog
index 70b20ca..5881d6d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+3 May 2004 Kevin Rosenberg (kevin@rosenberg.net)
+	* Version 2.10.8
+	* base/conditions.lisp: Add *backend-warning-behavior*
+	special variable.
+	* db-postgresql-socket/postgresql-socket-sql.lisp:
+	Honor value of *backend-warning-behavior*
+	* tests/test-fdml.lisp: Remove test of raw boolean value
+	since different backends handle this differently.
+	* tests/test-oodml.lisp: Add test for boolean slot value
+	* tests/test-init.lisp: Use *backend-warning-behavior*
+	to suppress warnings from postgresql about implicitly
+	creating primary key in tables.
+	
 3 May 2004 Kevin Rosenberg (kevin@rosenberg.net)
 	* Version 2.10.7
 	* db-odbc/odbc-dbi.lisp: Convert TINYINT to integers when
diff --git a/base/classes.lisp b/base/classes.lisp
index 292bb6b..f2220f6 100644
--- a/base/classes.lisp
+++ b/base/classes.lisp
@@ -52,3 +52,4 @@ are a list of ACTION specified for table and any cached value of list-attributes
 	      "<unbound>")
 	    (database-state object))))
 
+
diff --git a/base/conditions.lisp b/base/conditions.lisp
index 25d4623..4954ece 100644
--- a/base/conditions.lisp
+++ b/base/conditions.lisp
@@ -20,6 +20,10 @@
 
 (in-package #:clsql-base)
 
+(defvar *backend-warning-behavior* :warn
+  "Action to perform on warning messages from backend. Default is to :warn. May also be
+set to :error to signal an error or :ignore/nil to silently ignore the warning.")
+
 ;;; Conditions
 (define-condition clsql-condition ()
   ())
@@ -94,15 +98,20 @@ and signal an clsql-invalid-spec-error if they don't match."
 
 (define-condition clsql-sql-error (clsql-error)
   ((database :initarg :database :reader clsql-sql-error-database)
-   (expression :initarg :expression :reader clsql-sql-error-expression)
-   (errno :initarg :errno :reader clsql-sql-error-errno)
-   (error :initarg :error :reader clsql-sql-error-error))
+   (message :initarg :message :initarg nil :reader clsql-sql-error-message)
+   (expression :initarg :expression :initarg nil :reader clsql-sql-error-expression)
+   (errno :initarg :errno :initarg nil :reader clsql-sql-error-errno)
+   (error :initarg :error :initarg nil :reader clsql-sql-error-error))
   (:report (lambda (c stream)
-	     (format stream "While accessing database ~A~%  with expression ~S:~%  Error ~D / ~A~%  has occurred."
-		     (clsql-sql-error-database c)
-		     (clsql-sql-error-expression c)
-		     (clsql-sql-error-errno c)
-		     (clsql-sql-error-error c)))))
+	     (if (clsql-sql-error-message c)
+		 (format stream "While accessing database ~A~%, Error~%  ~A~%  has occurred."
+			 (clsql-sql-error-database c)
+			 (clsql-sql-error-message c))
+	       (format stream "While accessing database ~A~%  with expression ~S:~%  Error ~D / ~A~%  has occurred."
+		       (clsql-sql-error-database c)
+		       (clsql-sql-error-expression c)
+		       (clsql-sql-error-errno c)
+		       (clsql-sql-error-error c))))))
 
 (define-condition clsql-database-warning (clsql-warning)
   ((database :initarg :database :reader clsql-database-warning-database)
@@ -198,3 +207,4 @@ and signal an clsql-invalid-spec-error if they don't match."
   (:report (lambda (c stream)
 	     (format stream "Invalid SQL syntax: ~A"
 		     (clsql-sql-syntax-error-reason c)))))
+
diff --git a/base/package.lisp b/base/package.lisp
index faefebd..241d034 100644
--- a/base/package.lisp
+++ b/base/package.lisp
@@ -119,6 +119,7 @@
      #:clsql-type-error
      #:clsql-odbc-error
      #:clsql-odbc-error-message
+     #:*backend-warning-behavior*
      
      #:*loaded-database-types*
      #:reload-database-types
diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp
index 5630f04..69496c2 100644
--- a/db-postgresql-socket/postgresql-socket-api.lisp
+++ b/db-postgresql-socket/postgresql-socket-api.lisp
@@ -600,8 +600,9 @@ connection, if it is still open."
 				   :connection connection :message message))))
 	  (#.+notice-response-message+
 	   (let ((message (read-socket-value-string socket)))
-	     (warn 'postgresql-warning
-		   :connection connection :message message)))
+	     (unless (eq :ignore clsql-base:*backend-warning-behavior*)
+	       (warn 'postgresql-warning
+		     :connection connection :message message))))
 	  (#.+notification-response-message+
 	   (let ((pid (read-socket-value-int32 socket))
 		 (message (read-socket-value-string socket)))
diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp
index 180b036..24597c0 100644
--- a/db-postgresql-socket/postgresql-socket-sql.lisp
+++ b/db-postgresql-socket/postgresql-socket-sql.lisp
@@ -104,8 +104,17 @@ doesn't depend on UFFI."
 
 
 (defun convert-to-clsql-warning (database condition)
-  (warn 'clsql-database-warning :database database
-	:message (postgresql-condition-message condition)))
+  (ecase *backend-warning-behavior*
+    (:warn
+     (warn 'clsql-database-warning :database database
+	   :message (postgresql-condition-message condition)))
+    (:error
+     (error 'clsql-sql-error :database database
+	    :message (format nil "Warning upgraded to error: ~A" 
+			     (postgresql-condition-message condition))))
+    ((:ignore nil)
+     ;; do nothing
+     )))
 
 (defun convert-to-clsql-error (database expression condition)
   (error 'clsql-sql-error :database database
@@ -127,7 +136,6 @@ doesn't depend on UFFI."
 		       (lambda (c)
 			 (convert-to-clsql-error
 			  ,database-var ,expression-var c))))
-	 ;; KMR - removed double @@
 	 ,@body))))
 
 (defmethod database-initialize-database-type ((database-type
@@ -239,23 +247,23 @@ doesn't depend on UFFI."
 	  (wait-for-query-results connection)
 	(when (eq status :cursor)
 	  (loop
-	      (multiple-value-bind (row stuff)
-		  (skip-cursor-row result)
-		(unless row
-		  (setq status :completed result stuff)
-		  (return)))))
+	    (multiple-value-bind (row stuff)
+		(skip-cursor-row result)
+	      (unless row
+		(setq status :completed result stuff)
+		(return)))))
 	(cond
-	  ((null status)
-	   t)
-	  ((eq status :completed)
-	   (unless (null (wait-for-query-results connection))
+	 ((null status)
+	  t)
+	 ((eq status :completed)
+	  (unless (null (wait-for-query-results connection))
 	     (close-postgresql-connection connection)
 	     (error 'clsql-sql-error
 		    :database database
 		    :expression expression
 		    :errno 'multiple-results
 		    :error "Received multiple results for command."))
-	   result)
+	  result)
 	  (t
 	   (close-postgresql-connection connection)
 	   (error 'clsql-sql-error
diff --git a/sql/objects.lisp b/sql/objects.lisp
index 9598ea6..cb158d2 100644
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -665,9 +665,9 @@ superclass of the newly-defined View Class."
        (string (if (string= "0" val) nil t))
        (integer (if (zerop val) nil t))))
     (:postgresql
-     (if (database-type :odbc)
+     (if (eq :odbc (database-type database))
 	 (if (string= "0" val) nil t)
-	 (equal "t" val)))
+       (equal "t" val)))
     (t
      (equal "t" val))))
 
diff --git a/sql/package.lisp b/sql/package.lisp
index b1e39f2..4db6fe7 100644
--- a/sql/package.lisp
+++ b/sql/package.lisp
@@ -132,7 +132,8 @@
        #:clsql-closed-error-database
        #:clsql-type-error
        #:clsql-sql-syntax-error
-
+       #:*backend-warning-behavior*
+       
        ;; db-interface
        #:check-connection-spec
        #:database-initialize-database-type
diff --git a/tests/test-basic.lisp b/tests/test-basic.lisp
index c551b0d..85874a4 100644
--- a/tests/test-basic.lisp
+++ b/tests/test-basic.lisp
@@ -45,7 +45,11 @@
 	    (destructuring-bind (int float bigint str) row
 	      (push (list (integerp int)
 			  (typep float 'double-float)
-			  (integerp bigint)
+			  (if (and (eq :odbc *test-database-type*)
+				   (eq :postgresql *test-database-underlying-type*))
+			      ;; ODBC/Postgresql returns bigints as strings
+			      (stringp bigint)
+			    (integerp bigint))
 			  (stringp str))
 		    results))))
       ((t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t)))
diff --git a/tests/test-fdml.lisp b/tests/test-fdml.lisp
index f7ee005..53bc3fa 100644
--- a/tests/test-fdml.lisp
+++ b/tests/test-fdml.lisp
@@ -276,23 +276,17 @@
 
 (deftest :fdml/select/13
      (multiple-value-bind (results field-names) 
-	 (clsql:select [emplid] [last-name] [married] :from [employee] 
+	 (clsql:select [emplid] [last-name] :from [employee] 
 		       :where [= [emplid] 1])
        (values results (mapcar #'string-downcase field-names)))
- ((1 "Lenin" "t"))
- ("emplid" "last_name" "married"))
+ ((1 "Lenin"))
+ ("emplid" "last_name"))
 
 (deftest :fdml/select/14
      (floatp (car (clsql:select [height] :from [employee] :where [= [emplid] 1] 
 				:flatp t)))
   t)
 
-(deftest :fdml/select/15
-    (clsql:select [married] :from [employee] 
-     :where [= [emplid] 4]
-     :field-names nil)
- (("f")))
- 
 ;(deftest :fdml/select/11
 ;    (clsql:select [emplid] :from [employee]
 ;                :where [= [emplid] [any [select [companyid] :from [company]]]]
diff --git a/tests/test-init.lisp b/tests/test-init.lisp
index c13f545..eef4f88 100644
--- a/tests/test-init.lisp
+++ b/tests/test-init.lisp
@@ -156,8 +156,12 @@
 (defun test-initialise-database ()
   (test-basic-initialize)
   
-  (clsql:create-view-from-class 'employee)
-  (clsql:create-view-from-class 'company)
+  (let ((*backend-warning-behavior*
+	 (if (member *test-database-type* '(:postgresql :postgresql-socket))
+	     :ignore
+	   :warn)))
+    (clsql:create-view-from-class 'employee)
+    (clsql:create-view-from-class 'company))
 
   (setf company1 (make-instance 'company
 		   :companyid 1
@@ -255,7 +259,7 @@
 		     :first-name "Vladamir"
 		     :last-name "Putin"
 		     :email "putin@soviet.org"))
-
+  
   ;; sleep to ensure birthdays are no longer at current time
   (sleep 2) 
 
diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp
index 6ea820a..7cac6fe 100644
--- a/tests/test-oodml.lisp
+++ b/tests/test-oodml.lisp
@@ -54,11 +54,18 @@
                          :order-by [last-name]))
   ("Vladamir Lenin" "Vladamir Putin"))
 
-;; sqlite fails this because it is typeless 
 (deftest :oodml/select/5
     (length (clsql:select 'employee :where [married] :flatp t))
   3)
 
+(deftest :oodml/select/6
+    (slot-value (caar (clsql:select 'employee :where [= 1 [emplid]])) 'married)
+  t)
+
+(deftest :oodml/select/7
+    (slot-value (caar (clsql:select 'employee :where [= 4 [emplid]])) 'married)
+  nil)
+
 ;; tests update-records-from-instance 
 (deftest :oodml/update-records/1
     (values