fixes for ucw+interpreter

darcs-hash:20050822205457-5417e-33be4ebe946a8e5bbe7df391c1523545ec68aa93.gz

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index 45cf603..865f11d 100644 (file)
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -35,6 +35,8 @@
          
 (defsystem :lisp-on-lines
   :components ((:static-file "lisp-on-lines.asd")
          
 (defsystem :lisp-on-lines
   :components ((:static-file "lisp-on-lines.asd")

+              (:module :src
+                       :components ((:file "lisp-on-lines")))

               (:module :components
                :pathname "src/components/"
                 :components ((:file "range-list"))))
               (:module :components
                :pathname "src/components/"
                 :components ((:file "range-list"))))

diff --git a/src/backend/clsql.lisp b/src/backend/clsql.lisp
index 9bbea61..8d593dc 100644 (file)
--- a/src/backend/clsql.lisp
+++ b/src/backend/clsql.lisp
@@ -33,7 +33,10 @@
       (return-from sync-instance))
     (update-records-from-instance view :database database)
     (update-instance-from-records view :database database)
       (return-from sync-instance))
     (update-records-from-instance view :database database)
     (update-instance-from-records view :database database)

-    (update-objects-joins (list view))))
+    (update-objects-joins (list view)))
+
+  ;; return the modified and hopefully now persistent object
+  view)

 
 
 
 
 
 

diff --git a/src/meta-model.lisp b/src/meta-model.lisp
index 4416423..09f7f6f 100644 (file)
--- a/src/meta-model.lisp
+++ b/src/meta-model.lisp
@@ -156,14 +156,23 @@ most of the below functions expect this method to exist"
                 :test-key :target-slot
                 :return-full t)))
 
                 :test-key :target-slot
                 :return-full t)))
 

-(defmethod explode-foreign-key ((model clsql:standard-db-object) slot)
+(defmethod explode-foreign-key ((model clsql:standard-db-object) slot &key (createp t))

   "returns the clsql view-class joined on SLOT"
   (dolist (s (list-join-attributes model))
     (when (equal (getf (cdr s) :home-key) slot)
   "returns the clsql view-class joined on SLOT"
   (dolist (s (list-join-attributes model))
     (when (equal (getf (cdr s) :home-key) slot)

-      (let ((val (slot-value model (car s))))
-      (return-from explode-foreign-key 
-       (values (if val val (make-instance (getf (cdr s) :join-class))) 
-               (getf (cdr s) :foreign-key)))))))
+      (let* ((fkey (getf (cdr s) :foreign-key))
+            (new (sync-instance (make-instance (getf (cdr s) :join-class))))
+            (val (or (slot-value model (car s))
+                     (progn
+                       (when createp
+                         (setf
+                          (slot-value model slot)
+                          (slot-value new fkey))
+                         (sync-instance model)
+                         (slot-value model (car s)))))))
+           
+       (return-from explode-foreign-key 
+         (values val fkey))))))

 
 (defun find-join-helper (foreign-key)
   (lambda (class slot) 
 
 (defun find-join-helper (foreign-key)
   (lambda (class slot) 

diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp
index 4434039..785f05d 100644 (file)
--- a/src/mewa/mewa.lisp
+++ b/src/mewa/mewa.lisp
@@ -1,4 +1,3 @@
-

 (in-package :mewa)
  
 (defparameter *default-type* :ucw)
 (in-package :mewa)
  
 (defparameter *default-type* :ucw)


@@ -170,10 +169,6 @@ attributes is an alist keyed on the attribute name."
    (modifications :accessor modifications :initform nil)))
 
 
    (modifications :accessor modifications :initform nil)))
 
 

-
-
-
-

 (defmethod attributes :around ((self mewa))
   (let ((a (call-next-method)))
     (or a (funcall (attributes-getter self) self))))
 (defmethod attributes :around ((self mewa))
   (let ((a (call-next-method)))
     (or a (funcall (attributes-getter self) self))))


@@ -264,31 +259,20 @@ attributes is an alist keyed on the attribute name."
     (setf (attribute-slot-map self) (find-slot-presentations self))
     (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self )))))
   
     (setf (attribute-slot-map self) (find-slot-presentations self))
     (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self )))))
   

-
-(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
-  (let* ((p (make-instance 'mewa-object-presentation))
-        (a (progn (setf (slot-value p 'instance) object)
-                  (initialize-slots p) 
-                  (assoc type (find-all-attributes p))))
-        
-        (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
-    (setf (slot-value i 'instance) object)
-    i))
-

 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
   (let* ((p (make-instance 'mewa-object-presentation))
 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
   (let* ((p (make-instance 'mewa-object-presentation))

-        (a (progn (setf (slot-value p 'instance) object)
+        (a (progn (setf (slot-value p 'ucw::instance) object)

                   (initialize-slots p) 
                   (assoc type (find-all-attributes p))))
                   (initialize-slots p) 
                   (assoc type (find-all-attributes p))))

-        
-        (i (apply #'make-instance (or (second a)
-                                      ;; if we didnt find the type, 
-                                      ;; use the symbol as a class. 
-                                      (if (eql (symbol-package type) 
-                                               (find-package 'keyword))
-                                          (symbol-name type)
-                                          type))
-                                      (plist-union initargs (cddr a)))))
+        ;;;; TODO: this can be cleaned up, probably CHANGE-CLASS is better here
+        (i (apply #'change-class p (or (second a)
+                                     ;; if we didnt find the type, 
+                                     ;; use the symbol as a class. 
+                                     (if (eql (symbol-package type) 
+                                              (find-package 'keyword))
+                                         (symbol-name type)
+                                         type))
+                  (plist-union initargs (cddr a)))))

     (setf (slot-value i 'instance) object)
     (initialize-slots i)
     (setf (slot-value i 'initializedp) t)
     (setf (slot-value i 'instance) object)
     (initialize-slots i)
     (setf (slot-value i 'initializedp) t)


@@ -301,14 +285,14 @@ attributes is an alist keyed on the attribute name."
                                 (setf (component.place x) place)))
                             (slots mewa))))
   
                                 (setf (component.place x) place)))
                             (slots mewa))))
   

-(defmethod call-component :before ((from standard-component) (to mewa))
+(arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa))

   (unless (slot-value to 'initializedp)
     (initialize-slots to))
   (setf (slot-value to 'initializedp) t)
   (unless (slot-value to 'initializedp)
     (initialize-slots to))
   (setf (slot-value to 'initializedp) t)

-  (setf (slots to) (mapcar #'(lambda (x) (prog2 
-                                            (setf (component.place x) (component.place from))
-                                            x))
-                            (slots to))))
+  (initialize-slots-place (component.place from) to)
+  to)
+
+

 
 (defmacro call-presentation (object &rest args)
   `(present-object ,object :presentation (make-presentation ,object ,@args)))
 
 (defmacro call-presentation (object &rest args)
   `(present-object ,object :presentation (make-presentation ,object ,@args)))


@@ -357,9 +341,9 @@ attributes is an alist keyed on the attribute name."
 
 (defaction ok ((self mewa) &optional arg)
   "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
 
 (defaction ok ((self mewa) &optional arg)
   "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"

-  (declare (ignore arg))
-  (ensure-instance-sync self)
-  (answer self))
+  ;(declare (ignore arg))
+  (meta-model::sync-instance (instance self))
+  (answer (instance self)))

 
 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
   (let* ((old (prog1 
 
 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
   (let* ((old (prog1 

diff --git a/src/mewa/slot-presentations.lisp b/src/mewa/slot-presentations.lisp
index 2232ec1..4254227 100644 (file)
--- a/src/mewa/slot-presentations.lisp
+++ b/src/mewa/slot-presentations.lisp
@@ -30,8 +30,6 @@
          (<:as-html (presentation-slot-value slot instance)))))
 
 
          (<:as-html (presentation-slot-value slot instance)))))
 
 

-
-

 (defcomponent mewa-slot-presentation ()
   ((slot-name :accessor slot-name 
              :initarg :slot-name 
 (defcomponent mewa-slot-presentation ()
   ((slot-name :accessor slot-name 
              :initarg :slot-name 


@@ -42,7 +40,8 @@
                     :initform nil
                     :documentation 
                     "When nil, the instance is syncronised with the database. 
                     :initform nil
                     :documentation 
                     "When nil, the instance is syncronised with the database. 

-When T, only the default value for primary keys and the joins are updated."))
+When T, only the default value for primary keys and the joins are updated.")
+   (show-label-p :accessor show-label-p :initarg :show-label-p :initform t))

   (:documentation "The superclass of all Mewa slot presentations"))
 
 ;;;; this has to be in the eval when i would think
   (:documentation "The superclass of all Mewa slot presentations"))
 
 ;;;; this has to be in the eval when i would think

diff --git a/src/packages.lisp b/src/packages.lisp
index 596af25..0c7568e 100644 (file)
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -79,10 +79,16 @@
   (:use :mewa :meta-model :common-lisp :it.bese.ucw)
   (:nicknames :lol)
   (:export 
   (:use :mewa :meta-model :common-lisp :it.bese.ucw)
   (:nicknames :lol)
   (:export 

+   ;;;; LoL 
+   :initialize-lol-for-table
+   :initialize-lol-for-database
+
+
+

    ;;;; Mewa Exports
    :mewa ;the superclass of all mewa-presentations
    :make-presentation
    ;;;; Mewa Exports
    :mewa ;the superclass of all mewa-presentations
    :make-presentation

-
+   :call-presentation

    ;;attributes
    :attributes
    :set-default-attributes
    ;;attributes
    :attributes
    :set-default-attributes