X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/19531fbd947da15a17f8e5557a1a1492eab2bca3..4e2ecf695f074d4ed79c1099fa56b1d6fce08bfb:/src/mewa/mewa.lisp diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp index 8509f2d..54ab29d 100644 --- a/src/mewa/mewa.lisp +++ b/src/mewa/mewa.lisp @@ -1,9 +1,16 @@ + (in-package :mewa) (defparameter *default-type* :ucw) ;;; maps meta-model slot-types to slot-presentation -(defparameter *slot-type-map* '(number ucw:currency)) +(defparameter *slot-type-map* + '(boolean ucw::mewa-boolean + string ucw::mewa-string + number ucw::mewa-currency + integer ucw::mewa-integer + currency ucw::mewa-currency + )) ;;; an alist of model-class-name . attributes ;;; should really be a hash-table. @@ -12,9 +19,7 @@ ;;; some utilities for merging plists (defun plist-nunion (new-props plist) - (loop for cons on new-props - for i from 1 - when (oddp i) + (loop for cons on new-props by #'cddr do (setf (getf plist (first cons)) (second cons)) finally (return plist))) @@ -29,7 +34,7 @@ (mapcar #'(lambda (x) (gen-pslot (cadr x) (string (car x)) (car x))) - (list-slot-types instance))) + (meta-model:list-slot-types instance))) (defun gen-pslot (type label slot-name) @@ -85,14 +90,26 @@ 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 default-attributes ((model t)) - (append (mapcar #'(lambda (s) (cons (car s) (gen-pslot (if (meta-model:foreign-key-p model (car s)) - 'ucw::foreign-key - (cadr s)) - (string (car s)) (car s)))) - (meta-model:list-slot-types model)) - (mapcar #'(lambda (s) (cons s (append (gen-pslot 'ucw::has-many (string s) s) `(:presentation (make-presentation ,model :type :one-line))))) + "return the default attributes for a given model using the meta-model's meta-data" + (append (mapcar #'(lambda (s) + (cons (car s) + (gen-pslot + (if (meta-model:foreign-key-p model (car s)) + 'ucw::foreign-key + (cadr s)) + (string (car s)) (car s)))) + (meta-model:list-slot-types model)) + (mapcar #'(lambda (s) + (cons s (append (gen-pslot 'ucw::has-many (string s) s) + `(:presentation + (make-presentation + ,model + :type :one-line))))) (meta-model:list-has-many model)))) (defmethod set-default-attributes ((model t)) @@ -130,7 +147,8 @@ 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) + (modifications :accessor modifications :initform nil))) (defmethod attributes :around ((self mewa)) @@ -217,13 +235,6 @@ attributes is an alist keyed on the attribute nreeame." (setf (slots self) (find-slot-presentations self))) -(defmethod render-on :around ((res response) (self mewa)) - (unless (slot-value self 'initializedp) - (initialize-slots self)) - (setf (slot-value self 'initializedp) t) - (call-next-method)) - - (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) @@ -249,6 +260,8 @@ attributes is an alist keyed on the attribute nreeame." type)) (plist-union initargs (cddr a))))) (setf (slot-value i 'instance) object) + (initialize-slots i) + (setf (slot-value i 'initializedp) t) i)) @@ -262,7 +275,71 @@ attributes is an alist keyed on the attribute nreeame." (setf (slots to) (mapcar #'(lambda (x) (prog2 (setf (component.place x) (component.place from)) x)) - (slots to)))) + (slots to)))) (defmacro call-presentation (object &rest args) - `(present-object ,object :presentation (make-presentation ,object ,@args))) \ No newline at end of file + `(present-object ,object :presentation (make-presentation ,object ,@args))) + + +(defcomponent about-dialog (option-dialog) + ((body :initarg :body))) + +(defmethod render-on ((res response) (self about-dialog)) + (render-on res (slot-value self 'body)) + (call-next-method)) + +(defaction cancel-save-instance ((self mewa)) + (cond + ((slot-value (instance self) 'clsql-sys::view-database) + (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 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 'about-dialog + :body (make-presentation (instance self) + :type :viewer) + :message message + :options '((:save . "Save changes to Database") + (:cancel . "Cancel all changes"))) + (:cancel + (cancel-save-instance self)) + (: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 + (presentation-slot-value slot instance) + (call-next-method))) + (new (presentation-slot-value slot instance))) + + (unless (equal new old ) + (let ((self (ucw::parent slot))) + (setf (modifiedp self) instance + (modifications self) (append (list new old value slot instance) (modifications self))))))) + + +;; This software is Copyright (c) Drew Crampsie, 2004-2005. +;; You 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), +;; known as the LLGPL.