src/mewa/mewa.lisp

(in-package :mewa)

(defparameter *default-type* :ucw)

;;; maps meta-model slot-types to slot-presentation
(defparameter *slot-type-map*
  '(boolean   mewa-boolean
    string    mewa-string
    number    mewa-currency
    integer   mewa-integer
    currency  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))
				 'foreign-key
				 (cadr s))
			     (string (car s)) (car s))))
		  (meta-model:list-slot-types model))
	  (mapcar #'(lambda (s)
		      (cons s (append (gen-pslot '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 ()
  ((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))
		      *presentation-slot-type-mapping*)
	     (error  "Can't find slot type for ~A in ~A but ~A" attribute *presentation-slot-type-mapping* (gethash 'mewa:has-very-many *presentation-slot-type-mapping*)))))

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