r8936: merged classic-tests into tests

[clsql.git] / sql / objects.lisp

diff --git a/sql/objects.lisp b/sql/objects.lisp
index 1991b70c151f6e9b86f2781dc7ccf29ee3fde70b..e4b0ca13c50c328d9035cc0a46899b04995ce983 100644 (file)
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -1,14 +1,17 @@
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; $Id: $
+;;;; *************************************************************************
 ;;;;
-;;;; Description ==========================================================
-;;;; ======================================================================
+;;;; $Id$
 ;;;;
 ;;;; The CLSQL Object Oriented Data Definitional Language (OODDL)
 ;;;; and Object Oriented Data Manipulation Language (OODML).
 ;;;;
-;;;; ======================================================================
+;;;; 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-sys)
 
@@ -101,9 +104,9 @@
 
 (defun ensure-schema-version-table (database)
   (unless (table-exists-p "clsql_object_v" :database database)
-    (create-table [clsql_object_v] '(([name] (string 32))
+    (create-table [clsql_object_v] '(([name] string)
                                     ([vers] integer)
-                                    ([def] (string 32)))
+                                    ([def] string))
                   :database database)))
 
 (defun update-schema-version-records (view-class-name
@@ -142,7 +145,7 @@ the view. The argument DATABASE has a default value of
   (values))
 
 (defmethod %install-class ((self standard-db-class) database &aux schemadef)
-  (dolist (slotdef (class-slots self))
+  (dolist (slotdef (ordered-class-slots self))
     (let ((res (database-generate-column-definition (class-name self)
                                                     slotdef database)))
       (when res 
@@ -259,7 +262,7 @@ superclass of the newly-defined View Class."
 
 (defun generate-selection-list (vclass)
   (let ((sels nil))
-    (dolist (slotdef (class-slots vclass))
+    (dolist (slotdef (ordered-class-slots vclass))
       (let ((res (generate-attribute-reference vclass slotdef)))
        (when res
           (push (cons slotdef res) sels))))
@@ -294,7 +297,7 @@ superclass of the newly-defined View Class."
       list))
 
 (defun slot-type (slotdef)
-  (let ((slot-type (slot-definition-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))
@@ -526,7 +529,7 @@ associated with that database."))
                     (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 (class-slots 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."))
@@ -555,7 +558,7 @@ associated with that database."))
                     (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 (class-slots 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."))
@@ -616,7 +619,7 @@ associated with that database."))
   (let* ((view-class (class-of instance))
         (joins (remove-if #'(lambda (sd)
                               (not (equal (view-class-slot-db-kind sd) :join)))
-                          (class-slots view-class))))
+                          (ordered-class-slots view-class))))
     (dolist (slot joins)
       (let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot))))
        (cond