From: Drew Crampsie Date: Mon, 25 Jul 2005 19:44:33 +0000 (-0700) Subject: major update to slot presentations X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/commitdiff_plain/569ad9e659b96d5bce12410bbc0a24710306cd3e?hp=8e6e6b5651e88009c62f5502b4fabdf2919e0b4f major update to slot presentations darcs-hash:20050725194433-5417e-833479c68c27769c84ab89c038365f19577045d5.gz --- diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp index f8dad21..c6f14a3 100644 --- a/src/mewa/mewa.lisp +++ b/src/mewa/mewa.lisp @@ -149,6 +149,9 @@ attributes is an alist keyed on the attribute name." :accessor attributes-getter :initform #'get-attributes :initarg :attributes-getter) + (attribute-slot-map + :accessor attribute-slot-map + :initform nil) (global-properties :initarg :global-properties :accessor global-properties @@ -178,7 +181,6 @@ attributes is an alist keyed on the attribute name." (meta-model:list-has-many (instance self))) nil)) - (defmethod find-instance-classes ((self mewa)) (mapcar #'class-name (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self))))) @@ -232,22 +234,29 @@ attributes is an alist keyed on the attribute name." (attributes self))) all-attributes)))) +(defmethod find-slot-presentation-for-attribute ((self mewa) attribute) + (let ((class-name + (or (gethash (second attribute) ucw::*slot-type-mapping*) + (error "Can't find slot type for ~A" (second attribute))))) + + (cons (first attribute) (apply #'make-instance + class-name + (append (cddr attribute) (list :parent self :size 30)))))) + (defmethod find-slot-presentations ((self mewa)) - (mapcar #'(lambda (s) - (let ((class-name (or (gethash (second s) ucw::*slot-type-mapping*) 'mewa-object-presentation))) - (apply #'make-instance - class-name - (append (cddr s) (list :parent self :size 30))))) + (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a)) (find-applicable-attributes self))) - +(defmethod find-attribute-slot ((self mewa) (attribute symbol)) + (cdr (assoc attribute (attribute-slot-map self)))) (defmethod initialize-slots ((self mewa)) (when (use-instance-class-p self) (setf (classes self) (append (find-instance-classes self) (classes self)))) - (setf (slots self) (find-slot-presentations 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)) @@ -286,11 +295,6 @@ attributes is an alist keyed on the attribute name." (setf (component.place x) place))) (slots mewa)))) - - - - - (defmethod call-component :before ((from standard-component) (to mewa)) (unless (slot-value to 'initializedp) (initialize-slots to)) @@ -313,7 +317,10 @@ attributes is an alist keyed on the attribute name." (defmethod instance-is-stored-p ((instance clsql:standard-db-object)) - (slot-value instance 'clsql-sys::view-database)) + (slot-value instance 'clsql-sys::view-database)) + +(defmethod instance-is-stored-p ((mewa mewa)) + (instance-is-stored-p (instance mewa))) (defaction cancel-save-instance ((self mewa)) (cond diff --git a/src/mewa/slot-presentations.lisp b/src/mewa/slot-presentations.lisp index db5de2e..4a746d3 100644 --- a/src/mewa/slot-presentations.lisp +++ b/src/mewa/slot-presentations.lisp @@ -84,7 +84,8 @@ When T, only the default value for primary keys and the joins are updated.")) (defslot-presentation mewa-relation-slot-presentation (mewa-slot-presentation slot-presentation) ((foreign-instance :accessor foreign-instance) - (linkedp :accessor linkedp :initarg :linkedp :initform t)) + (linkedp :accessor linkedp :initarg :linkedp :initform t) + (creator :accessor creator :initarg :creator :initform :editor)) (:type-name relation)) (defaction search-records ((slot mewa-relation-slot-presentation) instance) @@ -104,15 +105,28 @@ When T, only the default value for primary keys and the joins are updated.")) (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name)) (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self))))) -(defaction create-record ((slot mewa-relation-slot-presentation) instance) +(defaction create-record-on-foreign-key ((slot mewa-relation-slot-presentation) instance) (multiple-value-bindf (finstance foreign-slot-name) (meta-model:explode-foreign-key instance (slot-name slot)) (let ((new-instance (call-component (parent slot) - (mewa:make-presentation finstance :type :editor)))) + (mewa:make-presentation finstance :type (creator self))))) + + ;;;; TODO: this next bit is due to a bad design decision. + ;;;; Components should always have (ok) return self, but somewhere + ;;;; i've made in return (instance self) sometimes, and this + ;;;; bahaviour is totatlly fucked. + + (when (typep new-instance 'mewa::mewa) + (setf new-instance (instance new-instance))) + + ;;;; sorry about that, and now back t our regular program. + + (meta-model:sync-instance new-instance) (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name)) (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self))))) + (defmethod present-relation ((slot mewa-relation-slot-presentation) instance) ;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance ) @@ -143,18 +157,22 @@ When T, only the default value for primary keys and the joins are updated.")) (meta-model:sync-instance (instance (parent self)))) -(defmethod present-slot :around ((slot foreign-key-slot-presentation) instance) + +(defmethod present-slot :before ((slot foreign-key-slot-presentation) instance) + ()) + + +(defmethod present-slot :around ((slot foreign-key-slot-presentation) instance) (setf (foreign-instance slot) (when (presentation-slot-value slot instance) (meta-model:explode-foreign-key instance (slot-name slot)))) - (flet ((render () (when (foreign-instance slot)(call-next-method)))) (if (slot-boundp slot 'place) (cond ((editablep slot) (render) (