r8822: now passes some of the regression tests

diff --git a/base/package.lisp b/base/package.lisp
index f8197592260b7e987fce2cfec69601fecd311aae..ba3eeec3b0e948b179635a8687631aad48f73f5e 100644 (file)
--- a/base/package.lisp
+++ b/base/package.lisp
@@ -57,7 +57,7 @@
      
      ;; Support for pooled connections
      #:database-type
      
      ;; Support for pooled connections
      #:database-type

-
+     

      ;; Large objects (Marc B)
      #:database-create-large-object
      #:database-write-large-object
      ;; Large objects (Marc B)
      #:database-create-large-object
      #:database-write-large-object


@@ -118,7 +118,7 @@
         #:transaction
         #:transaction-level
         #:conn-pool
         #:transaction
         #:transaction-level
         #:conn-pool

-        
+

         ;; utils.lisp
         #:number-to-sql-string
         #:float-to-sql-string
         ;; utils.lisp
         #:number-to-sql-string
         #:float-to-sql-string


@@ -223,6 +223,7 @@
         #:status                            ; database   xx
         #:with-database
         #:with-default-database
         #:status                            ; database   xx
         #:with-database
         #:with-default-database

+        #:disconnect-pooled

 
         ;; basic-sql.lisp
         #:query
 
         ;; basic-sql.lisp
         #:query

diff --git a/clsql-usql-tests.asd b/clsql-usql-tests.asd
index e60abab3358ce51fb654d29d3bf9185e0743b403..07cbdbd3335d3d1203fd69ecd941b657a0eadee0 100644 (file)
--- a/clsql-usql-tests.asd
+++ b/clsql-usql-tests.asd
@@ -24,6 +24,7 @@
     :description "A regression test suite for CLSQL-USQL."
     :components 
     ((:module usql-tests
     :description "A regression test suite for CLSQL-USQL."
     :components 
     ((:module usql-tests

+             :serial t

              :components ((:file "package")
                           (:file "test-init")
                           (:file "test-connection")
              :components ((:file "package")
                           (:file "test-init")
                           (:file "test-connection")

diff --git a/clsql-usql.asd b/clsql-usql.asd
index 428fb140424fe470c3199f89316f2291c31ecd2f..e10d5563f6ff9a8d212fdb6d057e3ed348ec2327 100644 (file)
--- a/clsql-usql.asd
+++ b/clsql-usql.asd
@@ -24,16 +24,14 @@
 based on the Xanalys CommonSQL interface for Lispworks. It depends on
 the low-level database interfaces provided by CLSQL and includes both
 a functional and an object oriented interface."
 based on the Xanalys CommonSQL interface for Lispworks. It depends on
 the low-level database interfaces provided by CLSQL and includes both
 a functional and an object oriented interface."

+    :depends-on (clsql-base)

     :components
     ((:module usql
              :components
     :components
     ((:module usql
              :components

-             ((:module :patches
+             ((:module :package

                        :pathname ""
                        :pathname ""

-                       :components (#+(or cmu sbcl) (:file "pcl-patch")))
-              (:module :package
-                       :pathname ""
-                       :components ((:file "package"))
-                       :depends-on (:patches))
+                       :components ((:file "package")
+                                    (:file "kmr-mop" :depends-on ("package"))))

               (:module :core
                        :pathname ""
                        :components ((:file "classes")
               (:module :core
                        :pathname ""
                        :components ((:file "classes")


@@ -47,8 +45,7 @@ a functional and an object oriented interface."
                        :depends-on (:core))
               (:module :object
                        :pathname ""
                        :depends-on (:core))
               (:module :object
                        :pathname ""

-                       :components ((:file "metaclasses")
-                                    (:file "objects" :depends-on ("metaclasses")))
-                       :depends-on (:functional)))))
-    :depends-on (:clsql-base))
+                      :components ((:file "metaclasses")
+                                   (:file "objects" :depends-on ("metaclasses")))
+                      :depends-on (:functional))))))

      
      

diff --git a/sql/package.lisp b/sql/package.lisp
index bb76d3e51e71d6f9a69a8d8757894b9843fc127f..7d8b8b23be461bef560b5d53035cee348cc83358 100644 (file)
--- a/sql/package.lisp
+++ b/sql/package.lisp
@@ -69,10 +69,50 @@
         #:closed-database
         #:database-name-from-spec
         
         #:closed-database
         #:database-name-from-spec
         

-        ;; utils.cl
+        ;; utils.lisp

         #:number-to-sql-string
         #:float-to-sql-string
         #:sql-escape-quotes
         #:number-to-sql-string
         #:float-to-sql-string
         #:sql-escape-quotes

+
+        ;; database.lisp -- Connection
+        #:*default-database-type*                ; clsql-base xx
+        #:*default-database*             ; classes    xx
+        #:connect                                ; database   xx
+        #:*connect-if-exists*            ; database   xx
+        #:connected-databases            ; database   xx
+        #:database                       ; database   xx
+        #:database-name                     ; database   xx
+        #:disconnect                     ; database   xx
+        #:reconnect                         ; database
+        #:find-database                     ; database   xx
+        #:status                            ; database   xx
+        #:with-database
+        #:with-default-database
+
+        ;; basic-sql.lisp
+        #:query
+        #:execute-command
+        #:write-large-object
+        #:read-large-object
+        #:delete-large-object
+
+        ;; Transactions
+        #:with-transaction
+        #:commit-transaction
+        #:rollback-transaction
+        #:add-transaction-commit-hook
+        #:add-transaction-rollback-hook
+        #:commit                            ; transact   xx
+        #:rollback                       ; transact   xx
+        #:with-transaction               ; transact   xx               .
+        #:start-transaction                 ; transact   xx
+        #:in-transaction-p                  ; transact   xx
+        #:database-start-transaction
+        #:database-abort-transaction
+        #:database-commit-transaction
+        #:transaction-level
+        #:transaction
+        #:disconnect-pooled

         ))
     (:export
      ;; sql.cl
         ))
     (:export
      ;; sql.cl

diff --git a/usql-tests/package.lisp b/usql-tests/package.lisp
index aa44d8bb0558221aa8ccb6365bb5d284313ca25b..7d111d67b0bbc39de83fbf5b98bcb55ffec4f31f 100644 (file)
--- a/usql-tests/package.lisp
+++ b/usql-tests/package.lisp
@@ -14,15 +14,10 @@
 ;;;; ======================================================================
 
 
 ;;;; ======================================================================
 
 

-(in-package :cl-user)
+(in-package #:cl-user)

 
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
-  
-(defpackage :clsql-usql-tests
-  (:nicknames :usql-tests)
-  (:use :clsql-usql :common-lisp :rtest)
-  (:export :test-usql :test-initialise-database :test-connect-to-database)
+(defpackage #:clsql-usql-tests
+  (:nicknames #:usql-tests)
+  (:use #:clsql-usql #:common-lisp #:rtest)
+  (:export #:test-usql #:test-initialise-database #:test-connect-to-database)

   (:documentation "Regression tests for CLSQL-USQL."))
   (:documentation "Regression tests for CLSQL-USQL."))

-
-); eval-when
-  

diff --git a/usql-tests/test-fdml.lisp b/usql-tests/test-fdml.lisp
index e24bbc644140f31340f865adef04c09ce457decd..ae986faa832929b443595b9700af2f74bbc7a6d8 100644 (file)
--- a/usql-tests/test-fdml.lisp
+++ b/usql-tests/test-fdml.lisp
@@ -23,7 +23,7 @@
     (progn
       (usql:insert-records :into [employee] 
                            :values `(11 1 "Yuri" "Gagarin" "gagarin@soviet.org"
     (progn
       (usql:insert-records :into [employee] 
                            :values `(11 1 "Yuri" "Gagarin" "gagarin@soviet.org"

-                                     1 1 1.85 t ,(usql:get-time)))
+                                     1 1 1.85 t ,(clsql-base:get-time)))

       (values 
        (usql:select [first-name] [last-name] [email]
                     :from [employee] :where [= [emplid] 11])
       (values 
        (usql:select [first-name] [last-name] [email]
                     :from [employee] :where [= [emplid] 11])


@@ -392,4 +392,4 @@
             (apply #'values (nreverse results)))))))
   nil nil ("lenin@soviet.org"))
 
             (apply #'values (nreverse results)))))))
   nil nil ("lenin@soviet.org"))
 

-#.(usql:restore-sql-reader-syntax-state)
\ No newline at end of file
+#.(usql:restore-sql-reader-syntax-state)

diff --git a/usql-tests/test-init.lisp b/usql-tests/test-init.lisp
index 67ad1e98bacb7266ff458854670c974a2c53ca30..3076a21d0d11ef4b469a5d9592f1c64476c83416 100644 (file)
--- a/usql-tests/test-init.lisp
+++ b/usql-tests/test-init.lisp
@@ -13,7 +13,7 @@
 ;;;;
 ;;;; ======================================================================
 
 ;;;;
 ;;;; ======================================================================
 

-(in-package :clsql-usql-tests)
+(in-package #:clsql-usql-tests)

 
 (defvar *test-database-type* nil)
 (defvar *test-database-server* "")
 
 (defvar *test-database-type* nil)
 (defvar *test-database-server* "")


@@ -121,7 +121,7 @@
                                        :groupid 1
                                        :married t 
                                        :height (1+ (random 1.00))
                                        :groupid 1
                                        :married t 
                                        :height (1+ (random 1.00))

-                                       :birthday (usql:get-time)
+                                       :birthday (clsql-base:get-time)

                                        :first-name "Vladamir"
                                        :last-name "Lenin"
                                        :email "lenin@soviet.org"))
                                        :first-name "Vladamir"
                                        :last-name "Lenin"
                                        :email "lenin@soviet.org"))


@@ -131,7 +131,7 @@
                                :groupid 1
                               :height (1+ (random 1.00))
                                :married t 
                                :groupid 1
                               :height (1+ (random 1.00))
                                :married t 

-                               :birthday (usql:get-time)
+                               :birthday (clsql-base:get-time)

                                :first-name "Josef"
                               :last-name "Stalin"
                               :email "stalin@soviet.org"))
                                :first-name "Josef"
                               :last-name "Stalin"
                               :email "stalin@soviet.org"))


@@ -141,7 +141,7 @@
                                :groupid 1
                               :height (1+ (random 1.00))
                                :married t 
                                :groupid 1
                               :height (1+ (random 1.00))
                                :married t 

-                               :birthday (usql:get-time)
+                               :birthday (clsql-base:get-time)

                                :first-name "Leon"
                               :last-name "Trotsky"
                               :email "trotsky@soviet.org"))
                                :first-name "Leon"
                               :last-name "Trotsky"
                               :email "trotsky@soviet.org"))


@@ -151,7 +151,7 @@
                                :groupid 1
                               :height (1+ (random 1.00))
                                :married nil
                                :groupid 1
                               :height (1+ (random 1.00))
                                :married nil

-                               :birthday (usql:get-time)
+                               :birthday (clsql-base:get-time)

                                :first-name "Nikita"
                               :last-name "Kruschev"
                               :email "kruschev@soviet.org"))
                                :first-name "Nikita"
                               :last-name "Kruschev"
                               :email "kruschev@soviet.org"))


@@ -161,7 +161,7 @@
                                :groupid 1
                                :married nil
                               :height (1+ (random 1.00))
                                :groupid 1
                                :married nil
                               :height (1+ (random 1.00))

-                               :birthday (usql:get-time)
+                               :birthday (clsql-base:get-time)

                                :first-name "Leonid"
                               :last-name "Brezhnev"
                               :email "brezhnev@soviet.org"))
                                :first-name "Leonid"
                               :last-name "Brezhnev"
                               :email "brezhnev@soviet.org"))


@@ -171,7 +171,7 @@
                                :groupid 1
                                :married nil
                               :height (1+ (random 1.00))
                                :groupid 1
                                :married nil
                               :height (1+ (random 1.00))

-                               :birthday (usql:get-time)
+                               :birthday (clsql-base:get-time)

                                :first-name "Yuri"
                               :last-name "Andropov"
                               :email "andropov@soviet.org"))
                                :first-name "Yuri"
                               :last-name "Andropov"
                               :email "andropov@soviet.org"))


@@ -181,7 +181,7 @@
                                  :groupid 1
                                  :height (1+ (random 1.00))
                                  :married nil
                                  :groupid 1
                                  :height (1+ (random 1.00))
                                  :married nil

-                                 :birthday (usql:get-time)
+                                 :birthday (clsql-base:get-time)

                                  :first-name "Konstantin"
                                  :last-name "Chernenko"
                                  :email "chernenko@soviet.org"))
                                  :first-name "Konstantin"
                                  :last-name "Chernenko"
                                  :email "chernenko@soviet.org"))


@@ -191,7 +191,7 @@
                                  :groupid 1
                                  :height (1+ (random 1.00))
                                  :married nil
                                  :groupid 1
                                  :height (1+ (random 1.00))
                                  :married nil

-                                 :birthday (usql:get-time)
+                                 :birthday (clsql-base:get-time)

                                  :first-name "Mikhail"
                                  :last-name "Gorbachev"
                                  :email "gorbachev@soviet.org"))
                                  :first-name "Mikhail"
                                  :last-name "Gorbachev"
                                  :email "gorbachev@soviet.org"))


@@ -201,7 +201,7 @@
                                  :groupid 1 
                                  :married nil
                                  :height (1+ (random 1.00))
                                  :groupid 1 
                                  :married nil
                                  :height (1+ (random 1.00))

-                                 :birthday (usql:get-time)
+                                 :birthday (clsql-base:get-time)

                                  :first-name "Boris"
                                  :last-name "Yeltsin"
                                  :email "yeltsin@soviet.org"))
                                  :first-name "Boris"
                                  :last-name "Yeltsin"
                                  :email "yeltsin@soviet.org"))


@@ -211,7 +211,7 @@
                                   :groupid 1
                                   :married nil
                                   :height (1+ (random 1.00))
                                   :groupid 1
                                   :married nil
                                   :height (1+ (random 1.00))

-                                  :birthday (usql:get-time)
+                                  :birthday (clsql-base:get-time)

                                   :first-name "Vladamir"
                                   :last-name "Putin"
                                   :email "putin@soviet.org"))
                                   :first-name "Vladamir"
                                   :last-name "Putin"
                                   :email "putin@soviet.org"))

diff --git a/usql-tests/test-ooddl.lisp b/usql-tests/test-ooddl.lisp
index cabf06a0140330e38a9529686def4277a2f7ccdf..aed77007778a70765aa5db92f7d2a84fb8acf4de 100644 (file)
--- a/usql-tests/test-ooddl.lisp
+++ b/usql-tests/test-ooddl.lisp
@@ -58,7 +58,7 @@
   "Lenin")
 
 (deftest :ooddl/time/1
   "Lenin")
 
 (deftest :ooddl/time/1

-    (let* ((now (usql:get-time)))
+    (let* ((now (clsql-base:get-time)))

       (when (member *test-database-type* '(:postgresql :postgresql-socket))
         (usql:execute-command "set datestyle to 'iso'"))
       (usql:update-records [employee] :av-pairs `((birthday ,now))
       (when (member *test-database-type* '(:postgresql :postgresql-socket))
         (usql:execute-command "set datestyle to 'iso'"))
       (usql:update-records [employee] :av-pairs `((birthday ,now))


@@ -66,11 +66,11 @@
       (let ((dbobj (car (usql:select 'employee :where [= [birthday] now]))))
         (values
          (slot-value dbobj 'last-name)
       (let ((dbobj (car (usql:select 'employee :where [= [birthday] now]))))
         (values
          (slot-value dbobj 'last-name)

-         (usql:time= (slot-value dbobj 'birthday) now))))
+         (clsql-base:time= (slot-value dbobj 'birthday) now))))

   "Lenin" t)
 
 (deftest :ooddl/time/2
   "Lenin" t)
 
 (deftest :ooddl/time/2

-    (let* ((now (usql:get-time))
+    (let* ((now (clsql-base:get-time))

            (fail-index -1))
       (when (member *test-database-type* '(:postgresql :postgresql-socket))
         (usql:execute-command "set datestyle to 'iso'"))
            (fail-index -1))
       (when (member *test-database-type* '(:postgresql :postgresql-socket))
         (usql:execute-command "set datestyle to 'iso'"))


@@ -78,10 +78,10 @@
         (usql:update-records [employee] :av-pairs `((birthday ,now))
                              :where [= [emplid] 1])
         (let ((dbobj (car (usql:select 'employee :where [= [birthday] now]))))
         (usql:update-records [employee] :av-pairs `((birthday ,now))
                              :where [= [emplid] 1])
         (let ((dbobj (car (usql:select 'employee :where [= [birthday] now]))))

-          (unless (usql:time= (slot-value dbobj 'birthday) now)
+          (unless (clsql-base:time= (slot-value dbobj 'birthday) now)

             (setf fail-index x))
             (setf fail-index x))

-          (setf now (usql:roll now :day (* 10 x)))))
+          (setf now (clsql-base:roll now :day (* 10 x)))))

       fail-index)
   -1)
 
       fail-index)
   -1)
 

-#.(usql:restore-sql-reader-syntax-state)
\ No newline at end of file
+#.(usql:restore-sql-reader-syntax-state)

diff --git a/usql/classes.lisp b/usql/classes.lisp
index 7a11ddb2c5a4625ea6b3d9355878562246a88537..c390c5f03e18feb77bdc3ba11459b8c149f0f59f 100644 (file)
--- a/usql/classes.lisp
+++ b/usql/classes.lisp
@@ -12,12 +12,9 @@
 ;;;;
 ;;;; ======================================================================
 
 ;;;;
 ;;;; ======================================================================
 

-(in-package :clsql-usql-sys)
+(in-package #:clsql-usql-sys)

 
 
 
 

-(defvar *default-database* nil
-  "Specifies the default database to be used.")
-

 (defvar +empty-string+ "''")
 
 (defvar +null-string+ "NULL")
 (defvar +empty-string+ "''")
 
 (defvar +null-string+ "NULL")

diff --git a/usql/kmr-mop.lisp b/usql/kmr-mop.lisp
new file mode 100644 (file)
index 0000000..32cc35d
--- /dev/null
+++ b/usql/kmr-mop.lisp
@@ -0,0 +1,48 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          kmr-mop.lisp
+;;;; Purpose:       MOP support for multiple-implementions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2003
+;;;;
+;;;; $Id: mop.lisp 8573 2004-01-29 23:30:50Z kevin $
+;;;;
+;;;; This file was extracted from the KMRCL utilities
+;;;; *************************************************************************
+
+;;; This file imports MOP symbols into the USQL-MOP package and then
+;;; re-exports into CLSQL-USQL-SYS them to hide differences in
+;;; MOP implementations.
+
+(in-package #:clsql-usql-sys)
+
+#+lispworks
+(defun intern-eql-specializer (slot)
+  `(eql ,slot))
+
+(defmacro process-class-option (metaclass slot-name &optional required)
+  #+lispworks
+  `(defmethod clos:process-a-class-option ((class ,metaclass)
+                                          (name (eql ,slot-name))
+                                          value)
+    (when (and ,required (null value))
+      (error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name))
+    (list name `',value))
+  #-lispworks
+    (declare (ignore metaclass slot-name required))
+    )
+
+(defmacro process-slot-option (metaclass slot-name)
+  #+lispworks
+  `(defmethod clos:process-a-slot-option ((class ,metaclass)
+                                         (option (eql ,slot-name))
+                                         value
+                                         already-processed-options
+                                         slot)
+    (list* option `',value already-processed-options))
+  #-lispworks
+  (declare (ignore metaclass slot-name))
+  )
+

diff --git a/usql/metaclasses.lisp b/usql/metaclasses.lisp
index d72985eded7c9d708921ee13ff6596f7f8c7afb0..6332d9ea528b9d9c12b53396e00484191382d153 100644 (file)
--- a/usql/metaclasses.lisp
+++ b/usql/metaclasses.lisp
@@ -11,7 +11,27 @@
 ;;;;
 ;;;; ======================================================================
 
 ;;;;
 ;;;; ======================================================================
 

-(in-package :clsql-usql-sys)
+
+(in-package #:clsql-usql-sys)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (>= (length (generic-function-lambda-list
+                    (ensure-generic-function
+                     'compute-effective-slot-definition)))
+           3)
+    (pushnew :kmr-normal-cesd cl:*features*))
+  
+  (when (>= (length (generic-function-lambda-list
+                    (ensure-generic-function
+                     'direct-slot-definition-class)))
+           3)
+    (pushnew :kmr-normal-dsdc cl:*features*))
+  
+  (when (>= (length (generic-function-lambda-list
+                    (ensure-generic-function
+                     'effective-slot-definition-class)))
+           3)
+    (pushnew :kmr-normal-esdc cl:*features*)))

 
 
 ;; ------------------------------------------------------------
 
 
 ;; ------------------------------------------------------------


@@ -125,14 +145,10 @@ of the default method.  The extra allowed options are the value of the
     result))
 
 
     result))
 
 

-(defmethod validate-superclass ((class standard-class)
-                                    (superclass standard-db-class))
-    t)
-
+#+(or cmu scl sbcl openmcl)

 (defmethod validate-superclass ((class standard-db-class)
 (defmethod validate-superclass ((class standard-db-class)

-                                    (superclass standard-class))
-    t)
-
+                               (superclass standard-class))
+  t)

 
 (defun table-name-from-arg (arg)
   (cond ((symbolp arg)
 
 (defun table-name-from-arg (arg)
   (cond ((symbolp arg)


@@ -262,10 +278,17 @@ of the default method.  The extra allowed options are the value of the
       (setq all-slots (remove-if #'not-db-col all-slots))
       (setq all-slots (stable-sort all-slots #'string< :key #'car))
       (setf (object-definition class) all-slots
       (setq all-slots (remove-if #'not-db-col all-slots))
       (setq all-slots (stable-sort all-slots #'string< :key #'car))
       (setf (object-definition class) all-slots

-            (key-slots class) (remove-if-not (lambda (slot)
-                                               (eql (slot-value slot 'db-kind)
-                                                    :key))
-                                             (class-slots class))))))
+           (key-slots class) (remove-if-not (lambda (slot)
+                                              (eql (slot-value slot 'db-kind)
+                                                   :key))
+                                            (class-slots class))))))
+
+#+allegro
+(defmethod finalize-inheritance :after ((class standard-db-class))
+  (setf (key-slots class) (remove-if-not (lambda (slot)
+                                          (eql (slot-value slot 'db-kind)
+                                               :key))
+                                        (class-slots class))))

 
 ;; return the deepest view-class ancestor for a given view class
 
 
 ;; return the deepest view-class ancestor for a given view class
 


@@ -402,14 +425,14 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE")
   ())
 
 (defmethod direct-slot-definition-class ((class standard-db-class)
   ())
 
 (defmethod direct-slot-definition-class ((class standard-db-class)

-                                         #-cmu &rest
+                                         #+kmr-normal-dsdc &rest

                                          initargs)
   (declare (ignore initargs))
   (find-class 'view-class-direct-slot-definition))
 
 (defmethod effective-slot-definition-class ((class standard-db-class)
                                          initargs)
   (declare (ignore initargs))
   (find-class 'view-class-direct-slot-definition))
 
 (defmethod effective-slot-definition-class ((class standard-db-class)

-                                            #-cmu &rest
-                                            initargs)
+                                           #+kmr-normal-esdc &rest
+                                           initargs)

   (declare (ignore initargs))
   (find-class 'view-class-effective-slot-definition))
 
   (declare (ignore initargs))
   (find-class 'view-class-effective-slot-definition))
 


@@ -418,10 +441,9 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE")
 ;; verifies the column name.
 
 (defmethod compute-effective-slot-definition ((class standard-db-class)
 ;; verifies the column name.
 
 (defmethod compute-effective-slot-definition ((class standard-db-class)

-                                             #-cmu slot-name
+                                             #+kmr-normal-cesd slot-name

                                              direct-slots)
                                              direct-slots)

-  ;(declare (ignore #-cmu slot-name direct-slots))
-  (declare (ignore #-cmu slot-name))
+  #+kmr-normal-cesd (declare (ignore slot-name))

   (let ((slotd (call-next-method))
        (sd (car direct-slots)))
     
   (let ((slotd (call-next-method))
        (sd (car direct-slots)))
     


@@ -493,3 +515,12 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE")
   (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
           (class-slots class)))
 
   (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
           (class-slots class)))
 

+#+ignore
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  #+kmr-normal-cesd
+  (setq cl:*features* (delete :kmr-normal-cesd cl:*features*))
+  #+kmr-normal-dsdc
+  (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*))
+  #+kmr-normal-esdc
+  (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
+  )

diff --git a/usql/objects.lisp b/usql/objects.lisp
index 757848c95fab9465ef7aff332e0db40dd944b61c..0478c8f3298b23db3216bffb443fbcdc072f2a65 100644 (file)
--- a/usql/objects.lisp
+++ b/usql/objects.lisp
@@ -43,7 +43,8 @@
   (call-next-method))
 
 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
   (call-next-method))
 
 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)

-                                                    instance slot)
+                                         instance slot)
+  (declare (ignore new-value instance slot))

   (call-next-method))
 
 ;; JMM - Can't go around trying to slot-access a symbol!  Guess in
   (call-next-method))
 
 ;; JMM - Can't go around trying to slot-access a symbol!  Guess in


@@ -770,7 +771,6 @@ DATABASE-NULL-VALUE on the type of the slot."))
           "VARCHAR(255)")))
 
 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
           "VARCHAR(255)")))
 
 (defmethod database-get-type-specifier ((type (eql 'string)) args database)

-  (declare (ignore database))

   (if args
       (format nil "VARCHAR(~A)" (car args))
       (if (member (database-type database) '(:postgresql :postgresql-socket))
   (if args
       (format nil "VARCHAR(~A)" (car args))
       (if (member (database-type database) '(:postgresql :postgresql-socket))

diff --git a/usql/package.lisp b/usql/package.lisp
index 17bb441b820ae6cda5cc4dd7336f16ed7840db77..51fb6ece70eb9a2d133ad8325f6ff447349adcf1 100644 (file)
--- a/usql/package.lisp
+++ b/usql/package.lisp
@@ -1,7 +1,7 @@
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; ======================================================================
 ;;;; File:    package.lisp
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; ======================================================================
 ;;;; File:    package.lisp

-;;;; Author:  Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Author:  Marcus Pearce <m.t.pearce@city.ac.uk>, Kevin Rosenberg

 ;;;; Created: 30/03/2004
 ;;;; Updated: <04/04/2004 12:21:50 marcusp>
 ;;;; ======================================================================
 ;;;; Created: 30/03/2004
 ;;;; Updated: <04/04/2004 12:21:50 marcusp>
 ;;;; ======================================================================


@@ -16,104 +16,201 @@
 (in-package #:cl-user)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 (in-package #:cl-user)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)

-  
-(defpackage #:clsql-usql-sys
-  (:nicknames #:usql-sys #:sql-sys)
-  (:use #:common-lisp #:clsql-base-sys #+lispworks #:clos)
-  ;; This is for working with the CMUCL/SBCL PCL MOP, which is kinda whacky
-  #+(or cmu sbcl)
-  (:shadowing-import-from #+cmu :pcl #+sbcl :sb-pcl 
-                          :built-in-class 
-                          :class-direct-slots
-                          :class-name
-                          :class-of
-                          :class-slots
-                          :compute-effective-slot-definition
-                          :direct-slot-definition-class
-                          :effective-slot-definition-class
-                          :find-class
-                          :slot-boundp
-                          :slot-definition-name
-                          :slot-definition-type
-                          :slot-value-using-class
-                          :standard-direct-slot-definition
-                          :standard-effective-slot-definition
-                          :validate-superclass
-                          :class-direct-superclasses
-                          :name
-                          :standard-class)
-  (:import-from :clsql-base-sys
-                ;; conditions 
-                :clsql-condition
-                :clsql-error
-                :clsql-simple-error
-                :clsql-warning
-                :clsql-simple-warning
-                :clsql-invalid-spec-error
-                :clsql-invalid-spec-error-connection-spec
-                :clsql-invalid-spec-error-database-type
-                :clsql-invalid-spec-error-template
-                :clsql-connect-error
-                :clsql-connect-error-database-type
-                :clsql-connect-error-connection-spec
-                :clsql-connect-error-errno
-                :clsql-connect-error-error
-                :clsql-sql-error
-                :clsql-sql-error-database
-                :clsql-sql-error-expression
-                :clsql-sql-error-errno
-                :clsql-sql-error-error
-                :clsql-database-warning
-                :clsql-database-warning-database
-                :clsql-database-warning-message
-                :clsql-exists-condition
-                :clsql-exists-condition-new-db
-                :clsql-exists-condition-old-db
-                :clsql-exists-warning
-                :clsql-exists-error
-                :clsql-closed-error
-                :clsql-closed-error-database
-                :clsql-type-error
-                :clsql-sql-syntax-error
-                ;; db-interface
-                :check-connection-spec
-                :database-initialize-database-type
-                :database-type-load-foreign
-                :database-name-from-spec
-                :database-create-sequence
-                :database-drop-sequence
-                :database-sequence-next
-                :database-set-sequence-position
-                :database-query-result-set
-                :database-dump-result-set
-                :database-store-next-row
-                :database-get-type-specifier
-                :database-list-tables
-                :database-list-views
-                :database-list-indexes
-                :database-list-sequences
-                :database-list-attributes
-                :database-attribute-type
-                :database-add-attribute
-                :database-type 
-                ;; initialize
-                :*loaded-database-types*
-                :reload-database-types
-                :*default-database-type*
-                :*initialized-database-types*
-                :initialize-database-type
-                ;; classes
-                :database
-                :closed-database
-                :database-name
-                :command-recording-stream
-                :result-recording-stream
-                :database-view-classes
-                :database-schema
-                :conn-pool
-                :print-object 
-                ;; utils
-                :sql-escape)
+
+#+sbcl
+  (if (find-package 'sb-mop)
+      (pushnew :usql-sbcl-mop cl:*features*)
+      (pushnew :usql-sbcl-pcl cl:*features*))
+
+  #+cmu
+  (if (eq (symbol-package 'pcl:find-class)
+         (find-package 'common-lisp))
+      (pushnew :usql-cmucl-mop cl:*features*)
+      (pushnew :usql-cmucl-pcl cl:*features*)))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defpackage #:clsql-usql-sys
+    (:nicknames #:usql-sys)
+    (:use #:common-lisp #:clsql-base-sys
+         #+usql-sbcl-mop #:sb-mop
+         #+usql-cmucl-mop #:mop
+         #+allegro #:mop
+         #+lispworks #:clos
+         #+scl #:clos
+         #+openmcl #:openmcl-mop)
+    
+    #+allegro
+    (:shadowing-import-from 
+     #:excl)
+   #+lispworks
+   (:shadowing-import-from 
+    #:clos)
+   #+usql-sbcl-mop 
+   (:shadowing-import-from 
+    #:sb-pcl
+    #:generic-function-lambda-list)
+   #+usql-sbcl-pcl
+   (:shadowing-import-from 
+    #:sb-pcl
+    #:name
+    #:class-direct-slots
+    #:class-of #:class-name #:class-slots #:find-class
+    #:slot-boundp
+    #:standard-class
+    #:slot-definition-name #:finalize-inheritance
+    #:standard-direct-slot-definition
+    #:standard-effective-slot-definition #:validate-superclass
+    #:direct-slot-definition-class #:compute-effective-slot-definition
+    #:effective-slot-definition-class
+    #:slot-value-using-class
+    #:class-prototype #:generic-function-method-class #:intern-eql-specializer
+    #:make-method-lambda #:generic-function-lambda-list
+    #:class-precedence-list #:slot-definition-type
+    #:class-direct-superclasses)
+   #+usql-cmucl-mop 
+   (:shadowing-import-from 
+    #:pcl
+    #:generic-function-lambda-list)
+   #+usql-cmucl-pcl
+   (:shadowing-import-from 
+    #:pcl
+    #:class-direct-slots
+    #:name
+    #:class-of  #:class-name #:class-slots #:find-class #:standard-class
+    #:slot-boundp
+    #:slot-definition-name #:finalize-inheritance
+    #:standard-direct-slot-definition #:standard-effective-slot-definition
+    #:validate-superclass #:direct-slot-definition-class
+    #:effective-slot-definition-class
+    #:compute-effective-slot-definition
+    #:slot-value-using-class
+    #:class-prototype #:generic-function-method-class #:intern-eql-specializer
+    #:make-method-lambda #:generic-function-lambda-list
+    #:class-precedence-list #:slot-definition-type
+    #:class-direct-superclasses)
+   #+scl
+   (:shadowing-import-from 
+    #:clos
+    #:class-prototype  ;; note: make-method-lambda is not fbound
+    )
+   
+   (:import-from 
+    #:clsql-base-sys
+    .
+    #1=(
+       ;; conditions 
+       :clsql-condition
+       :clsql-error
+       :clsql-simple-error
+       :clsql-warning
+       :clsql-simple-warning
+       :clsql-invalid-spec-error
+       :clsql-invalid-spec-error-connection-spec
+       :clsql-invalid-spec-error-database-type
+       :clsql-invalid-spec-error-template
+       :clsql-connect-error
+       :clsql-connect-error-database-type
+       :clsql-connect-error-connection-spec
+       :clsql-connect-error-errno
+       :clsql-connect-error-error
+       :clsql-sql-error
+       :clsql-sql-error-database
+       :clsql-sql-error-expression
+       :clsql-sql-error-errno
+       :clsql-sql-error-error
+       :clsql-database-warning
+       :clsql-database-warning-database
+       :clsql-database-warning-message
+       :clsql-exists-condition
+       :clsql-exists-condition-new-db
+       :clsql-exists-condition-old-db
+       :clsql-exists-warning
+       :clsql-exists-error
+       :clsql-closed-error
+       :clsql-closed-error-database
+       :clsql-type-error
+       :clsql-sql-syntax-error
+
+       ;; db-interface
+       :check-connection-spec
+       :database-initialize-database-type
+       :database-type-load-foreign
+       :database-name-from-spec
+       :database-create-sequence
+       :database-drop-sequence
+       :database-sequence-next
+       :database-set-sequence-position
+       :database-query-result-set
+       :database-dump-result-set
+       :database-store-next-row
+       :database-get-type-specifier
+       :database-list-tables
+       :database-list-views
+       :database-list-indexes
+       :database-list-sequences
+       :database-list-attributes
+       :database-attribute-type
+       :database-add-attribute
+       :database-type 
+       ;; initialize
+       :*loaded-database-types*
+       :reload-database-types
+       :*default-database-type*
+       :*initialized-database-types*
+       :initialize-database-type
+       ;; classes
+       :database
+       :closed-database
+       :database-name
+       :command-recording-stream
+       :result-recording-stream
+       :database-view-classes
+       :database-schema
+       :conn-pool
+       :print-object 
+       ;; utils
+       :sql-escape
+
+        ;; database.lisp -- Connection
+        #:*default-database-type*                ; clsql-base xx
+        #:*default-database*             ; classes    xx
+        #:connect                                ; database   xx
+        #:*connect-if-exists*            ; database   xx
+        #:connected-databases            ; database   xx
+        #:database                       ; database   xx
+        #:database-name                     ; database   xx
+        #:disconnect                     ; database   xx
+        #:reconnect                         ; database
+        #:find-database                     ; database   xx
+        #:status                            ; database   xx
+        #:with-database
+        #:with-default-database
+
+        ;; basic-sql.lisp
+        #:query
+        #:execute-command
+        #:write-large-object
+        #:read-large-object
+        #:delete-large-object
+
+        ;; Transactions
+        #:with-transaction
+        #:commit-transaction
+        #:rollback-transaction
+        #:add-transaction-commit-hook
+        #:add-transaction-rollback-hook
+        #:commit                            ; transact   xx
+        #:rollback                       ; transact   xx
+        #:with-transaction               ; transact   xx               .
+        #:start-transaction                 ; transact   xx
+        #:in-transaction-p                  ; transact   xx
+        #:database-start-transaction
+        #:database-abort-transaction
+        #:database-commit-transaction
+        #:transaction-level
+        #:transaction
+        ))

   (:export
    ;; "Private" exports for use by interface packages
    :check-connection-spec
   (:export
    ;; "Private" exports for use by interface packages
    :check-connection-spec


@@ -146,7 +243,7 @@
    ;; I = Implemented, D = Documented
    ;;  name                                 file       ID
    ;;====================================================
    ;; I = Implemented, D = Documented
    ;;  name                                 file       ID
    ;;====================================================

-   #1=(;;------------------------------------------------
+   #2=(;;------------------------------------------------

        ;; CommonSQL API 
        ;;------------------------------------------------
       ;;FDML 
        ;; CommonSQL API 
        ;;------------------------------------------------
       ;;FDML 


@@ -234,37 +331,6 @@
        :database-get-type-specifier       ; objects    x
        :database-output-sql               ; sql/class  xx
 
        :database-get-type-specifier       ; objects    x
        :database-output-sql               ; sql/class  xx
 

-       ;;-----------------------------------------------
-       ;; Conditions/Warnings/Errors
-       ;;-----------------------------------------------
-       :clsql-condition
-       :clsql-error
-       :clsql-simple-error
-       :clsql-warning
-       :clsql-simple-warning
-       :clsql-invalid-spec-error
-       :clsql-invalid-spec-error-connection-spec
-       :clsql-invalid-spec-error-database-type
-       :clsql-invalid-spec-error-template
-       :clsql-connect-error
-       :clsql-connect-error-database-type
-       :clsql-connect-error-connection-spec
-       :clsql-connect-error-errno
-       :clsql-connect-error-error
-       :clsql-sql-error
-       :clsql-type-error
-       :clsql-sql-error-database
-       :clsql-sql-error-expression
-       :clsql-sql-error-errno
-       :clsql-sql-error-error
-       :clsql-exists-condition
-       :clsql-exists-condition-new-db
-       :clsql-exists-condition-old-db
-       :clsql-exists-warning
-       :clsql-exists-error
-       :clsql-closed-error
-       :clsql-closed-error-database
-

        ;;-----------------------------------------------
        ;; Symbolic Sql Syntax 
        ;;-----------------------------------------------
        ;;-----------------------------------------------
        ;; Symbolic Sql Syntax 
        ;;-----------------------------------------------


@@ -306,7 +372,9 @@
        :sql-view-class
        :sql_slot-value
 
        :sql-view-class
        :sql_slot-value
 

-))
+       . 
+       #1#
+       ))

   (:documentation "This is the INTERNAL SQL-Interface package of USQL."))
 
 
   (:documentation "This is the INTERNAL SQL-Interface package of USQL."))
 
 


@@ -318,10 +386,34 @@
 (defpackage #:clsql-usql
   (:nicknames #:usql #:sql)
   (:use :common-lisp)
 (defpackage #:clsql-usql
   (:nicknames #:usql #:sql)
   (:use :common-lisp)

-  (:import-from :clsql-usql-sys . #1#)
-  (:export . #1#)
+  (:import-from :clsql-usql-sys . #2#)
+  (:export . #2#)

   (:documentation "This is the SQL-Interface package of USQL."))
 
   (:documentation "This is the SQL-Interface package of USQL."))
 

+  ;; This is from USQL's pcl-patch  
+  #+(or usql-sbcl-pcl usql-cmucl-pcl)
+  (progn
+    ;; Note that this will no longer required for cmucl as of version 19a. 
+    (in-package #+cmu :pcl #+sbcl :sb-pcl)
+    (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) 
+                          &body body)
+      `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
+       (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
+                       slot-vars pv-parameters))
+         ,@(mapcar #'(lambda (slot-var) `(declare (ignorable ,slot-var))) slot-vars)
+         ,@body))))
+  
+  
+  #+sbcl
+  (if (find-package 'sb-mop)
+      (setq cl:*features* (delete :usql-sbcl-mop cl:*features*))
+      (setq cl:*features* (delete :usql-sbcl-pcl cl:*features*)))
+  
+  #+cmu
+  (if (find-package 'mop)
+      (setq cl:*features* (delete :usql-cmucl-mop cl:*features*))
+      (setq cl:*features* (delete :usql-cmucl-pcl cl:*features*)))
+  

 );eval-when                                      
 
 
 );eval-when                                      
 
 

diff --git a/usql/pcl-patch.lisp b/usql/pcl-patch.lisp
deleted file mode 100644 (file)
index fd246f8..0000000
--- a/usql/pcl-patch.lisp
+++ /dev/null
@@ -1,12 +0,0 @@
-
-;; Note that this will no longer required for cmucl as of version 19a. 
-
-(in-package #+cmu :pcl #+sbcl :sb-pcl)
-
-(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) 
-                      &body body)
-  `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
-     (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
-              slot-vars pv-parameters))
-       ,@(mapcar #'(lambda (slot-var) `(declare (ignorable ,slot-var))) slot-vars)
-       ,@body)))