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 name."
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))))
100 (defmethod set-attribute-properties ((model t) attribute properties)
101 (let ((a (find-attribute model attribute)))
103 (setf (cddr a) (plist-nunion properties (cddr a)))
104 (error "Attribute ~A does not exist" attribute) )))
106 (defmethod perform-set-attribute-properties ((model t) definitions)
107 (dolist (def definitions)
108 (funcall #'set-attribute-properties model (car def) (cdr def))))
111 (defmethod default-attributes ((model t))
112 "return the default attributes for a given model using the meta-model's meta-data"
113 (append (mapcar #'(lambda (s)
116 (if (meta-model:foreign-key-p model (car 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)
127 (meta-model:list-has-many model))))
129 (defmethod set-default-attributes ((model t))
130 "Set the default attributes for MODEL"
131 (clear-class-attributes model)
132 (mapcar #'(lambda (x)
133 (setf (find-attribute model (car x)) (cdr x)))
134 (default-attributes model)))
137 (defgeneric attributes-getter (model))
143 (defcomponent mewa ()
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 (second attribute) ucw::*slot-type-mapping*)
240 (error "Can't find slot type for ~A" (second attribute)))))
242 (cons (first attribute) (apply #'make-instance
244 (append (cddr attribute) (list :parent self :size 30))))))
246 (defmethod find-slot-presentations ((self mewa))
247 (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a))
248 (find-applicable-attributes self)))
250 (defmethod find-attribute-slot ((self mewa) (attribute symbol))
251 (cdr (assoc attribute (attribute-slot-map self))))
253 (defmethod initialize-slots ((self mewa))
254 (when (use-instance-class-p self)
256 (append (find-instance-classes self)
258 (setf (attribute-slot-map self) (find-slot-presentations self))
259 (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self ))))
262 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
263 (let* ((p (make-instance 'mewa-object-presentation))
264 (a (progn (setf (slot-value p 'instance) object)
266 (assoc type (find-all-attributes p))))
268 (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
269 (setf (slot-value i 'instance) object)
272 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
273 (let* ((p (make-instance 'mewa-object-presentation))
274 (a (progn (setf (slot-value p 'instance) object)
276 (assoc type (find-all-attributes p))))
278 (i (apply #'make-instance (or (second a)
279 ;; if we didnt find the type,
280 ;; use the symbol as a class.
281 (if (eql (symbol-package type)
282 (find-package 'keyword))
285 (plist-union initargs (cddr a)))))
286 (setf (slot-value i 'instance) object)
288 (setf (slot-value i 'initializedp) t)
292 (defmethod initialize-slots-place ((place ucw::place) (mewa mewa))
293 (setf (slots mewa) (mapcar #'(lambda (x)
295 (setf (component.place x) place)))
298 (defmethod call-component :before ((from standard-component) (to mewa))
299 (unless (slot-value to 'initializedp)
300 (initialize-slots to))
301 (setf (slot-value to 'initializedp) t)
302 (setf (slots to) (mapcar #'(lambda (x) (prog2
303 (setf (component.place x) (component.place from))
307 (defmacro call-presentation (object &rest args)
308 `(present-object ,object :presentation (make-presentation ,object ,@args)))
311 (defcomponent about-dialog (option-dialog)
312 ((body :initarg :body)))
314 (defmethod render-on ((res response) (self about-dialog))
316 (render-on res (slot-value self 'body)))
319 (defmethod instance-is-stored-p ((instance clsql:standard-db-object))
320 (slot-value instance 'clsql-sys::view-database))
322 (defmethod instance-is-stored-p ((mewa mewa))
323 (instance-is-stored-p (instance mewa)))
325 (defaction cancel-save-instance ((self mewa))
327 ((instance-is-stored-p (instance self))
328 (meta-model::update-instance-from-records (instance self))
332 (defaction save-instance ((self mewa))
333 (meta-model:sync-instance (instance self))
334 (setf (modifiedp self) nil)
338 (defaction ensure-instance-sync ((self mewa))
339 (when (modifiedp self)
340 (let ((message (format nil "Record has been modified, Do you wish to save the changes?")))
341 (case (call 'about-dialog
342 :body (make-presentation (instance self)
345 :options '((:save . "Save changes to Database")
346 (:cancel . "Cancel all changes")))
348 (cancel-save-instance self))
350 (save-instance self))))))
352 (defaction ok ((self mewa) &optional arg)
353 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
354 (declare (ignore arg))
355 (ensure-instance-sync self)
358 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
360 (presentation-slot-value slot instance)
362 (new (presentation-slot-value slot instance)))
364 (unless (equal new old )
365 (let ((self (ucw::parent slot)))
366 (setf (modifiedp self) instance
367 (modifications self) (append (list new old value slot instance) (modifications self)))))))
369 ;;;; * Finally set up some defaults
371 (setf (find-attribute t :viewer)
372 '(mewa-object-presentation :global-properties (:editablep nil))
373 (find-attribute t :editor)
374 '(mewa-object-presentation :global-properties (:editablep t))
375 (find-attribute t :one-line)
376 '(mewa::mewa-one-line-presentation)
377 (find-attribute t :listing)
378 '(mewa::mewa-list-presentation :global-properties (:editablep nil) :editablep t)
379 (find-attribute t :search-presentation)
380 '(mewa-object-presentation))
386 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
387 ;; You are granted the rights to distribute
388 ;; and use this software as governed by the terms
389 ;; of the Lisp Lesser GNU Public License
390 ;; (http://opensource.franz.com/preamble.html),
391 ;; known as the LLGPL.