src/mewa/mewa.lisp

(in-package :mewa)

(defparameter *default-type* :ucw)

;;; maps meta-model slot-types to slot-presentation
(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.
(defvar *attribute-map* (list))

;;; some utilities for merging plists

(defun plist-nunion (new-props plist)
  (loop for cons on new-props by #'cddr
	do (setf (getf plist (first cons)) (second cons))
	finally (return plist)))

(defun plist-union (new-props plist)
  "Non-destructive version of plist-nunion"
		   (plist-nunion new-props (copy-list plist)))

(defun gen-ptype (type)
  (or (getf *slot-type-map* type) type))

(defun gen-presentation-slots (instance)
  (mapcar #'(lambda (x) (gen-pslot (cadr x)
				   (string (car x))
				   (car x)))
	  (meta-model:list-slot-types instance)))


(defun gen-pslot (type label slot-name)
  (copy-list `(,(gen-ptype type)
	       :label ,label
	       :slot-name ,slot-name)))

(defun gen-presentation-args (instance args)
  (declare (ignore instance))
  (if args args nil))


(defun find-or-create-attributes (class-name)
  "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 name."
  (or (assoc class-name *attribute-map*)
      (progn
	(setf *attribute-map* (acons class-name (list (list)) *attribute-map*))
	(assoc class-name *attribute-map*))))

(defgeneric find-class-attributes (class))

(defmethod find-class-attributes ((model t))
  (find-or-create-attributes (class-name (class-of model))))

(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)))))

(defmethod find-attribute ((model t) name)
  (assoc name (cdr (find-class-attributes model))))

(defmethod (setf find-attribute) ((def list) (model t) name)
  (let ((attr (find-attribute model name)))
    (if attr
	(prog2
	    (setf (cdr attr) def)
	    attr)
        (prog2
	    (add-attribute model name def)
	    (find-attribute model name)))))

(defmethod set-attribute ((model t) name definition &key (inherit t))
  (setf (find-attribute model name)
	(if inherit
	    (cons (car definition)
		  (plist-union (cdr definition)
			 (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"
  (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))
  "Set the default attributes for MODEL"
  (clear-class-attributes model)
  (mapcar #'(lambda (x)
	      (setf (find-attribute model (car x)) (cdr x)))
	  (default-attributes model)))


(defgeneric attributes-getter (model))

;;;presentations


(defcomponent mewa ()
  ((ucw::instance :accessor instance :initarg :instance)
   (attributes
    :initarg :attributes
    :accessor attributes
    :initform nil)
   (attributes-getter
    :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
    :initform nil)
   (classes
    :initarg :classes
    :accessor classes
    :initform nil)
   (use-instance-class-p
    :initarg :use-instance-class-p
    :accessor use-instance-class-p
    :initform t)
   (initializedp :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))))

(defgeneric get-attributes (mewa))

(defmethod get-attributes ((self mewa))
  (if (instance self)
  (append (meta-model:list-slots (instance self))
	  (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)))))

(defmethod find-all-attributes ((self mewa))
  (reduce #'append
	  (mapcar #'(lambda (x)
		      (cdr (find-class-attributes x)))
		  (classes self))))

(defun make-attribute (&rest props &key type &allow-other-keys)
	(remf props :type)
	(cons (gensym) (cons type props)))


(defmethod find-applicable-attributes ((self mewa))
  (let ((all-attributes (find-all-attributes self)))
    (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
				     (when att
				       (setf (cddr att) (plist-union (global-properties self) (cddr att)))
				       att))))
    (if (attributes self)
	(remove 'nil
		(mapcar #'(lambda (x)
			    (cond
			     ;;simple casee
			     ((symbolp x)
			      (gen-att x))
			     ;;if the car is a keyword then this is an inline def
			     ((and (listp x) (keywordp (car x)))
			      (let ((att (apply #'make-attribute x)))
				(setf (cddr att)
				      (plist-union (cddr att) (global-properties self)))
				att))
			     ;; if the plist has a :type
			     ((and (listp x) (getf (cdr x) :type))
			      (let ((new (cdr (apply #'make-attribute (cdr x))))
				    (def (gen-att (car x))))
				(setf (cdr new) (plist-union (cdr new) (cddr def)))
				(cons (car def) new)))
			     ;;finally if we are just overiding the props
			     ((and (listp x) (symbolp (car x)))
			      (let ((new (cdr (apply #'make-attribute (cdr x))))
				    (def (gen-att (car x))))
				(setf (cdr new) (plist-union (cdr new) (cddr def)))
				(cons (car def) (cons (second def) (cdr new)))))

			      )
			     )

			(attributes self)))
      all-attributes))))

(defmethod find-slot-presentation-for-attribute ((self mewa) attribute)
  (let ((class-name
	 (or (gethash (if (consp (second attribute))
			  (car (second attribute))
			       (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 (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 (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))
  (let* ((p (make-instance 'mewa-object-presentation))
	 (a (progn (setf (slot-value p 'ucw::instance) object)
		   (initialize-slots p)
		   (assoc type (find-all-attributes p))))
	 ;;;; TODO: this can be cleaned up, probably CHANGE-CLASS is better here
	 (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)))))
    (setf (slot-value i 'instance) object)
    (initialize-slots i)
    (setf (slot-value i 'initializedp) t)
    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))))

(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)
  (initialize-slots-place (component.place from) to)
  to)


(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))

(defmethod instance-is-stored-p ((mewa mewa))
  (instance-is-stored-p (instance mewa)))

(defaction cancel-save-instance ((self mewa))
  (cond
    ((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 ensure-instance-sync ((self mewa))
  (when (modifiedp 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)
		  :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))
  (meta-model::sync-instance (instance self))
  (answer (instance 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)))))))

;;;; * 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
;; 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.
Commit	Line	Data
	1	(in-package :mewa)
	2
	3	(defparameter default-type :ucw)
	4
	5	;;; maps meta-model slot-types to slot-presentation
	6	(defparameter slot-type-map
	7	'(boolean ucw::mewa-boolean
	8	string ucw::mewa-string
	9	number ucw::mewa-currency
	10	integer ucw::mewa-integer
	11	currency ucw::mewa-currency
	12	))
	13
	14	;;; an alist of model-class-name . attributes
	15	;;; should really be a hash-table.
	16	(defvar attribute-map (list))
	17
	18	;;; some utilities for merging plists
	19
	20	(defun plist-nunion (new-props plist)
	21	(loop for cons on new-props by #'cddr
	22	do (setf (getf plist (first cons)) (second cons))
	23	finally (return plist)))
	24
	25	(defun plist-union (new-props plist)
	26	"Non-destructive version of plist-nunion"
	27	(plist-nunion new-props (copy-list plist)))
	28
	29	(defun gen-ptype (type)
	30	(or (getf slot-type-map type) type))
	31
	32	(defun gen-presentation-slots (instance)
	33	(mapcar #'(lambda (x) (gen-pslot (cadr x)
	34	(string (car x))
	35	(car x)))
	36	(meta-model:list-slot-types instance)))
	37
	38
	39	(defun gen-pslot (type label slot-name)
	40	(copy-list `(,(gen-ptype type)
	41	:label ,label
	42	:slot-name ,slot-name)))
	43
	44	(defun gen-presentation-args (instance args)
	45	(declare (ignore instance))
	46	(if args args nil))
	47
	48
	49	(defun find-or-create-attributes (class-name)
	50	"return an exisiting class attribute map or create one.
	51
	52	A map is a cons of class-name . attributes.
	53	attributes is an alist keyed on the attribute name."
	54	(or (assoc class-name attribute-map)
	55	(progn
	56	(setf attribute-map (acons class-name (list (list)) attribute-map))
	57	(assoc class-name attribute-map))))
	58
	59	(defgeneric find-class-attributes (class))
	60
	61	(defmethod find-class-attributes ((model t))
	62	(find-or-create-attributes (class-name (class-of model))))
	63
	64	(defmethod find-class-attributes ((model symbol))
	65	(find-or-create-attributes model))
	66
	67	(defmethod clear-class-attributes ((model t))
	68	(setf (cdr (find-class-attributes model)) nil))
	69
	70	(defmethod add-attribute ((model t) name def)
	71	(let ((map (find-class-attributes model)))
	72	(setf (cdr map) (acons name def (cdr map)))))
	73
	74	(defmethod find-attribute ((model t) name)
	75	(assoc name (cdr (find-class-attributes model))))
	76
	77	(defmethod (setf find-attribute) ((def list) (model t) name)
	78	(let ((attr (find-attribute model name)))
	79	(if attr
	80	(prog2
	81	(setf (cdr attr) def)
	82	attr)
	83	(prog2
	84	(add-attribute model name def)
	85	(find-attribute model name)))))
	86
	87	(defmethod set-attribute ((model t) name definition &key (inherit t))
	88	(setf (find-attribute model name)
	89	(if inherit
	90	(cons (car definition)
	91	(plist-union (cdr definition)
	92	(cddr (find-attribute model name))))
	93	definition)))
	94
	95	(defmethod perform-set-attributes ((model t) definitions)
	96	(dolist (def definitions)
	97	(funcall #'set-attribute model (first def) (rest def))))
	98
	99	(defmethod set-attribute-properties ((model t) attribute properties)
	100	(let ((a (find-attribute model attribute)))
	101	(if a
	102	(setf (cddr a) (plist-nunion properties (cddr a)))
	103	(error "Attribute ~A does not exist" attribute) )))
	104
	105	(defmethod perform-set-attribute-properties ((model t) definitions)
	106	(dolist (def definitions)
	107	(funcall #'set-attribute-properties model (car def) (cdr def))))
	108
	109
	110	(defmethod default-attributes ((model t))
	111	"return the default attributes for a given model using the meta-model's meta-data"
	112	(append (mapcar #'(lambda (s)
	113	(cons (car s)
	114	(gen-pslot
	115	(if (meta-model:foreign-key-p model (car s))
	116	'ucw::foreign-key
	117	(cadr s))
	118	(string (car s)) (car s))))
	119	(meta-model:list-slot-types model))
	120	(mapcar #'(lambda (s)
	121	(cons s (append (gen-pslot 'ucw::has-many (string s) s)
	122	`(:presentation
	123	(make-presentation
	124	,model
	125	:type :one-line)))))
	126	(meta-model:list-has-many model))))
	127
	128	(defmethod set-default-attributes ((model t))
	129	"Set the default attributes for MODEL"
	130	(clear-class-attributes model)
	131	(mapcar #'(lambda (x)
	132	(setf (find-attribute model (car x)) (cdr x)))
	133	(default-attributes model)))
	134
	135
	136	(defgeneric attributes-getter (model))
	137
	138	;;;presentations
	139
	140
	141
	142	(defcomponent mewa ()
	143	((ucw::instance :accessor instance :initarg :instance)
	144	(attributes
	145	:initarg :attributes
	146	:accessor attributes
	147	:initform nil)
	148	(attributes-getter
	149	:accessor attributes-getter
	150	:initform #'get-attributes
	151	:initarg :attributes-getter)
	152	(attribute-slot-map
	153	:accessor attribute-slot-map
	154	:initform nil)
	155	(global-properties
	156	:initarg :global-properties
	157	:accessor global-properties
	158	:initform nil)
	159	(classes
	160	:initarg :classes
	161	:accessor classes
	162	:initform nil)
	163	(use-instance-class-p
	164	:initarg :use-instance-class-p
	165	:accessor use-instance-class-p
	166	:initform t)
	167	(initializedp :initform nil)
	168	(modifiedp :accessor modifiedp :initform nil :initarg :modifiedp)
	169	(modifications :accessor modifications :initform nil)))
	170
	171
	172	(defmethod attributes :around ((self mewa))
	173	(let ((a (call-next-method)))
	174	(or a (funcall (attributes-getter self) self))))
	175
	176	(defgeneric get-attributes (mewa))
	177
	178	(defmethod get-attributes ((self mewa))
	179	(if (instance self)
	180	(append (meta-model:list-slots (instance self))
	181	(meta-model:list-has-many (instance self)))
	182	nil))
	183
	184	(defmethod find-instance-classes ((self mewa))
	185	(mapcar #'class-name
	186	(it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
	187
	188	(defmethod find-all-attributes ((self mewa))
	189	(reduce #'append
	190	(mapcar #'(lambda (x)
	191	(cdr (find-class-attributes x)))
	192	(classes self))))
	193
	194	(defun make-attribute (&rest props &key type &allow-other-keys)
	195	(remf props :type)
	196	(cons (gensym) (cons type props)))
	197
	198
	199	(defmethod find-applicable-attributes ((self mewa))
	200	(let ((all-attributes (find-all-attributes self)))
	201	(flet ((gen-att (x) (let ((att (assoc x all-attributes)))
	202	(when att
	203	(setf (cddr att) (plist-union (global-properties self) (cddr att)))
	204	att))))
	205	(if (attributes self)
	206	(remove 'nil
	207	(mapcar #'(lambda (x)
	208	(cond
	209	;;simple casee
	210	((symbolp x)
	211	(gen-att x))
	212	;;if the car is a keyword then this is an inline def
	213	((and (listp x) (keywordp (car x)))
	214	(let ((att (apply #'make-attribute x)))
	215	(setf (cddr att)
	216	(plist-union (cddr att) (global-properties self)))
	217	att))
	218	;; if the plist has a :type
	219	((and (listp x) (getf (cdr x) :type))
	220	(let ((new (cdr (apply #'make-attribute (cdr x))))
	221	(def (gen-att (car x))))
	222	(setf (cdr new) (plist-union (cdr new) (cddr def)))
	223	(cons (car def) new)))
	224	;;finally if we are just overiding the props
	225	((and (listp x) (symbolp (car x)))
	226	(let ((new (cdr (apply #'make-attribute (cdr x))))
	227	(def (gen-att (car x))))
	228	(setf (cdr new) (plist-union (cdr new) (cddr def)))
	229	(cons (car def) (cons (second def) (cdr new)))))
	230
	231	)
	232	)
	233
	234	(attributes self)))
	235	all-attributes))))
	236
	237	(defmethod find-slot-presentation-for-attribute ((self mewa) attribute)
	238	(let ((class-name
	239	(or (gethash (if (consp (second attribute))
	240	(car (second attribute))
	241	(second attribute))
	242	ucw::slot-type-mapping)
	243	(error "Can't find slot type for ~A" (second attribute)))))
	244
	245	(cons (first attribute) (apply #'make-instance
	246	class-name
	247	(append (cddr attribute) (list :parent self :size 30))))))
	248
	249	(defmethod find-slot-presentations ((self mewa))
	250	(mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a))
	251	(find-applicable-attributes self)))
	252
	253	(defmethod find-attribute-slot ((self mewa) (attribute symbol))
	254	(cdr (assoc attribute (attribute-slot-map self))))
	255
	256	(defmethod initialize-slots ((self mewa))
	257	(when (instance self)
	258	(when (use-instance-class-p self)
	259	(setf (classes self)
	260	(append (find-instance-classes self)
	261	(classes self))))
	262	(setf (attribute-slot-map self) (find-slot-presentations self))
	263	(setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self )))))
	264
	265	(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
	266	(let* ((p (make-instance 'mewa-object-presentation))
	267	(a (progn (setf (slot-value p 'ucw::instance) object)
	268	(initialize-slots p)
	269	(assoc type (find-all-attributes p))))
	270	;;;; TODO: this can be cleaned up, probably CHANGE-CLASS is better here
	271	(i (apply #'make-instance (or (second a)
	272	;; if we didnt find the type,
	273	;; use the symbol as a class.
	274	(if (eql (symbol-package type)
	275	(find-package 'keyword))
	276	(symbol-name type)
	277	type))
	278	(plist-union initargs (cddr a)))))
	279	(setf (slot-value i 'instance) object)
	280	(initialize-slots i)
	281	(setf (slot-value i 'initializedp) t)
	282	i))
	283
	284
	285	(defmethod initialize-slots-place ((place ucw::place) (mewa mewa))
	286	(setf (slots mewa) (mapcar #'(lambda (x)
	287	(prog1 x
	288	(setf (component.place x) place)))
	289	(slots mewa))))
	290
	291	(arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa))
	292	(unless (slot-value to 'initializedp)
	293	(initialize-slots to))
	294	(setf (slot-value to 'initializedp) t)
	295	(initialize-slots-place (component.place from) to)
	296	to)
	297
	298
	299
	300	(defmacro call-presentation (object &rest args)
	301	`(present-object ,object :presentation (make-presentation ,object ,@args)))
	302
	303
	304	(defcomponent about-dialog (option-dialog)
	305	((body :initarg :body)))
	306
	307	(defmethod render-on ((res response) (self about-dialog))
	308	(call-next-method)
	309	(render-on res (slot-value self 'body)))
	310
	311
	312	(defmethod instance-is-stored-p ((instance clsql:standard-db-object))
	313	(slot-value instance 'clsql-sys::view-database))
	314
	315	(defmethod instance-is-stored-p ((mewa mewa))
	316	(instance-is-stored-p (instance mewa)))
	317
	318	(defaction cancel-save-instance ((self mewa))
	319	(cond
	320	((instance-is-stored-p (instance self))
	321	(meta-model::update-instance-from-records (instance self))
	322	(answer self))
	323	(t (answer nil))))
	324
	325	(defaction save-instance ((self mewa))
	326	(meta-model:sync-instance (instance self))
	327	(setf (modifiedp self) nil)
	328	(answer self))
	329
	330
	331	(defaction ensure-instance-sync ((self mewa))
	332	(when (modifiedp self)
	333	(let ((message (format nil "Record has been modified, Do you wish to save the changes?")))
	334	(case (call 'about-dialog
	335	:body (make-presentation (instance self)
	336	:type :viewer)
	337	:message message
	338	:options '((:save . "Save changes to Database")
	339	(:cancel . "Cancel all changes")))
	340	(:cancel
	341	(cancel-save-instance self))
	342	(:save
	343	(save-instance self))))))
	344
	345	(defaction ok ((self mewa) &optional arg)
	346	"Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
	347	;(declare (ignore arg))
	348	(meta-model::sync-instance (instance self))
	349	(answer (instance self)))
	350
	351	(defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
	352	(let* ((old (prog1
	353	(presentation-slot-value slot instance)
	354	(call-next-method)))
	355	(new (presentation-slot-value slot instance)))
	356
	357	(unless (equal new old )
	358	(let ((self (ucw::parent slot)))
	359	(setf (modifiedp self) instance
	360	(modifications self) (append (list new old value slot instance) (modifications self)))))))
	361
	362	;;;; * Finally set up some defaults
	363
	364	(setf (find-attribute t :viewer)
	365	'(mewa-object-presentation :global-properties (:editablep nil))
	366	(find-attribute t :editor)
	367	'(mewa-object-presentation :global-properties (:editablep t))
	368	(find-attribute t :creator)
	369	'(mewa-object-presentation :global-properties (:editablep t))
	370	(find-attribute t :one-line)
	371	'(mewa-one-line-presentation)
	372	(find-attribute t :listing)
	373	'(mewa-list-presentation :global-properties (:editablep nil) :editablep t)
	374	(find-attribute t :search-model)
	375	'(mewa-object-presentation))
	376
	377
	378
	379
	380
	381	;; This software is Copyright (c) Drew Crampsie, 2004-2005.
	382	;; You are granted the rights to distribute
	383	;; and use this software as governed by the terms
	384	;; of the Lisp Lesser GNU Public License
	385	;; (http://opensource.franz.com/preamble.html),
	386	;; known as the LLGPL.