X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/34e8e2d693c74ced15c3341b0dc36058a14f75c9..65792e79770b7808542f483a6e8b0af320d55704:/src/mewa/mewa.lisp diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp index 80795c8..7cdb073 100644 --- a/src/mewa/mewa.lisp +++ b/src/mewa/mewa.lisp @@ -51,7 +51,7 @@ "return an exisiting class attribute map or create one. A map is a cons of class-name . attributes. -attributes is an alist keyed on the attribute nreeame." +attributes is an alist keyed on the attribute name." (or (assoc class-name *attribute-map*) (progn (setf *attribute-map* (acons class-name (list (list)) *attribute-map*)) @@ -97,7 +97,6 @@ attributes is an alist keyed on the attribute nreeame." (dolist (def definitions) (funcall #'set-attribute model (first def) (rest def)))) - (defmethod set-attribute-properties ((model t) attribute properties) (let ((a (find-attribute model attribute))) (if a @@ -109,9 +108,6 @@ attributes is an alist keyed on the attribute nreeame." (funcall #'set-attribute-properties model (car def) (cdr def)))) - - - (defmethod default-attributes ((model t)) "return the default attributes for a given model using the meta-model's meta-data" (append (mapcar #'(lambda (s) @@ -131,6 +127,7 @@ attributes is an alist keyed on the attribute nreeame." (meta-model:list-has-many model)))) (defmethod set-default-attributes ((model t)) + "Set the default attributes for MODEL" (clear-class-attributes model) (mapcar #'(lambda (x) (setf (find-attribute model (car x)) (cdr x))) @@ -143,7 +140,6 @@ attributes is an alist keyed on the attribute nreeame." - (defcomponent mewa () ((attributes :initarg :attributes @@ -153,6 +149,9 @@ attributes is an alist keyed on the attribute nreeame." :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 @@ -166,10 +165,14 @@ attributes is an alist keyed on the attribute nreeame." :accessor use-instance-class-p :initform t) (initializedp :initform nil) - (modifiedp :accessor modifiedp :initform nil) + (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp) (modifications :accessor modifications :initform nil))) + + + + (defmethod attributes :around ((self mewa)) (let ((a (call-next-method))) (or a (funcall (attributes-getter self) self)))) @@ -182,7 +185,6 @@ attributes is an alist keyed on the attribute nreeame." (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))))) @@ -236,22 +238,30 @@ attributes is an alist keyed on the attribute nreeame." (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))))) + (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))) + (when (instance self) + (when (use-instance-class-p self) + (setf (classes self) + (append (find-instance-classes self) + (classes 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)) @@ -284,9 +294,12 @@ attributes is an alist keyed on the attribute nreeame." i)) - - - +(defmethod initialize-slots-place ((place ucw::place) (mewa mewa)) + (setf (slots mewa) (mapcar #'(lambda (x) + (prog1 x + (setf (component.place x) place))) + (slots mewa)))) + (defmethod call-component :before ((from standard-component) (to mewa)) (unless (slot-value to 'initializedp) (initialize-slots to)) @@ -304,25 +317,32 @@ attributes is an alist keyed on the attribute nreeame." ((body :initarg :body))) (defmethod render-on ((res response) (self about-dialog)) - (render-on res (slot-value self 'body)) - (call-next-method)) + (call-next-method) + (render-on res (slot-value self 'body))) + + +(defmethod instance-is-stored-p ((instance clsql:standard-db-object)) + (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 - ((slot-value (instance self) 'clsql-sys::view-database) + ((instance-is-stored-p (instance self)) (meta-model::update-instance-from-records (instance self)) (answer self)) (t (answer nil)))) (defaction save-instance ((self mewa)) (meta-model:sync-instance (instance self)) - (setf (modifiedp self) nil) - (answer self)) + (setf (modifiedp self) nil) + (answer self)) (defaction ensure-instance-sync ((self mewa)) (when (modifiedp self) - (let ((message (format nil "Record has been modified, Do you wish to save the changes?
~a" (print (modifications self))))) + (let ((message (format nil "Record has been modified, Do you wish to save the changes?"))) (case (call 'about-dialog :body (make-presentation (instance self) :type :viewer) @@ -340,10 +360,6 @@ attributes is an alist keyed on the attribute nreeame." (ensure-instance-sync self) (answer self)) - - - - (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance) (let* ((old (prog1 (presentation-slot-value slot instance) @@ -355,6 +371,24 @@ attributes is an alist keyed on the attribute nreeame." (setf (modifiedp self) instance (modifications self) (append (list new old value slot instance) (modifications self))))))) +;;;; * Finally set up some defaults + +(setf (find-attribute t :viewer) + '(mewa-object-presentation :global-properties (:editablep nil)) + (find-attribute t :editor) + '(mewa-object-presentation :global-properties (:editablep t)) + (find-attribute t :creator) + '(mewa-object-presentation :global-properties (:editablep t)) + (find-attribute t :one-line) + '(mewa-one-line-presentation) + (find-attribute t :listing) + '(mewa-list-presentation :global-properties (:editablep nil) :editablep t) + (find-attribute t :search-model) + '(mewa-object-presentation)) + + + + ;; This software is Copyright (c) Drew Crampsie, 2004-2005. ;; You are granted the rights to distribute