Commit | Line | Data |
---|---|---|
13ebe12f DC |
1 | (declaim (optimize (speed 2) (space 3) (safety 0))) |
2 | ||
5dea194e | 3 | (in-package :lisp-on-lines) |
13ebe12f | 4 | |
579597e3 | 5 | (defparameter *default-type* :ucw) |
6 | ||
15bc66bd DC |
7 | ;;;; I think these are unused now |
8 | (defmethod perform-set-attributes ((occurence-name t) definitions) | |
9 | (dolist (def definitions) | |
10 | (funcall #'set-attribute occurence-name (first def) (rest def)))) | |
11 | ||
12 | (defmethod perform-set-attribute-properties ((occurence-name t) definitions) | |
13 | (dolist (def definitions) | |
14 | (funcall #'set-attribute-properties occurence-name (car def) (cdr def)))) | |
15 | ||
16 | ;;;; PLIST Utilities. | |
579597e3 | 17 | |
18 | (defun plist-nunion (new-props plist) | |
15bc66bd DC |
19 | "Destructive Merge of plists. PLIST is modified and returned. |
20 | NEW-PROPS is merged into PLIST such that any properties | |
21 | in both PLIST and NEW-PROPS get the value in NEW-PROPS. | |
22 | The other properties in PLIST are left untouched." | |
d0c40011 | 23 | (loop for cons on new-props by #'cddr |
579597e3 | 24 | do (setf (getf plist (first cons)) (second cons)) |
25 | finally (return plist))) | |
26 | ||
27 | (defun plist-union (new-props plist) | |
28 | "Non-destructive version of plist-nunion" | |
29 | (plist-nunion new-props (copy-list plist))) | |
30 | ||
579597e3 | 31 | |
15bc66bd DC |
32 | ;;;; * Occurences |
33 | ||
34 | (defvar *occurence-map* (make-hash-table) | |
35 | "Presentations are created by associating an 'occurence' | |
36 | with an instance of a class. This is usually keyed off class-name, | |
37 | although an arbitrary occurence can be used with an arbitrary class.") | |
38 | ||
39 | (define-layered-class | |
40 | standard-occurence () | |
41 | ((attribute-map :accessor attribute-map :initform (make-hash-table))) | |
42 | (:documentation | |
43 | "an occurence holds the attributes like a class holds slot-definitions. | |
44 | Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects.")) | |
45 | ||
46 | (defun find-or-create-occurence (name) | |
47 | "Returns the occurence associated with this name." | |
48 | (let ((occurence (gethash name *occurence-map*))) | |
49 | (if occurence | |
50 | occurence | |
51 | (let ((new-occurence (make-instance 'standard-occurence))) | |
52 | (setf (gethash name *occurence-map*) new-occurence) | |
53 | new-occurence)))) | |
54 | ||
55 | (defun clear-occurence (occurence) | |
56 | "removes all attributes from the occurence" | |
57 | (setf (attribute-map occurence) (make-hash-table))) | |
58 | ||
59 | (defgeneric find-occurence (name) | |
bf12489a DC |
60 | (:method (thing) |
61 | nil) | |
15bc66bd DC |
62 | (:method ((name symbol)) |
63 | (find-or-create-occurence name)) | |
bf12489a | 64 | (:method ((instance standard-object)) |
15bc66bd DC |
65 | (find-or-create-occurence (class-name (class-of instance))))) |
66 | ||
67 | ||
68 | ;;;; * Attributes | |
69 | ||
70 | (define-layered-class | |
71 | standard-attribute () | |
72 | ((name :layered-accessor attribute.name :initarg :name :initform "attribute") | |
73 | (type :layered-accessor attribute.type :initarg :type :initform t :type symbol) | |
74 | (plist :layered-accessor attribute.plist :initarg :plist :initform nil)) | |
75 | (:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc.")) | |
76 | ||
77 | ||
78 | (defmethod print-object ((self standard-attribute) stream) | |
79 | (print-unreadable-object (self stream :type t) | |
80 | (with-slots (name type) self | |
81 | (format stream "~A ~A" name type)))) | |
82 | ||
83 | (define-layered-class | |
84 | presentation-attribute (standard-attribute) | |
85 | () | |
86 | (:documentation "Presentation Attributes are used to display objects | |
87 | using the attributes defined in an occurence. Presentation Attributes are always named using keywords.")) | |
88 | ||
89 | (defun clear-attributes (name) | |
90 | "removes all attributes from an occurance" | |
91 | (clear-occurence (find-occurence name))) | |
92 | ||
93 | (defmethod find-attribute-class-for-name (name) | |
94 | "presentation attributes are named using keywords" | |
95 | (if (keywordp name) | |
96 | 'presentation-attribute | |
97 | 'standard-attribute)) | |
98 | ||
99 | (defmethod ensure-attribute ((occurence standard-occurence) name type plist) | |
100 | "Creates an attribute in the given occurence" | |
101 | (setf (gethash name (attribute-map occurence)) | |
102 | (make-instance (find-attribute-class-for-name name) | |
103 | :name name :type type :plist plist))) | |
104 | ||
105 | (defmethod find-attribute ((occurence standard-occurence) name) | |
106 | (gethash name (attribute-map occurence))) | |
107 | ||
108 | (defmethod find-all-attributes ((occurence standard-occurence)) | |
109 | (loop for att being the hash-values of (attribute-map occurence) | |
110 | collect att)) | |
111 | ||
112 | (defmethod ensure-attribute (occurence-name name type plist) | |
113 | (ensure-attribute | |
114 | (find-occurence occurence-name) | |
115 | name | |
116 | type | |
117 | plist)) | |
118 | ||
119 | ;;;; The following functions make up the public interface to the | |
120 | ;;;; MEWA Attribute Occurence system. | |
121 | ||
122 | (defmethod find-all-attributes (occurence-name) | |
123 | (find-all-attributes (find-occurence occurence-name))) | |
124 | ||
125 | (defmethod find-attribute (occurence-name attribute-name) | |
126 | "Returns the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name" | |
127 | (find-attribute (find-occurence occurence-name) attribute-name)) | |
128 | ||
129 | (defmethod (setf find-attribute) ((def list) occurence-name attribute-name) | |
130 | (ensure-attribute occurence-name attribute-name (first def) (rest def))) | |
131 | ||
132 | (defmethod set-attribute (occurence-name attribute-name definition &key (inherit t)) | |
133 | (let ((att (find-attribute occurence-name attribute-name))) | |
134 | (setf (find-attribute occurence-name attribute-name) | |
135 | (if (and att inherit) | |
579597e3 | 136 | (cons (car definition) |
137 | (plist-union (cdr definition) | |
15bc66bd DC |
138 | (attribute.plist att))) |
139 | definition)))) | |
579597e3 | 140 | |
15bc66bd DC |
141 | (defmethod set-attribute-properties ((occurence-name t) attribute properties) |
142 | (let ((a (find-attribute occurence-name attribute))) | |
34e8e2d6 | 143 | (if a |
15bc66bd DC |
144 | (setf (attribute.plist a) (plist-nunion properties (attribute.plist a))) |
145 | (error "Attribute ~A does not exist" attribute)))) | |
fc3e754f | 146 | |
15bc66bd | 147 | (defmethod perform-define-attributes ((occurence-name t) attributes) |
fc3e754f DC |
148 | (loop for attribute in attributes |
149 | do (destructuring-bind (name type &rest args) | |
150 | attribute | |
151 | (cond ((eq type t) | |
152 | ;;use the existing (default) type | |
15bc66bd | 153 | (set-attribute-properties occurence-name name args)) |
fc3e754f DC |
154 | ((not (null type)) |
155 | ;;set the type as well | |
15bc66bd | 156 | (set-attribute occurence-name name (cons type args))))))) |
fc3e754f | 157 | |
15bc66bd | 158 | (defmacro define-attributes (occurence-names &body attribute-definitions) |
fc3e754f | 159 | `(progn |
15bc66bd DC |
160 | ,@(loop for occurence-name in occurence-names |
161 | collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions))))) | |
162 | ||
163 | ||
164 | (defmethod setter (attribute) | |
165 | (let ((setter (getf (attribute.plist attribute) :setter)) | |
166 | (slot-name (getf (attribute.plist attribute) :slot-name))) | |
167 | (cond (setter | |
168 | setter) | |
169 | (slot-name | |
170 | #'(lambda (value object) | |
171 | (setf (slot-value object slot-name) value))) | |
172 | (t | |
173 | #'(lambda (value object) | |
174 | (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute)))))) | |
175 | ||
176 | (defmethod getter (attribute) | |
177 | (let ((getter (getf (attribute.plist attribute) :getter)) | |
178 | (slot-name (getf (attribute.plist attribute) :slot-name))) | |
179 | (cond (getter | |
180 | getter) | |
181 | (slot-name | |
182 | #'(lambda (object) | |
183 | (when (slot-boundp object slot-name) | |
184 | (slot-value object slot-name))))))) | |
185 | ||
186 | (defgeneric attribute-value (instance attribute) | |
187 | (:method (instance (attribute standard-attribute)) | |
188 | (funcall (getter attribute) instance))) | |
d5e996b3 | 189 | |
15bc66bd DC |
190 | (defgeneric (setf attribute-value) (value instance attribute) |
191 | (:method (value instance (attribute standard-attribute)) | |
192 | (funcall (setter attribute) value instance))) | |
d5e996b3 DC |
193 | |
194 | ||
195 | ;;;; ** Default Attributes | |
196 | ||
197 | ||
198 | ;;;; The default mewa class contains the types use as defaults. | |
199 | ;;;; maps meta-model slot-types to slot-presentation | |
200 | ||
201 | (defvar *default-attributes-class-name* 'default) | |
202 | ||
15bc66bd DC |
203 | (defmacro with-default-attributes ((occurence-name) &body body) |
204 | `(let ((*default-attributes-class-name* ',occurence-name)) | |
205 | ,@body)) | |
206 | ||
d5e996b3 DC |
207 | (define-attributes (default) |
208 | (boolean mewa-boolean) | |
209 | (string mewa-string) | |
210 | (number mewa-currency) | |
211 | (integer mewa-integer) | |
212 | (currency mewa-currency) | |
213 | (clsql:generalized-boolean mewa-boolean) | |
214 | (foreign-key foreign-key) | |
215 | (:viewer mewa-viewer) | |
216 | (:editor mewa-editor) | |
217 | (:creator mewa-creator) | |
63c06c54 | 218 | (:as-string mewa-one-line-presentation) |
d5e996b3 DC |
219 | (:one-line mewa-one-line-presentation) |
220 | (:listing mewa-list-presentation :global-properties (:editablep nil) :editablep t) | |
221 | (:search-model mewa-object-presentation)) | |
222 | ||
15bc66bd DC |
223 | (defun find-presentation-attributes (occurence-name) |
224 | (loop for att in (find-all-attributes occurence-name) | |
225 | when (typep att 'presentation-attribute) | |
226 | collect att)) | |
d5e996b3 | 227 | |
15bc66bd DC |
228 | (defun attribute-to-definition (attribute) |
229 | (nconc (list (attribute.name attribute) | |
230 | (attribute.type attribute)) | |
231 | (attribute.plist attribute))) | |
d5e996b3 | 232 | |
15bc66bd DC |
233 | (defun find-default-presentation-attribute-definitions () |
234 | (if (eql *default-attributes-class-name* 'default) | |
235 | (mapcar #'attribute-to-definition (find-presentation-attributes 'default)) | |
236 | (remove-duplicates (mapcar #'attribute-to-definition | |
237 | (append | |
238 | (find-presentation-attributes 'default) | |
239 | (find-presentation-attributes | |
240 | *default-attributes-class-name*)))))) | |
d5e996b3 | 241 | (defun gen-ptype (type) |
15bc66bd DC |
242 | (let* ((type (if (consp type) (car type) type)) |
243 | (possible-default (find-attribute *default-attributes-class-name* type)) | |
244 | (real-default (find-attribute 'default type))) | |
245 | (cond | |
246 | (possible-default | |
247 | (attribute.type possible-default)) | |
248 | (real-default | |
249 | (attribute.type real-default)) | |
250 | (t type)))) | |
d5e996b3 DC |
251 | |
252 | (defun gen-presentation-slots (instance) | |
253 | (mapcar #'(lambda (x) (gen-pslot (cadr x) | |
254 | (string (car x)) | |
255 | (car x))) | |
256 | (meta-model:list-slot-types instance))) | |
257 | ||
34e8e2d6 | 258 | |
d5e996b3 DC |
259 | (defun gen-pslot (type label slot-name) |
260 | (copy-list `(,(gen-ptype type) | |
261 | :label ,label | |
262 | :slot-name ,slot-name))) | |
263 | ||
d5e996b3 | 264 | (defmethod find-default-attributes ((model t)) |
a6644385 | 265 | "return the default attributes for a given model using the meta-model's meta-data" |
7129498f | 266 | (append (mapcar #'(lambda (s) |
267 | (cons (car s) | |
268 | (gen-pslot | |
1679abef | 269 | (if (meta-model:foreign-key-p model (car s)) |
38a016c7 | 270 | 'foreign-key |
1679abef | 271 | (cadr s)) |
272 | (string (car s)) (car s)))) | |
273 | (meta-model:list-slot-types model)) | |
274 | (mapcar #'(lambda (s) | |
38a016c7 | 275 | (cons s (append (gen-pslot 'has-many (string s) s) |
1679abef | 276 | `(:presentation |
277 | (make-presentation | |
278 | ,model | |
279 | :type :one-line))))) | |
d5e996b3 | 280 | (meta-model:list-has-many model)) |
15bc66bd | 281 | (find-default-presentation-attribute-definitions))) |
19531fbd | 282 | |
283 | (defmethod set-default-attributes ((model t)) | |
8e6e6b56 | 284 | "Set the default attributes for MODEL" |
15bc66bd | 285 | (clear-attributes model) |
19531fbd | 286 | (mapcar #'(lambda (x) |
287 | (setf (find-attribute model (car x)) (cdr x))) | |
d5e996b3 | 288 | (find-default-attributes model))) |
579597e3 | 289 | |
19531fbd | 290 | ;;;presentations |
579597e3 | 291 | (defcomponent mewa () |
38a016c7 | 292 | ((instance :accessor instance :initarg :instance) |
2cb4247d | 293 | (attributes |
579597e3 | 294 | :initarg :attributes |
295 | :accessor attributes | |
296 | :initform nil) | |
297 | (attributes-getter | |
298 | :accessor attributes-getter | |
299 | :initform #'get-attributes | |
300 | :initarg :attributes-getter) | |
569ad9e6 DC |
301 | (attribute-slot-map |
302 | :accessor attribute-slot-map | |
303 | :initform nil) | |
579597e3 | 304 | (global-properties |
305 | :initarg :global-properties | |
306 | :accessor global-properties | |
307 | :initform nil) | |
308 | (classes | |
309 | :initarg :classes | |
310 | :accessor classes | |
311 | :initform nil) | |
312 | (use-instance-class-p | |
313 | :initarg :use-instance-class-p | |
314 | :accessor use-instance-class-p | |
315 | :initform t) | |
316 | (initializedp :initform nil) | |
8e6e6b56 | 317 | (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp) |
d1bb68e0 | 318 | (modifications :accessor modifications :initform nil))) |
579597e3 | 319 | |
579597e3 | 320 | |
321 | (defmethod attributes :around ((self mewa)) | |
322 | (let ((a (call-next-method))) | |
323 | (or a (funcall (attributes-getter self) self)))) | |
324 | ||
19531fbd | 325 | (defgeneric get-attributes (mewa)) |
326 | ||
579597e3 | 327 | (defmethod get-attributes ((self mewa)) |
328 | (if (instance self) | |
329 | (append (meta-model:list-slots (instance self)) | |
330 | (meta-model:list-has-many (instance self))) | |
331 | nil)) | |
332 | ||
579597e3 | 333 | (defmethod find-instance-classes ((self mewa)) |
334 | (mapcar #'class-name | |
335 | (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self))))) | |
336 | ||
579597e3 | 337 | (defun make-attribute (&rest props &key type &allow-other-keys) |
338 | (remf props :type) | |
339 | (cons (gensym) (cons type props))) | |
340 | ||
15bc66bd DC |
341 | (defun make-presentation-for-attribute-list-item |
342 | (occurence att-name plist parent-presentation &optional type) | |
343 | (declare (type list plist) (type symbol att-name)) | |
344 | "This is a ucw specific function that will eventually be factored elsewhere." | |
345 | (let* ((attribute (find-attribute occurence att-name)) | |
346 | (type (when attribute (or type (attribute.type attribute)))) | |
347 | (class-name | |
348 | (or (gethash (if (consp type) | |
349 | (car type) | |
350 | type) | |
351 | *presentation-slot-type-mapping*) | |
352 | (error "Can't find slot type for ~A in ~A from ~A" att-name occurence parent-presentation)))) | |
353 | ||
354 | (cons (attribute.name attribute) (apply #'make-instance | |
355 | class-name | |
356 | (append (plist-nunion | |
357 | plist | |
358 | (plist-union | |
359 | (global-properties parent-presentation) | |
360 | (attribute.plist attribute))) | |
361 | (list :size 30 :parent parent-presentation)))))) | |
362 | ||
363 | (defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list) | |
364 | "Returns a list of functions that, when called with an object presentation, | |
365 | returns the ucw slot presentation that will be used to present this attribute | |
366 | in that object presentation." | |
367 | (loop for att in attribute-list | |
368 | with funs = (list) | |
369 | do (let ((att att)) (cond | |
370 | ;;simple casee | |
371 | ((symbolp att) | |
372 | (push #'(lambda (p) | |
373 | (make-presentation-for-attribute-list-item occurence att nil p)) | |
374 | funs)) | |
375 | ;;if the car is a keyword then this is an inline def | |
376 | ;; drewc nov 12 2005: | |
377 | ;; i never used this, and never told anybody about it. | |
378 | ;; removing it. | |
379 | #+ (or) ((and (listp x) (keywordp (car x))) | |
380 | (let ((att (apply #'make-attribute x))) | |
381 | (setf (cddr att) | |
382 | (plist-union (cddr att) (global-properties self))) | |
383 | att)) | |
384 | ||
385 | ;; if the plist has a :type | |
386 | ((and (listp att) (getf (cdr att) :type)) | |
387 | (let ((type (getf (cdr att) :type))) | |
388 | (push #'(lambda (p) | |
389 | (make-presentation-for-attribute-list-item | |
390 | occurence (first att) | |
391 | (cdr att) | |
392 | p | |
393 | type)) | |
394 | funs))) | |
395 | ;;finally if we are just overiding the props | |
396 | ((and (listp att) (symbolp (car att))) | |
397 | (push #'(lambda (p) | |
398 | (make-presentation-for-attribute-list-item occurence (first att) (rest att) p)) | |
399 | funs)))) | |
400 | finally (return (nreverse funs)))) | |
401 | ||
402 | ||
403 | (defun find-attribute-names (mewa) | |
404 | (mapcar #'(lambda (x) | |
405 | (if (listp x) | |
406 | (first x) | |
407 | x)) | |
408 | (attributes mewa))) | |
579597e3 | 409 | |
410 | (defmethod find-applicable-attributes ((self mewa)) | |
15bc66bd DC |
411 | (if (attributes self) |
412 | (find-applicable-attributes-using-attribute-list (instance self) (attributes self)) | |
413 | (find-applicable-attributes-using-attribute-list (instance (get-attributes self))))) | |
414 | ||
569ad9e6 | 415 | |
579597e3 | 416 | (defmethod find-slot-presentations ((self mewa)) |
15bc66bd | 417 | (mapcar #'(lambda (a) (funcall a self)) |
579597e3 | 418 | (find-applicable-attributes self))) |
419 | ||
569ad9e6 DC |
420 | (defmethod find-attribute-slot ((self mewa) (attribute symbol)) |
421 | (cdr (assoc attribute (attribute-slot-map self)))) | |
579597e3 | 422 | |
423 | (defmethod initialize-slots ((self mewa)) | |
65792e79 DC |
424 | (when (instance self) |
425 | (when (use-instance-class-p self) | |
426 | (setf (classes self) | |
427 | (append (find-instance-classes self) | |
428 | (classes self)))) | |
429 | (setf (attribute-slot-map self) (find-slot-presentations self)) | |
430 | (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self ))))) | |
cf5da3ed DC |
431 | |
432 | ||
19531fbd | 433 | (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil)) |
598f1fa8 | 434 | ;(warn "Initargs : ~A" initargs) |
15bc66bd DC |
435 | (let* ((a (find-attribute object type)) |
436 | (i (apply #'make-instance | |
437 | (if a | |
438 | (attribute.type a) | |
439 | type) | |
440 | (plist-union initargs (when a | |
441 | (attribute.plist a)))))) | |
0fd9d744 | 442 | |
19531fbd | 443 | (setf (slot-value i 'instance) object) |
2acd3ba2 | 444 | (initialize-slots i) |
445 | (setf (slot-value i 'initializedp) t) | |
19531fbd | 446 | i)) |
447 | ||
5dea194e | 448 | (defmethod make-presentation ((list list) &key (type :listing) (initargs nil)) |
cf5da3ed DC |
449 | (let ((args (append |
450 | `(:type ,type) | |
451 | `(:initargs | |
452 | (:instances ,list | |
453 | ,@initargs))))) | |
454 | ||
455 | (apply #'make-presentation (car list) args))) | |
19531fbd | 456 | |
8e6e6b56 DC |
457 | (defmethod initialize-slots-place ((place ucw::place) (mewa mewa)) |
458 | (setf (slots mewa) (mapcar #'(lambda (x) | |
459 | (prog1 x | |
460 | (setf (component.place x) place))) | |
461 | (slots mewa)))) | |
462 | ||
68a53dce | 463 | (arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa)) |
579597e3 | 464 | (unless (slot-value to 'initializedp) |
465 | (initialize-slots to)) | |
466 | (setf (slot-value to 'initializedp) t) | |
68a53dce DC |
467 | (initialize-slots-place (component.place from) to) |
468 | to) | |
469 | ||
470 | ||
579597e3 | 471 | |
472 | (defmacro call-presentation (object &rest args) | |
ae09804a | 473 | `(present-object ,object :presentation (make-presentation ,object ,@args))) |
474 | ||
4e2ecf69 DC |
475 | |
476 | (defcomponent about-dialog (option-dialog) | |
477 | ((body :initarg :body))) | |
478 | ||
479 | (defmethod render-on ((res response) (self about-dialog)) | |
d75822e6 DC |
480 | (call-next-method) |
481 | (render-on res (slot-value self 'body))) | |
4e2ecf69 | 482 | |
569ad9e6 | 483 | |
13ada38f | 484 | |
8e6e6b56 | 485 | |
ae09804a | 486 | (defaction cancel-save-instance ((self mewa)) |
1679abef | 487 | (cond |
5dea194e | 488 | ((meta-model::persistentp (instance self)) |
1679abef | 489 | (meta-model::update-instance-from-records (instance self)) |
490 | (answer self)) | |
491 | (t (answer nil)))) | |
ae09804a | 492 | |
493 | (defaction save-instance ((self mewa)) | |
7129498f | 494 | (meta-model:sync-instance (instance self)) |
8e6e6b56 DC |
495 | (setf (modifiedp self) nil) |
496 | (answer self)) | |
ae09804a | 497 | |
d5e996b3 DC |
498 | (defmethod confirm-sync-instance ((self mewa)) |
499 | nil) | |
ae09804a | 500 | |
12dcf3d4 | 501 | (defaction ensure-instance-sync ((self mewa)) |
ae09804a | 502 | (when (modifiedp self) |
d5e996b3 DC |
503 | (if nil |
504 | (let ((message (format nil "Record has been modified, Do you wish to save the changes?"))) | |
505 | (case (call 'about-dialog | |
506 | :body (make-presentation (instance self) | |
507 | :type :viewer) | |
508 | :message message | |
509 | :options '((:save . "Save changes to Database") | |
510 | (:cancel . "Cancel all changes"))) | |
511 | (:cancel | |
512 | (cancel-save-instance self)) | |
513 | (:save | |
514 | (save-instance self)))) | |
515 | (save-instance self)))) | |
516 | ||
517 | (defaction sync-and-answer ((self mewa)) | |
518 | (ensure-instance-sync self) | |
519 | (answer (instance self))) | |
ae09804a | 520 | |
e8e743d7 | 521 | (defaction ok ((self mewa) &optional arg) |
522 | "Returns the component if it has not been modified. if it has been, prompt user to save or cancel" | |
68a53dce | 523 | ;(declare (ignore arg)) |
d5e996b3 | 524 | (sync-and-answer self)) |
e8e743d7 | 525 | |
ae09804a | 526 | (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance) |
527 | (let* ((old (prog1 | |
528 | (presentation-slot-value slot instance) | |
529 | (call-next-method))) | |
530 | (new (presentation-slot-value slot instance))) | |
531 | ||
532 | (unless (equal new old ) | |
533 | (let ((self (ucw::parent slot))) | |
534 | (setf (modifiedp self) instance | |
4e2ecf69 | 535 | (modifications self) (append (list new old value slot instance) (modifications self))))))) |
233380f7 | 536 | |
d5e996b3 | 537 | |
ab7ef8e9 DC |
538 | |
539 | ||
540 | ||
541 | ||
233380f7 | 542 | |
543 | ;; This software is Copyright (c) Drew Crampsie, 2004-2005. | |
544 | ;; You are granted the rights to distribute | |
545 | ;; and use this software as governed by the terms | |
546 | ;; of the Lisp Lesser GNU Public License | |
547 | ;; (http://opensource.franz.com/preamble.html), | |
548 | ;; known as the LLGPL. |