r8963: pre 2.6.4

diff --git a/ChangeLog b/ChangeLog
index 5adcac1522f13eda795e94082f0c885ad230e40a..0ef29d1ea432c0611806790d1521dd054cf79427 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
+       * Version 2.6.4
+       * test/test-init.lisp: Properly handle object
+       creation. Close database after use.
+       * sql/sql.lisp: Make DESCRIBE-TABLE a generic
+       function so can have methods specialized on
+       table being a string or an sql-table object.
+       * base/pool.lisp: Really CMUCL locking
+       
 10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
        * Version 2.6.3
        * test/test-init.lisp: Signal correctly

diff --git a/base/basic-sql.lisp b/base/basic-sql.lisp
index 64fdb44038d4741eecb6b5c7ceb27e5768067e66..5c12002bcfe527802991a4d4ebd2ca16629778cb 100644 (file)
--- a/base/basic-sql.lisp
+++ b/base/basic-sql.lisp
@@ -60,8 +60,7 @@ pair."))
   (values))
 
 
-(defun describe-table (table &key (database *default-database*))
-  "Return list of 2-element lists containing table name and type."
+(defmethod describe-table ((table string) &key (database *default-database*))
   (database-describe-table database table))
 
 (defmacro do-query (((&rest args) query-expression

diff --git a/base/db-interface.lisp b/base/db-interface.lisp
index 4f1dc209ee4eb218d9085cac8854618e4fe3323c..b2ba6e5533a1f20735a017757d517dd85553b7a7 100644 (file)
--- a/base/db-interface.lisp
+++ b/base/db-interface.lisp
@@ -254,3 +254,7 @@ the given lisp type and parameters."))
 (defmethod database-abort-transaction :before ((database database))
   (unless (is-database-open database)
     (signal-closed-database-error database)))
+
+(defgeneric describe-table (table &key database)
+  (:documentation "Describes a table, returns a list of name/type for columns in table"))
+

diff --git a/base/pool.lisp b/base/pool.lisp
index 53730e3a462a87a267fd4faf99f4b107042f63eb..e051423dced247c09b3cae05e5f46cbfe65d4738 100644 (file)
--- a/base/pool.lisp
+++ b/base/pool.lisp
@@ -35,10 +35,10 @@
   (let ((l (gensym)))
     `(let ((,l ,lock))
       #+allegro (mp:with-process-lock (,l) ,@body)
-      #+cmu `(mp:with-lock-held (,lock) ,@body)
-      #+openmcl (ccl:with-lock-grabbed (,lock) ,@body)
+      #+cmu (mp:with-lock-held (,l) ,@body)
+      #+openmcl (ccl:with-lock-grabbed (,l) ,@body)
       #+lispworks (mp:with-lock (,l) ,@body)
-      #+sb-thread (sb-thread:with-recursive-lock (,lock) ,@body)
+      #+sb-thread (sb-thread:with-recursive-lock (,l) ,@body)
       ))
 
   #+scl `(thread:with-lock-held (,lock ,desc) ,@body)

diff --git a/clsql-base.asd b/clsql-base.asd
index 4a13f783b3c0f090659c9c23f7ce1a9dc2a7129b..a870cd0d46721927293fdab4d65d1b2b6d3b5655 100644 (file)
--- a/clsql-base.asd
+++ b/clsql-base.asd
@@ -38,7 +38,7 @@
             (:file "package")
             (:file "utils" :depends-on ("package"))
             (:file "classes" :depends-on ("package"))
-            (:file "conditions" :depends-on ("classes"))
+            (:file "conditions" :depends-on ("classes" "utils"))
             (:file "db-interface" :depends-on ("conditions"))
             (:file "initialize" :depends-on ("db-interface"))
             (:file "loop-extension" :depends-on ("db-interface"))

diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp
index 2ceb6798bcd83e27d4be61ae761ead66ed08d387..1e29c070d6749dfac59dcc88dde53898c397aff0 100644 (file)
--- a/db-postgresql-socket/postgresql-socket-sql.lisp
+++ b/db-postgresql-socket/postgresql-socket-sql.lisp
@@ -467,12 +467,7 @@ doesn't depend on UFFI."
                                    and a.attnum > 0
                                    and a.attrelid = c.oid
                                    and a.atttypid = t.oid"
-           (sql-escape (string-downcase 
-                       (etypecase table
-                         (string table)
-                         (clsql-base-sys::sql-create-table
-                          (symbol-name 
-                           (slot-value table 'clsql-base-sys::name)))))))
+           (sql-escape (string-downcase table)))
    database :auto))
 
 (when (clsql-base-sys:database-type-library-loaded :postgresql-socket)

diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp
index 5758730e07f19486a79086b364456f3277a8a080..ae3c18ef936cf097ae5325b929ead2a73dbe14a3 100644 (file)
--- a/db-postgresql/postgresql-sql.lisp
+++ b/db-postgresql/postgresql-sql.lisp
@@ -536,12 +536,7 @@
                                    and a.attnum > 0
                                    and a.attrelid = c.oid
                                    and a.atttypid = t.oid"
-           (sql-escape (string-downcase 
-                       (etypecase table
-                         (string table)
-                         (clsql-base-sys::sql-create-table
-                          (symbol-name 
-                           (slot-value table 'clsql-base-sys::name)))))))
+           (sql-escape (string-downcase table)))
    database :auto))
 
 (defun %pg-database-connection (connection-spec)

diff --git a/sql/new-objects.lisp b/sql/new-objects.lisp
index c06882fe78fe2cf5decc7f45a5536679d385c7d7..cfd63e173bacb0a2c5240c7f306f2129d93e9206 100644 (file)
--- a/sql/new-objects.lisp
+++ b/sql/new-objects.lisp
@@ -28,14 +28,15 @@
 (defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
   (declare (optimize (speed 3)))
   (unless *db-deserializing*
-    (let ((slot-name (slot-definition-name slot-def))
-          (slot-kind (view-class-slot-db-kind slot-def)))
+    (let* ((slot-name (%svuc-slot-name slot-def))
+          (slot-object (%svuc-slot-object slot-def class))
+          (slot-kind (view-class-slot-db-kind slot-object)))
       (when (and (eql slot-kind :join)
                  (not (slot-boundp instance slot-name)))
         (let ((*db-deserializing* t))
           (setf (slot-value instance slot-name)
                 (fault-join-slot class instance slot-def))))))
-  (call-next-method))
+    (call-next-method))
 
 (defmethod (setf slot-value-using-class) :around (new-value (class standard-db-class) instance slot-def)
   (declare (ignore new-value))
@@ -87,8 +88,6 @@
               (database-output-sql keylist database)))))
 
 
-
-
 (defun create-view-from-class (view-class-name
                                &key (database *default-database*))
   "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
@@ -97,9 +96,7 @@ the view. The argument DATABASE has a default value of
   (let ((tclass (find-class view-class-name)))
     (if tclass
         (let ((*default-database* database))
-          (%install-class tclass database)
-          #+noschema (ensure-schema-version-table database)
-          #+noschema (update-schema-version-records view-class-name :database database))
+          (%install-class tclass database))
         (error "Class ~s not found." view-class-name)))
   (values))
 
@@ -130,10 +127,7 @@ which defines that view. The argument DATABASE has a default value of
   (let ((tclass (find-class view-class-name)))
     (if tclass
         (let ((*default-database* database))
-          (%uninstall-class tclass)
-         #+nil
-          (delete-records :from [clsql_object_v]
-                          :where [= [name] (sql-escape view-class-name)]))
+          (%uninstall-class tclass))
         (error "Class ~s not found." view-class-name)))
   (values))
 
@@ -257,13 +251,7 @@ superclass of the newly-defined View Class."
       list))
 
 (defun slot-type (slotdef)
-  (specified-type slotdef)
-  #+ignore
-  (let ((slot-type (specified-type slotdef)))
-    (if (listp slot-type)
-        (cons (find-symbol (symbol-name (car slot-type)) :clsql-sys)
-              (cdr slot-type))
-        (find-symbol (symbol-name slot-type) :clsql-sys))))
+  (specified-type slotdef))
 
 (defvar *update-context* nil)
 
@@ -404,7 +392,6 @@ superclass of the newly-defined View Class."
           (setf (slot-value target slot-name)
                 nil)))))
 
-
 (defgeneric update-record-from-slot (object slot &key database)
   (:documentation
    "The generic function UPDATE-RECORD-FROM-SLOT updates an individual
@@ -474,7 +461,6 @@ names are derived from the view class definition."))
            (error "Unable to update records"))))
   t)
 
-
 (defgeneric update-records-from-instance (object &key database)
   (:documentation
    "Using an instance of a view class, update the database table that

diff --git a/sql/objects.lisp b/sql/objects.lisp
index 3c6588f5540af9aa2e3d2723cac8b87f82ff1fd5..3073bfd17eb916214be19d3421e22dec168a61a8 100644 (file)
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -16,24 +16,19 @@
 (in-package #:clsql-sys)
 
 (defclass standard-db-object ()
-  ((view-database
-    :initform nil
-    :initarg :view-database
+  ((view-database :initform nil :initarg :view-database :reader view-database
     :db-kind :virtual))
   (:metaclass standard-db-class)
   (:documentation "Superclass for all CLSQL View Classes."))
 
-(defmethod view-database ((self standard-db-object))
-  (slot-value self 'view-database))
-
 (defvar *db-deserializing* nil)
 (defvar *db-initializing* nil)
 
-(defmethod slot-value-using-class ((class standard-db-class) instance slot)
+(defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
   (declare (optimize (speed 3)))
   (unless *db-deserializing*
-    (let* ((slot-name (%svuc-slot-name slot))
-          (slot-object (%svuc-slot-object slot class))
+    (let* ((slot-name (%svuc-slot-name slot-def))
+          (slot-object (%svuc-slot-object slot-def class))
           (slot-kind (view-class-slot-db-kind slot-object)))
       (when (and (eql slot-kind :join)
                  (not (slot-boundp instance slot-name)))
@@ -50,8 +45,7 @@
   (call-next-method))
 
 (defmethod initialize-instance :around ((class standard-db-object)
-                                        &rest all-keys
-                                        &key &allow-other-keys)
+                                        &rest all-keys &key &allow-other-keys)
   (declare (ignore all-keys))
   (let ((*db-deserializing* t))
     (call-next-method)))
@@ -125,9 +119,7 @@ which defines that view. The argument DATABASE has a default value of
   (let ((tclass (find-class view-class-name)))
     (if tclass
         (let ((*default-database* database))
-          (%uninstall-class tclass)
-          (delete-records :from [clsql_object_v]
-                          :where [= [name] (sql-escape view-class-name)]))
+          (%uninstall-class tclass))
         (error "Class ~s not found." view-class-name)))
   (values))
 
@@ -251,11 +243,7 @@ superclass of the newly-defined View Class."
       list))
 
 (defun slot-type (slotdef)
-  (let ((slot-type (specified-type slotdef)))
-    (if (listp slot-type)
-        (cons (find-symbol (symbol-name (car slot-type)) :clsql-sys)
-              (cdr slot-type))
-        (find-symbol (symbol-name slot-type) :clsql-sys))))
+  (specified-type slotdef))
 
 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
@@ -526,9 +514,6 @@ associated with that database."))
         (setf (slot-value obj 'view-database) database))
     (values)))
 
-;; Perhaps the slot class is not correct in all CLOS implementations,
-;; tho I have not run across a problem yet.
-
 (defmethod handle-cascade-delete-rule ((instance standard-db-object)
                                       (slot
                                         view-class-effective-slot-definition))
@@ -666,14 +651,14 @@ value.  If nulls are allowed for the column, the slot's value will be
 nil, otherwise its value will be set to the result of calling
 DATABASE-NULL-VALUE on the type of the slot."))
 
-(defmethod update-slot-with-null ((instance standard-db-object)
+(defmethod update-slot-with-null ((object standard-db-object)
                                  slotname
                                  slotdef)
   (let ((st (slot-type slotdef))
         (allowed (slot-value slotdef 'nulls-ok)))
     (if allowed
-        (setf (slot-value instance slotname) nil)
-        (setf (slot-value instance slotname)
+        (setf (slot-value object slotname) nil)
+        (setf (slot-value object slotname)
               (database-null-value st)))))
 
 (defvar +no-slot-value+ '+no-slot-value+)
@@ -886,7 +871,7 @@ DATABASE-NULL-VALUE on the type of the slot."))
 ;; ------------------------------------------------------------
 ;; Logic for 'faulting in' :join slots
 
-(defun fault-join-slot-raw (class instance slot-def)
+(defun fault-join-slot-raw (class instancex slot-def)
   (let* ((dbi (view-class-slot-db-info slot-def))
         (jc (gethash :join-class dbi)))
     (let ((jq (join-qualifier class instance slot-def)))
@@ -909,7 +894,7 @@ DATABASE-NULL-VALUE on the type of the slot."))
        ((and (not ts) (gethash :set dbi))
         res)))))
 
-(defun join-qualifier (class instance slot-def)
+(defun join-qualifier (class object slot-def)
     (declare (ignore class))
     (let* ((dbi (view-class-slot-db-info slot-def))
           (jc (find-class (gethash :join-class dbi)))
@@ -918,8 +903,8 @@ DATABASE-NULL-VALUE on the type of the slot."))
           (foreign-keys (gethash :foreign-key dbi))
           (home-keys (gethash :home-key dbi)))
       (when (every #'(lambda (slt)
-                      (and (slot-boundp instance slt)
-                            (not (null (slot-value instance slt)))))
+                      (and (slot-boundp object slt)
+                            (not (null (slot-value object slt)))))
                   (if (listp home-keys) home-keys (list home-keys)))
        (let ((jc
                (mapcar #'(lambda (hk fk)
@@ -934,7 +919,7 @@ DATABASE-NULL-VALUE on the type of the slot."))
                                               (t fk))
                                             (typecase hk
                                               (symbol
-                                               (slot-value instance hk))
+                                               (slot-value object hk))
                                               (t
                                                hk)))))
                        (if (listp home-keys)
@@ -1051,6 +1036,7 @@ tuples."
                        target-args))))
     (multiple-value-bind (target-args qualifier-args)
         (query-get-selections select-all-args)
+      ;; (cmsg "Qual args = ~s" qualifier-args)
       (if (select-objects target-args)
           (apply #'find-all target-args qualifier-args)
           (let ((expr (apply #'make-query select-all-args)))

diff --git a/sql/sql.lisp b/sql/sql.lisp
index 077e27dd365bcd7e79aea520667c3b29be4693f9..a904c89ba7af437459d289932cc3f3c4bb6fda18 100644 (file)
--- a/sql/sql.lisp
+++ b/sql/sql.lisp
@@ -255,6 +255,12 @@ condition is true."
         (write-char #\) *sql-stream*)))
   t)
 
+(defmethod describe-table ((table sql-create-table)
+                          &key (database *default-database*))
+  (database-describe-table
+   database
+   (string-downcase (symbol-name (slot-value table 'name)))))
+
 #+nil
 (defmethod add-storage-class ((self database) (class symbol) &key (sequence t))
   (let ((tablename (view-table (find-class class))))

diff --git a/tests/test-init.lisp b/tests/test-init.lisp
index 0f4180ab4d3d301a459e8f2bc57ac78851f5e017..ae0c6b4bf26bdc954b8dc81c70e6f65c31d450e0 100644 (file)
--- a/tests/test-init.lisp
+++ b/tests/test-init.lisp
@@ -7,6 +7,11 @@
 ;;;;
 ;;;; Initialisation utilities for running regression tests on CLSQL. 
 ;;;;
+;;;; This file is part of CLSQL.
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; ======================================================================
 
 (in-package #:clsql-tests)
@@ -124,12 +129,6 @@
                 :make-default t
                 :if-exists :old))
 
-(defmacro with-ignore-errors (&rest forms)
-  `(progn
-     ,@(mapcar
-       (lambda (x) (list 'ignore-errors x))
-       forms)))
-
 (defparameter company1 nil)
 (defparameter employee1 nil)
 (defparameter employee2 nil)
@@ -144,9 +143,8 @@
 
 (defun test-initialise-database ()
   ;; Create the tables for our view classes
-  (ignore-errors
-   (clsql:drop-view-from-class 'employee)
-   (clsql:drop-view-from-class 'company))
+  (ignore-errors (clsql:drop-view-from-class 'employee))
+  (ignore-errors (clsql:drop-view-from-class 'company))
   (clsql:create-view-from-class 'employee)
   (clsql:create-view-from-class 'company)