3 (defparameter *default-type
* :ucw
)
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
14 ;;; an alist of model-class-name . attributes
15 ;;; should really be a hash-table.
16 (defvar *attribute-map
* (list))
18 ;;; some utilities for merging plists
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
)))
25 (defun plist-union (new-props plist
)
26 "Non-destructive version of plist-nunion"
27 (plist-nunion new-props
(copy-list plist
)))
29 (defun gen-ptype (type)
30 (or (getf *slot-type-map
* type
) type
))
32 (defun gen-presentation-slots (instance)
33 (mapcar #'(lambda (x) (gen-pslot (cadr x
)
36 (meta-model:list-slot-types instance
)))
39 (defun gen-pslot (type label slot-name
)
40 (copy-list `(,(gen-ptype type
)
42 :slot-name
,slot-name
)))
44 (defun gen-presentation-args (instance args
)
45 (declare (ignore instance
))
49 (defun find-or-create-attributes (class-name)
50 "return an exisiting class attribute map or create one.
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
*)
56 (setf *attribute-map
* (acons class-name
(list (list)) *attribute-map
*))
57 (assoc class-name
*attribute-map
*))))
59 (defgeneric find-class-attributes
(class))
61 (defmethod find-class-attributes ((model t
))
62 (find-or-create-attributes (class-name (class-of model
))))
64 (defmethod find-class-attributes ((model symbol
))
65 (find-or-create-attributes model
))
67 (defmethod clear-class-attributes ((model t
))
68 (setf (cdr (find-class-attributes model
)) nil
))
70 (defmethod add-attribute ((model t
) name def
)
71 (let ((map (find-class-attributes model
)))
72 (setf (cdr map
) (acons name def
(cdr map
)))))
74 (defmethod find-attribute ((model t
) name
)
75 (assoc name
(cdr (find-class-attributes model
))))
77 (defmethod (setf find-attribute
) ((def list
) (model t
) name
)
78 (let ((attr (find-attribute model name
)))
84 (add-attribute model name def
)
85 (find-attribute model name
)))))
87 (defmethod set-attribute ((model t
) name definition
&key
(inherit t
))
88 (setf (find-attribute model name
)
90 (cons (car definition
)
91 (plist-union (cdr definition
)
92 (cddr (find-attribute model name
))))
95 (defmethod perform-set-attributes ((model t
) definitions
)
96 (dolist (def definitions
)
97 (funcall #'set-attribute model
(first def
) (rest def
))))
99 (defmethod set-attribute-properties ((model t
) attribute properties
)
100 (let ((a (find-attribute model attribute
)))
102 (setf (cddr a
) (plist-nunion properties
(cddr a
)))
103 (error "Attribute ~A does not exist" attribute
) )))
105 (defmethod perform-set-attribute-properties ((model t
) definitions
)
106 (dolist (def definitions
)
107 (funcall #'set-attribute-properties model
(car def
) (cdr def
))))
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)
115 (if (meta-model:foreign-key-p model
(car 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
)
126 (meta-model:list-has-many model
))))
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
)))
136 (defgeneric attributes-getter
(model))
142 (defcomponent mewa
()
143 ((ucw::instance
:accessor instance
:initarg
:instance
)
149 :accessor attributes-getter
150 :initform
#'get-attributes
151 :initarg
:attributes-getter
)
153 :accessor attribute-slot-map
156 :initarg
:global-properties
157 :accessor global-properties
163 (use-instance-class-p
164 :initarg
:use-instance-class-p
165 :accessor use-instance-class-p
167 (initializedp :initform nil
)
168 (modifiedp :accessor modifiedp
:initform nil
:initarg
:modifiedp
)
169 (modifications :accessor modifications
:initform nil
)))
172 (defmethod attributes :around
((self mewa
))
173 (let ((a (call-next-method)))
174 (or a
(funcall (attributes-getter self
) self
))))
176 (defgeneric get-attributes
(mewa))
178 (defmethod get-attributes ((self mewa
))
180 (append (meta-model:list-slots
(instance self
))
181 (meta-model:list-has-many
(instance self
)))
184 (defmethod find-instance-classes ((self mewa
))
186 (it.bese.arnesi.mopp
:compute-class-precedence-list
(class-of (instance self
)))))
188 (defmethod find-all-attributes ((self mewa
))
190 (mapcar #'(lambda (x)
191 (cdr (find-class-attributes x
)))
194 (defun make-attribute (&rest props
&key type
&allow-other-keys
)
196 (cons (gensym) (cons type props
)))
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
)))
203 (setf (cddr att
) (plist-union (global-properties self
) (cddr att
)))
205 (if (attributes self
)
207 (mapcar #'(lambda (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
)))
216 (plist-union (cddr att
) (global-properties self
)))
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
)))))
237 (defmethod find-slot-presentation-for-attribute ((self mewa
) attribute
)
239 (or (gethash (if (consp (second attribute
))
240 (car (second attribute
))
242 ucw
::*slot-type-mapping
*)
243 (error "Can't find slot type for ~A" (second attribute
)))))
245 (cons (first attribute
) (apply #'make-instance
247 (append (cddr attribute
) (list :parent self
:size
30))))))
249 (defmethod find-slot-presentations ((self mewa
))
250 (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a
))
251 (find-applicable-attributes self
)))
253 (defmethod find-attribute-slot ((self mewa
) (attribute symbol
))
254 (cdr (assoc attribute
(attribute-slot-map self
))))
256 (defmethod initialize-slots ((self mewa
))
257 (when (instance self
)
258 (when (use-instance-class-p self
)
260 (append (find-instance-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
)))))
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
)
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
))
278 (plist-union initargs
(cddr a
)))))
279 (setf (slot-value i
'instance
) object
)
281 (setf (slot-value i
'initializedp
) t
)
285 (defmethod initialize-slots-place ((place ucw
::place
) (mewa mewa
))
286 (setf (slots mewa
) (mapcar #'(lambda (x)
288 (setf (component.place x
) place
)))
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
)
300 (defmacro call-presentation
(object &rest args
)
301 `(present-object ,object
:presentation
(make-presentation ,object
,@args
)))
304 (defcomponent about-dialog
(option-dialog)
305 ((body :initarg
:body
)))
307 (defmethod render-on ((res response
) (self about-dialog
))
309 (render-on res
(slot-value self
'body
)))
312 (defmethod instance-is-stored-p ((instance clsql
:standard-db-object
))
313 (slot-value instance
'clsql-sys
::view-database
))
315 (defmethod instance-is-stored-p ((mewa mewa
))
316 (instance-is-stored-p (instance mewa
)))
318 (defaction cancel-save-instance
((self mewa
))
320 ((instance-is-stored-p (instance self
))
321 (meta-model::update-instance-from-records
(instance self
))
325 (defaction save-instance
((self mewa
))
326 (meta-model:sync-instance
(instance self
))
327 (setf (modifiedp self
) nil
)
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
)
338 :options
'((:save .
"Save changes to Database")
339 (:cancel .
"Cancel all changes")))
341 (cancel-save-instance self
))
343 (save-instance self
))))))
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
)))
351 (defmethod (setf presentation-slot-value
) :around
(value (slot slot-presentation
) instance
)
353 (presentation-slot-value slot instance
)
355 (new (presentation-slot-value slot instance
)))
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
)))))))
362 ;;;; * Finally set up some defaults
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))
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.