4 (defparameter *default-type
* :ucw
)
6 ;;; maps meta-model slot-types to slot-presentation
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
15 ;;; an alist of model-class-name . attributes
16 ;;; should really be a hash-table.
17 (defvar *attribute-map
* (list))
19 ;;; some utilities for merging plists
21 (defun plist-nunion (new-props plist
)
22 (loop for cons on new-props by
#'cddr
23 do
(setf (getf plist
(first cons
)) (second cons
))
24 finally
(return plist
)))
26 (defun plist-union (new-props plist
)
27 "Non-destructive version of plist-nunion"
28 (plist-nunion new-props
(copy-list plist
)))
30 (defun gen-ptype (type)
31 (or (getf *slot-type-map
* type
) type
))
33 (defun gen-presentation-slots (instance)
34 (mapcar #'(lambda (x) (gen-pslot (cadr x
)
37 (meta-model:list-slot-types instance
)))
40 (defun gen-pslot (type label slot-name
)
41 (copy-list `(,(gen-ptype type
)
43 :slot-name
,slot-name
)))
45 (defun gen-presentation-args (instance args
)
46 (declare (ignore instance
))
50 (defun find-or-create-attributes (class-name)
51 "return an exisiting class attribute map or create one.
53 A map is a cons of class-name . attributes.
54 attributes is an alist keyed on the attribute nreeame."
55 (or (assoc class-name
*attribute-map
*)
57 (setf *attribute-map
* (acons class-name
(list (list)) *attribute-map
*))
58 (assoc class-name
*attribute-map
*))))
60 (defgeneric find-class-attributes
(class))
62 (defmethod find-class-attributes ((model t
))
63 (find-or-create-attributes (class-name (class-of model
))))
65 (defmethod find-class-attributes ((model symbol
))
66 (find-or-create-attributes model
))
68 (defmethod clear-class-attributes ((model t
))
69 (setf (cdr (find-class-attributes model
)) nil
))
71 (defmethod add-attribute ((model t
) name def
)
72 (let ((map (find-class-attributes model
)))
73 (setf (cdr map
) (acons name def
(cdr map
)))))
75 (defmethod find-attribute ((model t
) name
)
76 (assoc name
(cdr (find-class-attributes model
))))
78 (defmethod (setf find-attribute
) ((def list
) (model t
) name
)
79 (let ((attr (find-attribute model name
)))
85 (add-attribute model name def
)
86 (find-attribute model name
)))))
88 (defmethod set-attribute ((model t
) name definition
&key
(inherit t
))
89 (setf (find-attribute model name
)
91 (cons (car definition
)
92 (plist-union (cdr definition
)
93 (cddr (find-attribute model name
))))
96 (defmethod perform-set-attributes ((model t
) definitions
)
97 (dolist (def definitions
)
98 (funcall #'set-attribute model
(first def
) (rest def
))))
101 (defmethod set-attribute-properties ((model t
) attribute properties
)
102 (let ((a (find-attribute model attribute
)))
104 (setf (cddr a
) (plist-nunion properties
(cddr a
)))
105 (error "Attribute ~A does not exist" attribute
) )))
107 (defmethod perform-set-attribute-properties ((model t
) definitions
)
108 (dolist (def definitions
)
109 (funcall #'set-attribute-properties model
(car def
) (cdr def
))))
115 (defmethod default-attributes ((model t
))
116 "return the default attributes for a given model using the meta-model's meta-data"
117 (append (mapcar #'(lambda (s)
120 (if (meta-model:foreign-key-p model
(car s
))
123 (string (car s
)) (car s
))))
124 (meta-model:list-slot-types model
))
125 (mapcar #'(lambda (s)
126 (cons s
(append (gen-pslot 'ucw
::has-many
(string s
) s
)
131 (meta-model:list-has-many model
))))
133 (defmethod set-default-attributes ((model t
))
134 (clear-class-attributes model
)
135 (mapcar #'(lambda (x)
136 (setf (find-attribute model
(car x
)) (cdr x
)))
137 (default-attributes model
)))
140 (defgeneric attributes-getter
(model))
147 (defcomponent mewa
()
153 :accessor attributes-getter
154 :initform
#'get-attributes
155 :initarg
:attributes-getter
)
157 :initarg
:global-properties
158 :accessor global-properties
164 (use-instance-class-p
165 :initarg
:use-instance-class-p
166 :accessor use-instance-class-p
168 (initializedp :initform nil
)
169 (modifiedp :accessor modifiedp
:initform nil
)
170 (modifications :accessor modifications
:initform nil
)))
173 (defmethod attributes :around
((self mewa
))
174 (let ((a (call-next-method)))
175 (or a
(funcall (attributes-getter self
) self
))))
177 (defgeneric get-attributes
(mewa))
179 (defmethod get-attributes ((self mewa
))
181 (append (meta-model:list-slots
(instance self
))
182 (meta-model:list-has-many
(instance self
)))
186 (defmethod find-instance-classes ((self mewa
))
188 (it.bese.arnesi.mopp
:compute-class-precedence-list
(class-of (instance self
)))))
190 (defmethod find-all-attributes ((self mewa
))
192 (mapcar #'(lambda (x)
193 (cdr (find-class-attributes x
)))
196 (defun make-attribute (&rest props
&key type
&allow-other-keys
)
198 (cons (gensym) (cons type props
)))
201 (defmethod find-applicable-attributes ((self mewa
))
202 (let ((all-attributes (find-all-attributes self
)))
203 (flet ((gen-att (x) (let ((att (assoc x all-attributes
)))
205 (setf (cddr att
) (plist-union (global-properties self
) (cddr att
)))
207 (if (attributes self
)
209 (mapcar #'(lambda (x)
214 ;;if the car is a keyword then this is an inline def
215 ((and (listp x
) (keywordp (car x
)))
216 (let ((att (apply #'make-attribute x
)))
218 (plist-union (cddr att
) (global-properties self
)))
220 ;; if the plist has a :type
221 ((and (listp x
) (getf (cdr x
) :type
))
222 (let ((new (cdr (apply #'make-attribute
(cdr x
))))
223 (def (gen-att (car x
))))
224 (setf (cdr new
) (plist-union (cdr new
) (cddr def
)))
225 (cons (car def
) new
)))
226 ;;finally if we are just overiding the props
227 ((and (listp x
) (symbolp (car x
)))
228 (let ((new (cdr (apply #'make-attribute
(cdr x
))))
229 (def (gen-att (car x
))))
230 (setf (cdr new
) (plist-union (cdr new
) (cddr def
)))
231 (cons (car def
) (cons (second def
) (cdr new
)))))
239 (defmethod find-slot-presentations ((self mewa
))
240 (mapcar #'(lambda (s)
241 (let ((class-name (or (gethash (second s
) ucw
::*slot-type-mapping
*) 'mewa-object-presentation
)))
242 (apply #'make-instance
244 (append (cddr s
) (list :parent self
)))))
245 (find-applicable-attributes self
)))
249 (defmethod initialize-slots ((self mewa
))
250 (when (use-instance-class-p self
)
252 (append (find-instance-classes self
)
254 (setf (slots self
) (find-slot-presentations self
)))
257 (defmethod make-presentation ((object t
) &key
(type :viewer
) (initargs nil
))
258 (let* ((p (make-instance 'mewa-object-presentation
))
259 (a (progn (setf (slot-value p
'instance
) object
)
261 (assoc type
(find-all-attributes p
))))
263 (i (apply #'make-instance
(second a
) (plist-union initargs
(cddr a
)))))
264 (setf (slot-value i
'instance
) object
)
267 (defmethod make-presentation ((object t
) &key
(type :viewer
) (initargs nil
))
268 (let* ((p (make-instance 'mewa-object-presentation
))
269 (a (progn (setf (slot-value p
'instance
) object
)
271 (assoc type
(find-all-attributes p
))))
273 (i (apply #'make-instance
(or (second a
)
274 ;; if we didnt find the type,
275 ;; use the symbol as a class.
276 (if (eql (symbol-package type
)
277 (find-package 'keyword
))
280 (plist-union initargs
(cddr a
)))))
281 (setf (slot-value i
'instance
) object
)
283 (setf (slot-value i
'initializedp
) t
)
290 (defmethod call-component :before
((from standard-component
) (to mewa
))
291 (unless (slot-value to
'initializedp
)
292 (initialize-slots to
))
293 (setf (slot-value to
'initializedp
) t
)
294 (setf (slots to
) (mapcar #'(lambda (x) (prog2
295 (setf (component.place x
) (component.place from
))
299 (defmacro call-presentation
(object &rest args
)
300 `(present-object ,object
:presentation
(make-presentation ,object
,@args
)))
303 (defcomponent about-dialog
(option-dialog)
304 ((body :initarg
:body
)))
306 (defmethod render-on ((res response
) (self about-dialog
))
307 (render-on res
(slot-value self
'body
))
310 (defaction cancel-save-instance
((self mewa
))
312 ((slot-value (instance self
) 'clsql-sys
::view-database
)
313 (meta-model::update-instance-from-records
(instance self
))
317 (defaction save-instance
((self mewa
))
318 (meta-model:sync-instance
(instance self
))
319 (setf (modifiedp self
) nil
)
323 (defaction ensure-instance-sync
((self mewa
))
324 (when (modifiedp self
)
325 (let ((message (format nil
"Record has been modified, Do you wish to save the changes?<br/> ~a" (print (modifications self
)))))
326 (case (call 'about-dialog
327 :body
(make-presentation (instance self
)
330 :options
'((:save .
"Save changes to Database")
331 (:cancel .
"Cancel all changes")))
333 (cancel-save-instance self
))
335 (save-instance self
))))))
337 (defaction ok
((self mewa
) &optional arg
)
338 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
339 (declare (ignore arg
))
340 (ensure-instance-sync self
)
347 (defmethod (setf presentation-slot-value
) :around
(value (slot slot-presentation
) instance
)
349 (presentation-slot-value slot instance
)
351 (new (presentation-slot-value slot instance
)))
353 (unless (equal new old
)
354 (let ((self (ucw::parent slot
)))
355 (setf (modifiedp self
) instance
356 (modifications self
) (append (list new old value slot instance
) (modifications self
)))))))
359 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
360 ;; You are granted the rights to distribute
361 ;; and use this software as governed by the terms
362 ;; of the Lisp Lesser GNU Public License
363 ;; (http://opensource.franz.com/preamble.html),
364 ;; known as the LLGPL.