X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/12dcf3d4b06fd83b8c62c01a93dc26f94dc922ee..8e6e6b5651e88009c62f5502b4fabdf2919e0b4f:/src/mewa/mewa.lisp?ds=inline diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp index 16a08e5..f8dad21 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*)) @@ -65,6 +65,9 @@ attributes is an alist keyed on the attribute nreeame." (defmethod find-class-attributes ((model symbol)) (find-or-create-attributes model)) +(defmethod clear-class-attributes ((model t)) + (setf (cdr (find-class-attributes model)) nil)) + (defmethod add-attribute ((model t) name def) (let ((map (find-class-attributes model))) (setf (cdr map) (acons name def (cdr map))))) @@ -90,6 +93,20 @@ attributes is an alist keyed on the attribute nreeame." (cddr (find-attribute model name)))) definition))) +(defmethod perform-set-attributes ((model t) definitions) + (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 + (setf (cddr a) (plist-nunion properties (cddr a))) + (error "Attribute ~A does not exist" attribute) ))) + +(defmethod perform-set-attribute-properties ((model t) definitions) + (dolist (def definitions) + (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" @@ -110,6 +127,8 @@ 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))) (default-attributes model))) @@ -121,7 +140,6 @@ attributes is an alist keyed on the attribute nreeame." - (defcomponent mewa () ((attributes :initarg :attributes @@ -144,7 +162,7 @@ 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))) @@ -219,7 +237,7 @@ attributes is an alist keyed on the attribute nreeame." (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))))) + (append (cddr s) (list :parent self :size 30))))) (find-applicable-attributes self))) @@ -262,6 +280,14 @@ 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)))) + + + @@ -277,29 +303,37 @@ attributes is an alist keyed on the attribute nreeame." (defmacro call-presentation (object &rest args) `(present-object ,object :presentation (make-presentation ,object ,@args))) + +(defcomponent about-dialog (option-dialog) + ((body :initarg :body))) + +(defmethod render-on ((res response) (self about-dialog)) + (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)) + (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)) - - -(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) + (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))))) - (case (call 'option-dialog + (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) :message message :options '((:save . "Save changes to Database") (:cancel . "Cancel all changes"))) @@ -308,7 +342,11 @@ attributes is an alist keyed on the attribute nreeame." (:save (save-instance self)))))) - +(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)) (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance) (let* ((old (prog1 @@ -319,7 +357,23 @@ attributes is an alist keyed on the attribute nreeame." (unless (equal new old ) (let ((self (ucw::parent slot))) (setf (modifiedp self) instance - (modifications self) (append (list (type-of new) (type-of old) (type-of value) slot 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 :one-line) + '(mewa::mewa-one-line-presentation) + (find-attribute t :listing) + '(mewa::mewa-list-presentation :global-properties (:editablep nil) :editablep t) + (find-attribute t :search-presentation) + '(mewa-object-presentation)) + + + ;; This software is Copyright (c) Drew Crampsie, 2004-2005.