[clinton/lisp-on-lines.git] / 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 (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 'instance) object)
		   (initialize-slots p) 
		   (assoc type (find-all-attributes p))))
	 
	 (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
    (setf (slot-value i 'instance) object)
    i))

(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)
		   (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))))
  
(defmethod call-component :before ((from standard-component) (to mewa))
  (unless (slot-value to 'initializedp)
    (initialize-slots to))
  (setf (slot-value to 'initializedp) t)
  (setf (slots to) (mapcar #'(lambda (x) (prog2 
					     (setf (component.place x) (component.place from))
					     x))
                            (slots 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))
  (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)))))))

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