r8989: v 2.6.11

diff --git a/ChangeLog b/ChangeLog
index c663a82ffdc03389f5659fdbbd1d3936c4c96bd0..b419131966583f1509f28a7c875d1c2e4ae0dcb3 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,7 +1,9 @@
 12 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
        * Version 2.6.11
+       * sql/objects.lisp: add :root-class functionality for
+       list-classes and add duration type support [Marcus Pearce]
        * db-odbc: Add mid-level [DBI] layer
-       
+
 12 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
        * Version 2.6.10
        * db-aodbc: Add methods for generic functions, some are

diff --git a/TODO b/TODO
index 739fe7a658a857b939ef41a52bc4174d95785827..9e3d694ba3317d08123a3165f138f142fe65242c 100644 (file)
--- a/TODO
+++ b/TODO
@@ -49,9 +49,6 @@ COMMONSQL SPEC
       o get :target-slot working 
       o implement :retrieval :immediate 
 
-    LIST-CLASSES 
-      o keyword arg :root-class should do something (portable)
-
     DO-QUERY,MAP-QUERY,LOOP
       o should work with object queries as well as functional ones 
 

diff --git a/sql/objects.lisp b/sql/objects.lisp
index a84bf3be9c44c19d843feb4f7632aafaabdd51d7..e1bc241e09cdf26c4be92f3e9d1ff7517052063a 100644 (file)
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -113,8 +113,6 @@ the view. The argument DATABASE has a default value of
 ;; Drop the tables which store the given view class
 ;;
 
-#.(locally-enable-sql-reader-syntax)
-
 (defun drop-view-from-class (view-class-name &key (database *default-database*))
   "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME
 which defines that view. The argument DATABASE has a default value of
@@ -126,8 +124,6 @@ which defines that view. The argument DATABASE has a default value of
         (error "Class ~s not found." view-class-name)))
   (values))
 
-#.(restore-sql-reader-syntax-state)
-
 (defun %uninstall-class (self &key (database *default-database*))
   (drop-table (sql-expression :table (view-table self))
               :if-does-not-exist :ignore
@@ -141,13 +137,21 @@ which defines that view. The argument DATABASE has a default value of
 ;;
 
 (defun list-classes (&key (test #'identity)
-                          (root-class 'standard-db-object)
-                          (database *default-database*))
-  "Returns a list of View Classes connected to a given DATABASE which
-defaults to *DEFAULT-DATABASE*."
-  (declare (ignore root-class))
-  (remove-if #'(lambda (c) (not (funcall test c)))
-             (database-view-classes database)))
+                    (root-class (find-class 'standard-db-object))
+                    (database *default-database*))
+  "The LIST-CLASSES function collects all the classes below
+ROOT-CLASS, which defaults to standard-db-object, that are connected
+to the supplied DATABASE and which satisfy the TEST function. The
+default for the TEST argument is identity. By default, LIST-CLASSES
+returns a list of all the classes connected to the default database,
+*DEFAULT-DATABASE*."
+  (flet ((find-superclass (class) 
+          (member root-class (class-precedence-list class))))
+    (let ((view-classes (and database (database-view-classes database))))
+      (when view-classes
+       (remove-if #'(lambda (c) (or (not (funcall test c))
+                                    (not (find-superclass c))))
+                  view-classes)))))
 
 ;;
 ;; Define a new view class
@@ -727,6 +731,11 @@ DATABASE-NULL-VALUE on the type of the slot."))
   (unless (eq 'NULL val)
     (parse-timestring val)))
 
+(defmethod read-sql-value (val (type (eql 'duration)) database)
+  (declare (ignore database))
+  (unless (or (eq 'NULL val)
+              (equal "NIL" val))
+    (parse-timestring val)))
 
 ;; ------------------------------------------------------------
 ;; Logic for 'faulting in' :join slots

diff --git a/sql/sql.lisp b/sql/sql.lisp
index 8cf7758263c04133f7a864bca783af375ea40ca5..8227fea896f9b611cfe3fbf377855fff3cbdcc0c 100644 (file)
--- a/sql/sql.lisp
+++ b/sql/sql.lisp
@@ -217,6 +217,10 @@ condition is true."
   (declare (ignore database))
   (db-timestring self))
 
+(defmethod database-output-sql ((self duration) database)
+  (declare (ignore database))
+  (format nil "'~a'" (duration-timestring self)))
+
 (defmethod database-output-sql (thing database)
   (if (or (null thing)
          (eq 'null thing))