r9179: 30 Apr 2004 Marcus Pearce (m.t.pearce@city.ac.uk)
authorKevin M. Rosenberg <kevin@rosenberg.net>
Fri, 30 Apr 2004 23:21:13 +0000 (23:21 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Fri, 30 Apr 2004 23:21:13 +0000 (23:21 +0000)
        * Version 2.9.6
        * sql/objects.lisp: remove create/drop-sequence-from-class.
        * sql/objects.lisp: add INSTANCE-REFRESHED generic function.
        * sql/objects.lisp: improved CommonSQL compatibility for
        UPDATE-RECORD-FROM-SLOT, UPDATE-RECORD-FROM-SLOTS,
        UPDATE-RECORDS-FROM-INSTANCE and DELETE-INSTANCE-RECORDS.
        * sql/generics.lisp: move generics from objects.lisp to here.

ChangeLog
TODO
db-mysql/mysql-client-info.lisp
debian/changelog
sql/generics.lisp
sql/objects.lisp
sql/package.lisp
sql/sql.lisp

index 1aa949942d53848407d4780c1b53f65a37684986..a0cd1f292cbb26b2953a55b41fa75642f705f58f 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,19 @@
+30 Apr 2004 Marcus Pearce (m.t.pearce@city.ac.uk) 
+       * Version 2.9.6
+       * sql/objects.lisp: remove create/drop-sequence-from-class. 
+       * sql/objects.lisp: add INSTANCE-REFRESHED generic function. 
+       * sql/objects.lisp: improved CommonSQL compatibility for
+       UPDATE-RECORD-FROM-SLOT, UPDATE-RECORD-FROM-SLOTS,
+       UPDATE-RECORDS-FROM-INSTANCE and DELETE-INSTANCE-RECORDS. 
+       * sql/generics.lisp: move generics from objects.lisp to here. 
+       
 29 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
        * Version 2.9.6-pre1
        * db-mysql/mysql-client-info.lisp: Add client version 4.1
        detection
-
+       * sql/sql.lisp: Make *default-database* the default for
+       TRUNCATE-DATABASE
+       
 28 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
        * Version 2.9.5
        * db-mysql/mysql-sql.lisp: Fix bug in transaction capability
diff --git a/TODO b/TODO
index a648df17ccdab28fde7907f956a10aa5fe9863f6..e71c4bd5e01f5f1ca1b8a89b2520ffdf87ee8740 100644 (file)
--- a/TODO
+++ b/TODO
@@ -12,7 +12,6 @@ COMMONSQL SPEC
   *CACHE-TABLE-QUERIES-DEFAULT*
   *DEFAULT-UPDATE-OBJECTS-MAX-LEN* 
   UPDATE-OBJECT-JOINS 
-  INSTANCE-REFRESHED
 
 
 * Incompatible 
@@ -30,7 +29,7 @@ COMMONSQL SPEC
  >> The functional sql interface 
   
     SELECT 
-      o should accept keyword arg :refresh and call INSTANCE-REFRESHED
+      o keyword arg :refresh should function as advertised 
       o should return (values result-list field-names)
       o should coerce values returned as strings to appropriate lisp type
 
index e4435083d317d54293a65aba3621921feeff2923..75abdd075b36c69d5439f5da6af4bc272616306a 100644 (file)
 
   (setf *mysql-client-info* (uffi:convert-from-cstring (mysql-get-client-info)))
 
-  (cond
-    ((eql (schar *mysql-client-info* 0) #\3)
-     (pushnew :mysql-client-v3 cl:*features*))
-    ((eql (schar *mysql-client-info* 0) #\4)
-     (pushnew :mysql-client-v4 cl:*features*)
-     (when (and (>= (length *mysql-client-info*) 3)
-               (string-equal "4.1" *mysql-client-info* :end2 3))
-       (pushnew :mysql-client-v4.1)))
-    (t
-     (error "Unknown mysql client version '~A'." *mysql-client-info*)))
-
-  )
+  (when (and (stringp *mysql-client-info*)
+            (plusp (length *mysql-client-info*)))
+    (cond
+      ((eql (schar *mysql-client-info* 0) #\3)
+       (pushnew :mysql-client-v3 cl:*features*))
+      ((eql (schar *mysql-client-info* 0) #\4)
+       (pushnew :mysql-client-v4 cl:*features*)
+       (when (and (>= (length *mysql-client-info*) 3)
+                 (string-equal "4.1" *mysql-client-info* :end2 3))
+        (pushnew :mysql-client-v4.1 cl:*features*)))
+      (t
+       (error "Unknown mysql client version '~A'." *mysql-client-info*)))))
 
index e5c1e712ee49842f20a15aed2beb64d4a5a78aa6..adbb0d662fe329bceb749b58d7062a4a64f37ae5 100644 (file)
@@ -1,3 +1,9 @@
+cl-sql (2.9.6-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Fri, 30 Apr 2004 17:07:03 -0600
+
 cl-sql (2.9.5-1) unstable; urgency=low
 
   * New upstream
index a8de765681f9521c8f8b5e0329c23ca1903f3440..d1b642aecf2202ebcf595302c926b082b5caa393 100644 (file)
 
 (in-package #:clsql-sys)
 
+(defgeneric update-record-from-slot (object slot &key database)
+  (:documentation
+   "The generic function UPDATE-RECORD-FROM-SLOT updates an individual
+data item in the column represented by SLOT. The DATABASE is only used
+if OBJECT is not yet associated with any database, in which case a
+record is created in DATABASE. Only SLOT is initialized in this case;
+other columns in the underlying database receive default values. The
+argument SLOT is the CLOS slot name; the corresponding column names
+are derived from the View Class definition."))
+
+(defgeneric update-record-from-slots (object slots &key database)
+  (:documentation 
+   "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the
+columns represented by SLOTS. The DATABASE is only used if OBJECT is
+not yet associated with any database, in which case a record is
+created in DATABASE. Only slots are initialized in this case; other
+columns in the underlying database receive default values. The
+argument SLOTS contains the CLOS slot names; the corresponding column
+names are derived from the view class definition."))
+
+(defgeneric update-records-from-instance (object &key database)
+  (:documentation
+   "Using an instance of a view class, OBJECT, update the database
+table that stores its instance data. If OBJECT is already associated
+with a database, that database is used, and DATABASE is ignored. If
+OBJECT is not yet associated with a database, a record is created for
+instance in the appropriate table of DATABASE and the instance becomes
+associated with that database."))
+
+(defgeneric delete-instance-records (instance)
+  (:documentation
+   "Deletes the records represented by INSTANCE from the database
+associated with it. If INSTANCE has no associated database, an error
+is signalled."))
+
+(defgeneric update-instance-from-records (instance &key database)
+  (:documentation
+   "The generic function UPDATE-INSTANCE-FROM-RECORDS updates the
+values in the slots of the View Class instance INSTANCE using the data
+in the database DATABASE which defaults to the DATABASE that instance
+is associated with, or the value of *DEFAULT-DATABASE*. If INSTANCE is
+associated with a database, then DATABASE must be that same
+database. The update is not recursive on joins. Join slots (that is,
+slots with :db-kind :join ) are updated, but the joined objects are
+not updated."))
+
+(defgeneric update-slot-from-record (instance slot &key database)
+  (:documentation
+   "Updates the value in the slot SLOT of the View Class instance
+INSTANCE using the data in the database DATABASE which defaults to the
+database that INSTANCE is associated with, or the value of
+*DEFAULT-DATABASE*. The argument SLOT is the CLOS slot name, the
+corresponding column names are derived from the View Class
+definition. The update is not recursive on joins. Join slots (that is,
+slots with :db-kind :join) are updated, but the joined objects are not
+updated."))
+
+(defgeneric instance-refreshed (instance) 
+  (:documentation 
+   "The function INSTANCE-REFRESHED is called inside SELECT when its
+REFRESH argument is true and the instance INSTANCE has just been
+updated. The supplied method on STANDARD-DB-OBJECT does nothing. If
+your application needs to take action when a View Class instance has
+been updated by (select ... :refresh t) then add an INSTANCE-REFRESH
+method specializing on your subclass of STANDARD-DB-OBJECT."))
+
+(defgeneric database-null-value (type)
+  (:documentation 
+   "Return an expression of type TYPE which SQL NULL values will be
+converted into."))
+
+(defgeneric update-slot-with-null (instance slotname slotdef)
+  (:documentation "Called to update a slot when its column has a NULL
+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."))
+
 (defgeneric output-sql (expr database)
   )
 
   )
 (defgeneric read-sql-value  (val type database)
   )
-(defgeneric postinitialize  (object)
-  )
 (defgeneric add-to-relation  (target slot-name value)
   )
 (defgeneric remove-from-relation  (target slot-name value)
index d8181d1fb763b6ae6034cd4a3d7c4a6dc631a4bb..0ea28e93c244ab4054404a392a8ca79bac80c916 100644 (file)
       #+nil (created-object object)
       (update-records-from-instance object))))
 
-(defun sequence-from-class (view-class-name)
-  (sql-escape
-   (concatenate
-    'string
-    (symbol-name (view-table (find-class view-class-name)))
-    "-SEQ")))
-
-(defun create-sequence-from-class (view-class-name
-                                   &key (database *default-database*))
-  (create-sequence (sequence-from-class view-class-name) :database database))
-
-(defun drop-sequence-from-class (view-class-name
-                                 &key (if-does-not-exist :error)
-                                 (database *default-database*))
-  (drop-sequence (sequence-from-class view-class-name)
-                 :if-does-not-exist if-does-not-exist
-                 :database database))
-
 ;;
 ;; Build the database tables required to store the given view class
 ;;
 
-(defmethod database-pkey-constraint ((class standard-db-class) database)
-  (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
-    (when keylist 
-      (convert-to-db-default-case
-       (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
-              (database-output-sql (view-table class) database)
-              (database-output-sql keylist database))
-       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
@@ -111,6 +83,28 @@ the view. The argument DATABASE has a default value of
   (push self (database-view-classes database))
   t)
 
+(defmethod database-pkey-constraint ((class standard-db-class) database)
+  (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
+    (when keylist 
+      (convert-to-db-default-case
+       (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
+              (database-output-sql (view-table class) database)
+              (database-output-sql keylist database))
+       database))))
+
+(defmethod database-generate-column-definition (class slotdef database)
+  (declare (ignore database class))
+  (when (member (view-class-slot-db-kind slotdef) '(:base :key))
+    (let ((cdef
+           (list (sql-expression :attribute (view-class-slot-column slotdef))
+                 (slot-type slotdef))))
+      (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
+      (let ((const (view-class-slot-db-constraints slotdef)))
+        (when const 
+          (setq cdef (append cdef (list const)))))
+      cdef)))
+
+
 ;;
 ;; Drop the tables which store the given view class
 ;;
@@ -227,22 +221,6 @@ superclass of the newly-defined View Class."
        sels
         (error "No slots of type :base in view-class ~A" (class-name vclass)))))
 
-;;
-;; Used by 'create-view-from-class'
-;;
-
-
-(defmethod database-generate-column-definition (class slotdef database)
-  (declare (ignore database class))
-  (when (member (view-class-slot-db-kind slotdef) '(:base :key))
-    (let ((cdef
-           (list (sql-expression :attribute (view-class-slot-column slotdef))
-                 (slot-type slotdef))))
-      (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
-      (let ((const (view-class-slot-db-constraints slotdef)))
-        (when const 
-          (setq cdef (append cdef (list const)))))
-      cdef)))
 
 ;;
 ;; Called by 'get-slot-values-from-view'
@@ -328,51 +306,35 @@ superclass of the newly-defined View Class."
       (mapc #'update-slot slotdeflist values)
       obj))
 
-(defgeneric update-record-from-slot (object slot &key database)
-  (:documentation
-   "The generic function UPDATE-RECORD-FROM-SLOT updates an individual
-data item in the column represented by SLOT. The DATABASE is only used
-if OBJECT is not yet associated with any database, in which case a
-record is created in DATABASE. Only SLOT is initialized in this case;
-other columns in the underlying database receive default values. The
-argument SLOT is the CLOS slot name; the corresponding column names
-are derived from the View Class definition."))
-   
 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
-                                       (database *default-database*))
-  (let* ((vct (view-table (class-of obj)))
+                                   (database *default-database*))
+  (let* ((database (or (view-database obj) database))
+        (vct (view-table (class-of obj)))
          (sd (slotdef-for-slot-with-class slot (class-of obj))))
     (check-slot-type sd (slot-value obj slot))
     (let* ((att (view-class-slot-column sd))
            (val (db-value-from-slot sd (slot-value obj slot) database)))
       (cond ((and vct sd (view-database obj))
              (update-records (sql-expression :table vct)
-                             :attributes (list (sql-expression
-                                                :attribute att))
+                             :attributes (list (sql-expression :attribute att))
                              :values (list val)
                              :where (key-qualifier-for-instance
                                      obj :database database)
-                             :database (view-database obj)))
+                             :database database))
             ((and vct sd (not (view-database obj)))
-             (warn "Ignoring (install-instance obj :database database))")
-            t)
+            (insert-records :into (sql-expression :table vct)
+                             :attributes (list (sql-expression :attribute att))
+                             :values (list val)
+                            :database database)
+            (setf (slot-value obj 'view-database) database))
             (t
              (error "Unable to update record.")))))
-  t)
-
-(defgeneric update-record-from-slots (object slots &key database)
-  (:documentation 
-   "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the
-columns represented by SLOTS. The DATABASE is only used if OBJECT is
-not yet associated with any database, in which case a record is
-created in DATABASE. Only slots are initialized in this case; other
-columns in the underlying database receive default values. The
-argument SLOTS contains the CLOS slot names; the corresponding column
-names are derived from the view class definition."))
+  (values))
 
 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
                                      (database *default-database*))
-  (let* ((vct (view-table (class-of obj)))
+  (let* ((database (or (view-database obj) database))
+        (vct (view-table (class-of obj)))
          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
          (avps (mapcar #'(lambda (s)
                            (let ((val (slot-value
@@ -387,7 +349,7 @@ names are derived from the view class definition."))
                            :av-pairs avps
                            :where (key-qualifier-for-instance
                                    obj :database database)
-                           :database (view-database obj)))
+                           :database database))
           ((and avps (not (view-database obj)))
            (insert-records :into (sql-expression :table vct)
                            :av-pairs avps
@@ -397,65 +359,45 @@ names are derived from the view class definition."))
            (error "Unable to update records"))))
   (values))
 
-(defgeneric update-records-from-instance (object &key database)
-  (:documentation
-   "Using an instance of a view class, update the database table that
-stores its instance data. If the instance is already associated with a
-database, that database is used, and database is ignored. If instance
-is not yet associated with a database, a record is created for
-instance in the appropriate table of database and the instance becomes
-associated with that database."))
-
 (defmethod update-records-from-instance ((obj standard-db-object)
                                          &key (database *default-database*))
-  (labels ((slot-storedp (slot)
-            (and (member (view-class-slot-db-kind slot) '(:base :key))
-                 (slot-boundp obj (slot-definition-name slot))))
-          (slot-value-list (slot)
-            (let ((value (slot-value obj (slot-definition-name slot))))
-              (check-slot-type slot value)
-              (list (sql-expression :attribute (view-class-slot-column slot))
-                    (db-value-from-slot slot value database)))))
-    (let* ((view-class (class-of obj))
-          (view-class-table (view-table view-class))
-          (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))
-          (record-values (mapcar #'slot-value-list slots)))
-      (unless record-values
-        (error "No settable slots."))
-      (if (view-database obj)
-          (update-records (sql-expression :table view-class-table)
-                          :av-pairs record-values
-                          :where (key-qualifier-for-instance
-                                  obj :database database)
-                          :database (view-database obj))
-          (progn
-            (insert-records :into (sql-expression :table view-class-table)
-                            :av-pairs record-values
-                            :database database)
-            (setf (slot-value obj 'view-database) database)))
-      (values))))
-
-(defgeneric delete-instance-records (instance)
-  (:documentation
-   "Deletes the records represented by INSTANCE from the database
-associated with it. If instance has no associated database, an error
-is signalled."))
+  (let ((database (or (view-database obj) database)))
+    (labels ((slot-storedp (slot)
+              (and (member (view-class-slot-db-kind slot) '(:base :key))
+                   (slot-boundp obj (slot-definition-name slot))))
+            (slot-value-list (slot)
+              (let ((value (slot-value obj (slot-definition-name slot))))
+                (check-slot-type slot value)
+                (list (sql-expression :attribute (view-class-slot-column slot))
+                      (db-value-from-slot slot value database)))))
+      (let* ((view-class (class-of obj))
+            (view-class-table (view-table view-class))
+            (slots (remove-if-not #'slot-storedp 
+                                  (ordered-class-slots view-class)))
+            (record-values (mapcar #'slot-value-list slots)))
+       (unless record-values
+         (error "No settable slots."))
+       (if (view-database obj)
+           (update-records (sql-expression :table view-class-table)
+                           :av-pairs record-values
+                           :where (key-qualifier-for-instance
+                                   obj :database database)
+                           :database database)
+           (progn
+             (insert-records :into (sql-expression :table view-class-table)
+                             :av-pairs record-values
+                             :database database)
+             (setf (slot-value obj 'view-database) database))))))
+  (values))
 
 (defmethod delete-instance-records ((instance standard-db-object))
   (let ((vt (sql-expression :table (view-table (class-of instance))))
-       (vd (or (view-database instance) *default-database*)))
-    (when vd
-      (let ((qualifier (key-qualifier-for-instance instance :database vd)))
-       (delete-records :from vt :where qualifier :database vd)
-       (setf (slot-value instance 'view-database) nil))))
-  #+ignore (odcl::deleted-object object))
-
-(defgeneric update-instance-from-records (instance &key database)
-  (:documentation
-   "Updates the values in the slots of the View Class instance
-INSTANCE using the data in the database DATABASE which defaults to the
-database that INSTANCE is associated with, or the value of
-*DEFAULT-DATABASE*."))
+       (vd (view-database instance)))
+    (if vd
+       (let ((qualifier (key-qualifier-for-instance instance :database vd)))
+         (delete-records :from vt :where qualifier :database vd)
+         (setf (slot-value instance 'view-database) nil))
+       (error 'clsql-no-database-error nil))))
 
 (defmethod update-instance-from-records ((instance standard-db-object)
                                          &key (database *default-database*))
@@ -470,13 +412,6 @@ database that INSTANCE is associated with, or the value of
     (when res
       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 
-(defgeneric update-slot-from-record (instance slot &key database)
-  (:documentation
-   "Updates the value in the slot SLOT of the View Class instance
-INSTANCE using the data in the database DATABASE which defaults to the
-database that INSTANCE is associated with, or the value of
-*DEFAULT-DATABASE*."))
-
 (defmethod update-slot-from-record ((instance standard-db-object)
                                     slot &key (database *default-database*))
   (let* ((view-class (find-class (class-name (class-of instance))))
@@ -486,13 +421,10 @@ database that INSTANCE is associated with, or the value of
          (slot-def (slotdef-for-slot-with-class slot view-class))
          (att-ref (generate-attribute-reference view-class slot-def))
          (res (select att-ref :from  view-table :where view-qual)))
-    (get-slot-values-from-view instance (list slot-def) (car res))))
+    (when res 
+      (get-slot-values-from-view instance (list slot-def) (car res)))))
 
 
-(defgeneric database-null-value (type)
-  (:documentation "Return an expression of type TYPE which SQL NULL values
-will be converted into."))
-
 (defmethod database-null-value ((type t))
   (cond
     ((subtypep type 'string) nil)
@@ -508,12 +440,6 @@ will be converted into."))
     (t
      (error "Unable to handle null for type ~A" type))))
 
-(defgeneric update-slot-with-null (instance slotname slotdef)
-  (:documentation "Called to update a slot when its column has a NULL
-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 ((object standard-db-object)
                                  slotname
                                  slotdef)
@@ -810,76 +736,78 @@ DATABASE-NULL-VALUE on the type of the slot."))
                 (apply #'sql-and jc)
                 jc))))))
 
-(defmethod postinitialize ((self t))
-  )
-
 (defun find-all (view-classes &rest args &key all set-operation distinct from
                  where group-by having order-by order-by-descending offset limit
-                 (database *default-database*))
+                refresh (database *default-database*))
   "tweeze me apart someone pleeze"
-  (declare (ignore all set-operation group-by having
-                   offset limit)
+  (declare (ignore all set-operation group-by having offset limit)
            (optimize (debug 3) (speed 1)))
-  ;; (cmsg "Args = ~s" args)
   (remf args :from)
-  (let* ((*db-deserializing* t)
-         (*default-database* (or database
-                                 (error 'clsql-no-database-error nil))))
-    (flet ((table-sql-expr (table)
-             (sql-expression :table (view-table table)))
-           (ref-equal (ref1 ref2)
-             (equal (sql ref1)
-                    (sql ref2)))
-           (tables-equal (table-a table-b)
-             (string= (string (slot-value table-a 'name))
-                      (string (slot-value table-b 'name)))))
-
-      (let* ((sclasses (mapcar #'find-class view-classes))
-             (sels (mapcar #'generate-selection-list sclasses))
-             (fullsels (apply #'append sels))
-             (sel-tables (collect-table-refs where))
-             (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses) sel-tables)
-                                        :test #'tables-equal))
-             (res nil))
+  (labels ((table-sql-expr (table)
+            (sql-expression :table (view-table table)))
+          (ref-equal (ref1 ref2)
+            (equal (sql ref1)
+                   (sql ref2)))
+          (tables-equal (table-a table-b)
+            (string= (string (slot-value table-a 'name))
+                     (string (slot-value table-b 'name))))
+          (build-object (vals vclass selects)
+            (let* ((class-name (class-name vclass))
+                   (db-vals (butlast vals (- (list-length vals)
+                                             (list-length selects))))
+                   (*db-initializing* t)
+                   (obj (make-instance class-name :view-database database)))
+              ;; use refresh keyword here 
+              (setf obj (get-slot-values-from-view obj (mapcar #'car selects) 
+                                                   db-vals))
+              (when refresh (instance-refreshed obj))
+              obj))
+          (build-objects (vals sclasses sels)
+            (let ((objects (mapcar #'(lambda (sclass sel) 
+                                       (build-object vals sclass sel))
+                                   sclasses sels)))
+              (if (= (length sclasses) 1)
+                  (car objects)
+                  objects))))
+    (let* ((*db-deserializing* t)
+          (*default-database* (or database
+                                  (error 'clsql-no-database-error nil)))
+          (sclasses (mapcar #'find-class view-classes))
+          (sels (mapcar #'generate-selection-list sclasses))
+          (fullsels (apply #'append sels))
+          (sel-tables (collect-table-refs where))
+          (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
+                                             sel-tables)
+                                     :test #'tables-equal))
+          (res nil))
         (dolist (ob (listify order-by))
           (when (and ob (not (member ob (mapcar #'cdr fullsels)
                                      :test #'ref-equal)))
-            (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att))
-                                                    (listify ob))))))
+            (setq fullsels 
+                 (append fullsels (mapcar #'(lambda (att) (cons nil att))
+                                          (listify ob))))))
         (dolist (ob (listify order-by-descending))
           (when (and ob (not (member ob (mapcar #'cdr fullsels)
                                      :test #'ref-equal)))
-            (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att))
-                                                    (listify ob))))))
+            (setq fullsels 
+                 (append fullsels (mapcar #'(lambda (att) (cons nil att))
+                                          (listify ob))))))
         (dolist (ob (listify distinct))
-          (when (and (typep ob 'sql-ident) (not (member ob (mapcar #'cdr fullsels)
-                                                        :test #'ref-equal)))
-            (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att))
-                                                    (listify ob))))))
-        ;; (cmsg  "Tables = ~s" tables)
-        ;; (cmsg  "From = ~s" from)
-        (setq res (apply #'select (append (mapcar #'cdr fullsels)
-                                          (cons :from (list (append (when from (listify from)) (listify tables)))) args)))
-        (flet ((build-object (vals)
-                 (flet ((%build-object (vclass selects)
-                          (let ((class-name (class-name vclass))
-                                (db-vals    (butlast vals (- (list-length vals)
-                                                             (list-length selects)))))
-                            ;; (setf vals (nthcdr (list-length selects) vals))
-                            (%make-fresh-object class-name (mapcar #'car selects) db-vals))))
-                   (let ((objects (mapcar #'%build-object sclasses sels)))
-                     (if (= (length sclasses) 1)
-                         (car objects)
-                         objects)))))
-          (mapcar #'build-object res))))))
-
-(defun %make-fresh-object (class-name slots values)
-  (let* ((*db-initializing* t)
-         (obj (make-instance class-name
-                             :view-database *default-database*)))
-    (setf obj (get-slot-values-from-view obj slots values))
-    (postinitialize obj)
-    obj))
+          (when (and (typep ob 'sql-ident) 
+                    (not (member ob (mapcar #'cdr fullsels) 
+                                 :test #'ref-equal)))
+            (setq fullsels 
+                 (append fullsels (mapcar #'(lambda (att) (cons nil att))
+                                          (listify ob))))))
+        (setq res 
+             (apply #'select 
+                    (append (mapcar #'cdr fullsels)
+                            (cons :from 
+                                  (list (append (when from (listify from)) 
+                                                (listify tables)))) args)))
+       (mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
+
+(defmethod instance-refreshed ((instance standard-db-object)))
 
 (defun select (&rest select-all-args)
   "Selects data from database given the constraints specified. Returns
@@ -897,7 +825,6 @@ 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)))
index 52a203854bd16809231fe00d9c6cdcb6dc492a7a..c9cce9ba8a53d83306bce108485ec13aad1bf5cf 100644 (file)
        #: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
+       #:*default-database-type*          ; database   xx
+       #:*default-database*               ; database   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   xx
+       #:find-database                    ; database   xx
+       #:status                           ; database   xx
        #:with-database
        #:with-default-database
        #:create-database
        
        ;; recording.lisp -- SQL I/O Recording 
        #:record-sql-action
-       #:add-sql-stream                 ; recording  xx
-       #:delete-sql-stream               ; recording  xx
-       #:list-sql-streams                ; recording  xx
-       #:sql-recording-p                 ; recording  xx
-       #:sql-stream                      ; recording  xx
-       #:start-sql-recording             ; recording  xx
-       #:stop-sql-recording              ; recording  xx
+       #:add-sql-stream                   ; recording  xx
+       #:delete-sql-stream                ; recording  xx
+       #:list-sql-streams                 ; recording  xx
+       #:sql-recording-p                  ; recording  xx
+       #:sql-stream                       ; recording  xx
+       #:start-sql-recording              ; recording  xx
+       #:stop-sql-recording               ; recording  xx
        
        ;; Transactions
        #:with-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
+       #: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
        #:select                            ; objects    xx
        #:cache-table-queries               ; 
        #:*cache-table-queries-default*     ; 
-       #:delete-records                    ; sql              xx
+       #:delete-records                    ; sql        xx
        #:insert-records                    ; sql        xx
-       #:update-records                    ; sql              xx
-       #:execute-command                         ; sql        xx
+       #:update-records                    ; sql        xx
+       #:execute-command                   ; sql        xx
        #:query                             ; sql        xx
-       #:print-query                     ; sql        xx
-       #:do-query                        ; sql        xx
-       #:map-query                       ; sql        xx
-       #:loop                            ; loop-ext   x
+       #:print-query                       ; sql        xx
+       #:do-query                          ; sql        xx
+       #:map-query                         ; sql        xx
+       #:loop                              ; loop-ext   x
        ;;FDDL
-       #:create-table                    ; table      xx
-       #:drop-table                      ; table      xx
-       #:list-tables                     ; table      xx
+       #:create-table                      ; table      xx
+       #:drop-table                        ; table      xx
+       #:list-tables                       ; table      xx
        #:table-exists-p                    ; table      xx 
-       #:list-attributes                         ; table      xx
+       #:list-attributes                   ; table      xx
        #:attribute-type                    ; table      xx
        #:list-attribute-types              ; table      xx
-       #:create-view                     ; table      xx
-       #:drop-view                       ; table      xx
-       #:create-index                    ; table      xx               
-       #:drop-index                      ; table      xx               
+       #:create-view                       ; table      xx
+       #:drop-view                         ; table      xx
+       #:create-index                      ; table      xx             
+       #:drop-index                        ; table      xx             
        #:truncate-database
        ;;OODDL
-       #:standard-db-object              ; objects    xx
+       #:standard-db-object                ; objects    xx
        #:def-view-class                    ; objects    xx
        #:create-view-from-class            ; objects    xx
-       #:drop-view-from-class            ; objects    xx
+       #:drop-view-from-class              ; objects    xx
        ;;OODML
-       #:instance-refreshed                ;
+       #:instance-refreshed                ; objects    xx 
        #:update-object-joins               ;
        #:*default-update-objects-max-len*  ; 
        #:update-slot-from-record           ; objects    xx
        #:update-instance-from-records      ; objects    xx
-       #:update-records-from-instance    ; objects    xx
-       #:update-record-from-slot                 ; objects    xx
-       #:update-record-from-slots        ; objects    xx
-       #:list-classes                    ; objects    xx
-       #:delete-instance-records                 ; objects    xx
+       #:update-records-from-instance      ; objects    xx
+       #:update-record-from-slot           ; objects    xx
+       #:update-record-from-slots          ; objects    xx
+       #:list-classes                      ; objects    xx
+       #:delete-instance-records           ; objects    xx
        ;;Symbolic SQL Syntax 
-       #:sql                             ; syntax     xx
+       #:sql                               ; syntax     xx
        #:sql-expression                    ; syntax     xx
        #:sql-operation                     ; syntax     xx
-       #:sql-operator                    ; syntax     xx       
+       #:sql-operator                      ; syntax     xx     
        #:disable-sql-reader-syntax         ; syntax     xx
        #:enable-sql-reader-syntax          ; syntax     xx
        #:locally-disable-sql-reader-syntax ; syntax     xx
        #:set-sequence-position             ; table      xx
        ;;OODDL
        #:view-table                        ; metaclass  x
-       #:create-sequence-from-class        ; objects    x
-       #:drop-sequence-from-class          ; objects    x      
        ;;OODML
        #:add-to-relation                   ; objects    x
        #:remove-from-relation              ; objects    x
index c322666eb2932fdf6c1dde4cde3d47e6e7fd7bd4..3b575df849f486719cca25a89a185e6474a8bee4 100644 (file)
@@ -33,7 +33,7 @@
   (query (sql-output expr database) :database database :flatp flatp
          :result-types result-types))
 
-(defun truncate-database (&key database)
+(defun truncate-database (&key (database *default-database*))
   (unless (typep database 'database)
     (clsql-base-sys::signal-no-database-error database))
   (unless (is-database-open database)