5 (defcomponent presentation
()
6 ((css-class :accessor css-class
:initarg
:css-class
:initform nil
))
7 (:documentation
"The super class of all UCW presentations.
9 A presentation object is a UCW component which knows how to
10 read/write different kinds of data types.
12 There are three major kinds of presentations:
14 1) object-presentation - Managing a single object.
16 2) slot-presentation - Managing the single parts (slots) which
19 3) collection-presentation - Managing multiple objects.
21 Presentations are independant of the underlying application
22 specific lisp objects they manage. A presentation can be created
23 once and reused or modified before and aftre it has been used.
25 Presentations fulfill two distinct roles: on the one hand they
26 create, given a lisp object, a grahpical (html) rendering of that
27 object, they also deal with whatever operations the user might
28 wish to perform on that object.
30 * Creating Presentation Objects
32 Presentation objects are created by making an instance of either
33 an object-presentation or a collection-presentation and then
34 filling the slots property of this object."))
36 (defgeneric present
(presentation)
37 (:documentation
"Render PRESENTATION (generally called from render-on)."))
39 (defmacro present-object
(object &key using presentation
)
40 (assert (xor using presentation
)
42 "Must specify exactly one of :USING and :PRESENTATION.")
44 (destructuring-bind (type &rest args
)
46 `(call ',type
,@args
'instance
,object
))
47 (rebinding (presentation)
49 (setf (slot-value ,presentation
'instance
) ,object
)
50 (call-component self
,presentation
)))))
52 (defmacro present-collection
(presentation-type &rest initargs
)
53 `(call ',presentation-type
,@initargs
))
55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
56 ;;;; object-presentation
58 (defcomponent object-presentation
(presentation)
59 ((slots :accessor slots
:initarg
:slots
:initform nil
)
60 (instance :initform nil
:initarg instance
:accessor instance
))
61 (:documentation
"Presentations for single objects."))
63 (defmethod render-on ((res response
) (o object-presentation
))
64 (unless (slot-value o
'instance
)
65 (error "Attempting to render the presentation ~S, but it has no instance object to present."
69 (defmethod present ((pres object-presentation
))
70 (<:table
:class
(css-class pres
)
71 (dolist (slot (slots pres
))
72 (<:tr
:class
"presentation-slot-row"
73 (<:td
:class
"presentation-slot-label" (<:as-html
(label slot
)))
74 (<:td
:class
"presentation-slot-value" (present-slot slot
(instance pres
)))))
75 (render-options pres
(instance pres
))))
77 (defmethod render-options ((pres object-presentation
) instance
)
78 (declare (ignore instance pres
))
80 (<:td
:colspan
2 :align
"center"
81 (<ucw
:input
:type
"submit" :action
(ok pres
) :value
"Ok."))) |
# )
83 (defaction ok
((o object-presentation
) &optional
(value (slot-value o
'instance
)))
86 (defmethod find-slot ((o object-presentation
) slot-label
)
87 (find slot-label
(slots o
) :test
#'string
= :key
#'label
))
89 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
90 ;;;; inline objects are extremly similar to object-presentations
91 ;;;; except that we assume they're being edited within the context of
92 ;;;; some other and so don't get their own edit/delete/confirm
93 ;;;; whatever buttons.
95 (defcomponent inline-object-presentation
(object-presentation)
98 (defmethod render-options ((pres inline-object-presentation
) instance
)
99 (declare (ignore instance
))
102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
103 ;;;; 'one line' objects
105 (defcomponent one-line-presentation
(object-presentation)
106 ((before :accessor before
:initform
"" :initarg
:before
107 :documentation
"Text to render before rendirng the slots.")
108 (between :accessor between
:initform
" " :initarg
:between
109 :documentation
"Text to render between each slot.")
110 (after :accessor after
:initform
"" :initarg after
111 :documentation
"Text to render after all the slots have been rendered.")))
113 (defmethod present ((pres one-line-presentation
))
114 (<:as-is
(before pres
))
116 (present-slot (first (slots pres
)) (instance pres
)))
117 (dolist (slot (cdr (slots pres
)))
118 (<:as-is
(between pres
))
119 (present-slot slot
(instance pres
)))
120 (<:as-is
(after pres
)))
122 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
125 (defcomponent list-presentation
(presentation)
126 ((slots :accessor slots
:initarg
:slots
)
127 (editablep :accessor editablep
:initform t
:initarg
:editablep
)
128 (edit-label :accessor edit-label
:initform
"Edit")
129 (deleteablep :accessor deleteablep
:initform t
:initarg
:deleteablep
)
130 (delete-label :accessor delete-label
:initform
"Delete")
131 (instances :accessor instances
)))
133 (defmethod initialize-instance :after
((l list-presentation
) &rest initargs
)
134 (declare (ignore initargs
))
135 (setf (instances l
) (get-all-instances l
)))
137 (defmethod render-on ((res response
) (l list-presentation
))
140 (defgeneric get-all-instances
(listing)
141 (:documentation
"Returns all the instances which should be viewable with LISTING.
143 This method is also used by relation-slot-presentations for the same reason."))
145 (defmethod present ((listing list-presentation
))
146 (<:table
:class
(css-class listing
)
147 (render-list-heading listing
)
149 (for element in
(instances listing
))
151 (render-list-row listing element index
))))
153 (defmethod render-list-heading ((listing list-presentation
))
154 (<:tr
:class
"presentation-list-heading-row"
156 (dolist (slot (slots listing
))
157 (<:th
:class
"presentation-list-heading-cell"
158 (<:as-html
(label slot
))))
161 (defmethod render-list-row ((listing list-presentation
) object index
)
162 (<:tr
:class
"item-row"
163 (<:td
:class
"index-number-cell"
164 (<:i
(<:as-html index
)))
165 (dolist (slot (slots listing
))
166 (<:td
:class
"data-cell" (present-slot slot object
)))
167 (<:td
:align
"center" :valign
"top"
168 (when (editablep listing
)
169 (let ((object object
))
170 (<ucw
:input
:type
"submit"
171 :action
(edit-from-listing listing object index
)
172 :value
(edit-label listing
))))
174 (when (deleteablep listing
)
176 (<ucw
:input
:type
"submit"
177 :action
(delete-from-listing listing object index
)
178 :value
(delete-label listing
)))))))
180 (defgeneric/cc create-from-listing
(listing))
182 (defmethod/cc create-from-listing
:after
((l list-presentation
))
183 (setf (instances l
) (get-all-instances l
)))
185 (defgeneric/cc delete-from-listing
(listing item index
))
187 (defmethod/cc delete-from-listing
:after
((l list-presentation
) item index
)
188 (declare (ignore item index
))
189 (setf (instances l
) (get-all-instances l
)))
191 (defgeneric/cc edit-from-listing
(listing item index
))
193 (defmethod/cc edit-from-listing
:after
((l list-presentation
) item index
)
194 (declare (ignore item index
))
195 (setf (instances l
) (get-all-instances l
)))
197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
198 ;;;; Searching/Filtering
200 (defcomponent presentation-search
(presentation)
201 ((criteria :accessor criteria
:initform
'())
202 (search-presentation :accessor search-presentation
:initarg
:search-presentation
203 :documentation
"The presentation object
204 used in determining what the possible
205 search options are.")
206 (list-presentation :accessor list-presentation
:initarg
:list-presentation
207 :documentation
"The presentation object used when showing the results.")))
209 (defgeneric applicable-criteria
(presentation)
210 (:method-combination nconc
))
212 (defmethod applicable-criteria nconc
((search presentation-search
))
213 (let ((criteria '()))
214 (dolist (slot (slots (search-presentation search
)))
215 (setf criteria
(append criteria
(applicable-criteria slot
))))
216 (cons (make-instance 'negated-criteria
:presentation search
)
219 (defcomponent criteria
()
220 ((presentation :accessor presentation
:initarg
:presentation
)))
222 (defaction add-criteria
((search presentation-search
) (criteria criteria
))
223 (push criteria
(criteria search
)))
225 (defaction drop-criteria
((search presentation-search
) (criteria criteria
))
226 (setf (criteria search
) (delete criteria
(criteria search
))))
228 (defgeneric apply-criteria
(criteria instance
)
229 (:method-combination and
))
231 (defmethod valid-instances ((search presentation-search
))
233 (dolist (i (get-all-instances search
))
234 (block apply-criteria
235 (dolist (criteria (criteria search
))
236 (unless (apply-criteria criteria i
)
237 (return-from apply-criteria nil
)))
241 (defcomponent search-results-list
(list-presentation)
242 ((search-presentation :accessor search-presentation
)))
244 (defmethod render-on ((res response
) (s presentation-search
))
246 (let ((listing (list-presentation s
)))
248 (<:tr
:class
"presentation-list-heading-row"
250 (dolist (slot (slots (list-presentation s
)))
251 (<:th
:class
"presentation-list-heading-cell"
252 (<:as-html
(label slot
))))
255 for object in
(valid-instances s
)
257 do
(<:tr
:class
"item-row"
258 (<:td
:class
"index-number-cell" (<:i
(<:as-html index
)))
259 (dolist (slot (slots (list-presentation s
)))
260 (<:td
:class
"data-cell" (present-slot slot object
)))
261 (<:td
:align
"center" :valign
"top"
262 (when (editablep listing
)
263 (let ((object object
))
264 (<ucw
:input
:type
"submit"
265 :action
(edit-from-search s object index
)
266 :value
(edit-label listing
))))
268 (when (deleteablep listing
)
270 (<ucw
:input
:type
"submit"
271 :action
(delete-from-search s object index
)
272 :value
(delete-label listing
)))))))))
273 (<:p
"Search Criteria:")
275 (render-criteria res s
)
276 (<:li
(<ucw
:input
:type
"submit" :action
(refresh-component s
)
279 (defmethod render-criteria ((res response
) (s presentation-search
))
281 (dolist (c (criteria s
))
282 (<:li
(render-on res c
)
284 (<ucw
:input
:action
(drop-criteria s c
) :type
"submit" :value
"eliminate"))))
285 (let ((new-criteria nil
))
286 (<:li
"Add Criteria: "
287 (<ucw
:select
:accessor new-criteria
288 (dolist (criteria (applicable-criteria s
))
289 (<ucw
:option
:value criteria
(<:as-html
(label criteria
)))))
290 (<ucw
:input
:type
"submit" :action
(add-criteria s new-criteria
)
293 (defgeneric/cc edit-from-search
(search object index
))
295 (defgeneric/cc delete-from-search
(search object index
))
299 (defcomponent negated-criteria
(criteria)
300 ((criteria :accessor criteria
:initform nil
)))
302 (defmethod label ((n negated-criteria
)) "Not:")
304 (defmethod render-on ((res response
) (n negated-criteria
))
307 (render-on res
(criteria n
))))
308 (let ((new-criteria nil
))
309 (<:p
"Set Criteria: "
310 (<ucw
:select
:accessor new-criteria
311 (dolist (criteria (applicable-criteria (presentation n
)))
312 (<ucw
:option
:value criteria
(<:as-html
(label criteria
)))))
313 (<ucw
:input
:type
"submit" :action
(setf (criteria n
) new-criteria
)
316 (defmethod apply-criteria and
((n negated-criteria
) instance
)
318 (not (apply-criteria (criteria n
) instance
))
321 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
322 ;;;; Slot presentations
324 (defcomponent slot-presentation
(presentation)
325 ((label :accessor label
:initarg
:label
)
326 (label-plural :accessor label-plural
:initarg
:label-plural
)
327 (getter :accessor getter
:initarg
:getter
328 :documentation
"A function used for getting the
329 current value of the object. It will be passed the
330 objcet and must return the current value.")
331 (setter :accessor setter
:initarg
:setter
332 :documentation
"A function used for updatig the value of
333 the underlying object. It will be passed the new
334 value and the object (in that order).")
335 (editablep :accessor editablep
:initarg
:editablep
:initform t
)
336 (print-object-label)))
338 (defmethod print-object ((s slot-presentation
) stream
)
341 (print-unreadable-object (s stream
:type t
:identity t
)
342 (princ (label s
) stream
)
344 (princ (slot-value s
'print-object-label
) stream
)
345 (princ ")" stream
))))
347 (defgeneric present-slot
(slot instance
))
349 (defmethod initialize-instance :after
((presentation slot-presentation
)
350 &key slot-name getter setter
&allow-other-keys
)
352 (setf (slot-value presentation
'print-object-label
) slot-name
)
353 (setf (slot-value presentation
'print-object-label
) getter
))
355 (assert (not (or getter setter
))
356 (slot-name getter setter
)
357 "Can't specify :GETTER and/or :SETTER alnog with :SLOT-NAME.")
358 (setf (getter presentation
) (lambda (object)
359 (when (slot-boundp object slot-name
)
360 (slot-value object slot-name
)))
361 (setter presentation
) (lambda (value object
)
362 (setf (slot-value object slot-name
) value
)))))
364 (defvar *presentation-slot-type-mapping
* (make-hash-table :test
'eql
))
366 (defun register-slot-type-mapping (name class-name
)
367 (setf (gethash name
*presentation-slot-type-mapping
*) class-name
))
369 (defmacro defslot-presentation
(name supers slots
&rest options
)
371 (defcomponent ,name
,(or supers
`(slot-presentation))
373 ,@(remove :type-name options
:key
#'car
))
374 ,(let ((type-name (assoc :type-name options
)))
376 `(register-slot-type-mapping ',(second type-name
) ',name
)))
379 (defgeneric presentation-slot-value
(slot instance
)
380 (:method
((slot slot-presentation
) instance
)
381 (funcall (getter slot
) instance
)))
383 (defgeneric (setf presentation-slot-value
) (value slot instance
)
384 (:method
(value (slot slot-presentation
) instance
)
385 (funcall (setter slot
) value instance
)))
387 (defmethod applicable-criteria nconc
((s slot-presentation
))
390 (defmacro criteria-for-slot-presentation
(slot &body criteria-clauses
)
393 ,@(mapcar (lambda (criteria-clause)
394 (let ((criteria-clause (ensure-list criteria-clause
)))
395 `(make-instance ',(first criteria-clause
)
396 ,@(cdr criteria-clause
)
397 :presentation
,slot
)))
400 (defmacro defslot-critera
(class-name supers slots
&key label apply-criteria
)
401 (with-unique-names (obj instance
)
404 `(defcomponent ,class-name
,supers
,slots
)
406 `(defmethod label ((,obj
,class-name
))
407 (format nil
,label
(label (presentation ,obj
)))))
410 `(defmethod apply-criteria and
((,obj
,class-name
) ,instance
)
411 (funcall ,apply-criteria
414 (presentation-slot-value (presentation ,obj
) ,instance
))))
415 `(quote ,class-name
))))
417 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
420 (defslot-presentation boolean-slot-presentation
()
422 (:type-name boolean
))
424 (defmethod present-slot ((slot boolean-slot-presentation
) instance
)
425 (<ucw
:input
:type
"checkbox" :accessor
(presentation-slot-value slot instance
))
426 (setf (presentation-slot-value slot instance
) nil
))
428 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
431 (defslot-presentation string-slot-presentation
()
432 ((max-length :accessor max-length
:initarg
:max-length
:initform nil
)
433 (size :accessor size
:initarg
:size
:initform nil
))
436 (defmethod present-slot ((slot string-slot-presentation
) instance
)
438 (<ucw
:input
:type
"text"
439 :accessor
(presentation-slot-value slot instance
)
440 :size
(or (size slot
)
441 (if (string= "" (presentation-slot-value slot instance
))
443 (+ 3 (length (presentation-slot-value slot instance
)))))
444 :maxlength
(max-length slot
))
445 (<:as-html
(presentation-slot-value slot instance
))))
449 (defmethod applicable-criteria nconc
((s string-slot-presentation
))
450 (criteria-for-slot-presentation s
455 (defcomponent string-criteria
(criteria)
456 ((search-text :accessor search-text
:initform nil
)))
458 (defmethod render-on ((res response
) (criteria string-criteria
))
459 (<:as-html
(label criteria
) " ")
460 (<ucw
:input
:type
"text" :accessor
(search-text criteria
) :size
10))
462 (defslot-critera string-contains
(string-criteria)
464 :label
"~A contains:"
465 :apply-criteria
(lambda (criteria instance slot-value
)
466 (declare (ignore instance
))
467 (and (<= (length (search-text criteria
)) (length slot-value
))
468 (search (search-text criteria
) slot-value
:test
#'char-equal
))))
470 (defslot-critera string-starts-with
(string-contains)
472 :label
"~A starts with:"
473 :apply-criteria
(lambda (criteria instance slot-value
)
474 (declare (ignore instance
))
475 (and (<= (length (search-text criteria
)) (length slot-value
))
476 (= 0 (or (search (search-text criteria
) slot-value
480 (defslot-critera string-ends-with
(string-contains)
482 :label
"~A ends with:"
483 :apply-criteria
(lambda (criteria instance slot-value
)
484 (declare (ignore instance
))
485 (and (<= (length (search-text criteria
)) (length slot-value
))
486 (= (- (length slot-value
) (length (search-text criteria
)))
487 (or (search (search-text criteria
) slot-value
492 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
495 (defslot-presentation number-slot-presentation
()
496 ((min-value :accessor min-value
:initarg
:min-value
:initform nil
)
497 (max-value :accessor max-value
:initarg
:max-value
:initform nil
)))
499 (defcomponent number-criteria
(criteria)
500 ((number-input :accessor number-input
:initform nil
)))
502 (defmethod applicable-criteria nconc
((s number-slot-presentation
))
503 (criteria-for-slot-presentation s
508 (defmacro defnumber-criteria
(name &key label render-on-prefix apply-criteria
)
510 (defslot-critera ,name
(number-criteria)
513 :apply-criteria
(lambda (criteria instance slot-value
)
514 (declare (ignore instance
))
515 (if (numberp slot-value
)
516 (if (number-input criteria
)
517 (funcall ,apply-criteria slot-value
(number-input criteria
))
521 (defmethod render-on ((res response
) (obj ,name
))
522 (<:as-html
(format nil
,render-on-prefix
(label (presentation obj
))))
523 (<ucw
:input
:type
"text"
524 :reader
(or (number-input obj
) "")
526 (unless (string= "" v
)
527 (let ((n (parse-float v
)))
529 (setf (number-input obj
) n
)))))))))
531 (defnumber-criteria number-equal-to
532 :apply-criteria
(lambda (slot-value number-input
)
533 (= slot-value number-input
))
534 :label
"~A is equal to:"
535 :render-on-prefix
"~A = ")
537 (defnumber-criteria number-less-than
538 :apply-criteria
(lambda (slot-value number-input
)
539 (< slot-value number-input
))
540 :label
"~A is less than:"
541 :render-on-prefix
"~A < ")
543 (defnumber-criteria number-greater-than
544 :apply-criteria
(lambda (slot-value number-input
)
545 (> slot-value number-input
))
546 :label
"~A is greater than:"
547 :render-on-prefix
"~A > ")
550 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
553 (defslot-presentation integer-slot-presentation
(number-slot-presentation)
555 (:type-name integer
))
557 (defmethod presentation-slot-value ((slot integer-slot-presentation
) instance
)
558 (declare (ignore instance
))
559 (or (call-next-method) ""))
561 (defmethod (setf presentation-slot-value
) ((value string
) (slot integer-slot-presentation
) instance
)
562 (unless (string= "" value
)
563 (let ((i (parse-integer value
:junk-allowed t
)))
565 (setf (presentation-slot-value slot instance
) (parse-integer value
))))))
567 (defmethod present-slot ((slot integer-slot-presentation
) instance
)
569 (<ucw
:input
:type
"text"
570 :accessor
(presentation-slot-value slot instance
))
571 (<:as-html
(presentation-slot-value slot instance
))))
573 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
576 (defcomponent real-slot-presentation
(number-slot-presentation)
579 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
580 ;;;; Currency (double precision reals)
582 (defslot-presentation currency-slot-presentation
(real-slot-presentation)
584 (:type-name currency
))
586 (defmethod (setf presentation-slot-value
) ((value string
) (c currency-slot-presentation
) instance
)
587 (let ((*read-eval
* nil
))
588 (unless (string= "" value
)
589 (let ((value (read-from-string value
)))
590 (when (numberp value
)
591 (setf (presentation-slot-value c instance
) value
))))))
593 (defmethod present-slot ((currency currency-slot-presentation
) instance
)
594 (if (editablep currency
)
595 (<ucw
:input
:type
"text" :size
10
596 :accessor
(presentation-slot-value currency instance
))
597 (<:as-html
(presentation-slot-value currency instance
))))
599 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
602 (defslot-presentation timestamp-slot-presentation
(slot-presentation)
604 (:type-name timestamp
))
606 (defmacro deftimestamp-slot-accessor
(accessor time-accessor nth-value make-time-arg
)
607 (let ((accessor-name (intern (strcat '#:timestamp-slot- accessor
))))
609 (defgeneric ,accessor-name
(slot instance
))
610 (defgeneric (setf ,accessor-name
) (value slot instance
))
611 (defmethod ,accessor-name
((slot timestamp-slot-presentation
) instance
)
612 (when (presentation-slot-value slot instance
)
613 (nth-value ,nth-value
(,time-accessor
(presentation-slot-value slot instance
)))))
614 (defmethod (setf ,accessor-name
) ((value integer
) (slot timestamp-slot-presentation
) instance
)
615 (if (presentation-slot-value slot instance
)
616 (setf (presentation-slot-value slot instance
)
617 (make-time ,make-time-arg value
:defaults
(presentation-slot-value slot instance
)))
618 (setf (presentation-slot-value slot instance
) (make-time ,make-time-arg value
))))
619 (defmethod (setf ,accessor-name
) ((value string
) (slot timestamp-slot-presentation
) instance
)
620 (setf (,accessor-name slot instance
)
621 (if (string= "" value
)
623 (parse-integer value
))))
624 (defmethod (setf ,accessor-name
) ((value null
) (slot timestamp-slot-presentation
) instance
)
625 (setf (presentation-slot-value slot instance
) nil
)))))
627 (deftimestamp-slot-accessor second time-hms
2 :second
)
628 (deftimestamp-slot-accessor minute time-hms
1 :minute
)
629 (deftimestamp-slot-accessor hour time-hms
0 :hour
)
630 (deftimestamp-slot-accessor year time-ymd
0 :year
)
631 (deftimestamp-slot-accessor month time-ymd
1 :month
)
632 (deftimestamp-slot-accessor day time-ymd
2 :day
)
634 (defslot-presentation ymd-slot-presentation
(timestamp-slot-presentation)
638 (defmethod present-slot ((slot ymd-slot-presentation
) instance
)
641 (<ucw
:input
:class
(css-class slot
) :type
"text" :size
2
642 :accessor
(timestamp-slot-day slot instance
))
644 (<ucw
:input
:class
(css-class slot
) :type
"text" :size
2
645 :accessor
(timestamp-slot-month slot instance
))
647 (<ucw
:input
:class
(css-class slot
) :type
"text" :size
4
648 :accessor
(timestamp-slot-year slot instance
)))
649 (if (presentation-slot-value slot instance
)
651 (<:as-html
(timestamp-slot-day slot instance
))
653 (<:as-html
(timestamp-slot-month slot instance
))
655 (<:as-html
(timestamp-slot-year slot instance
)))
658 (defmethod applicable-criteria nconc
((slot ymd-slot-presentation
))
659 (criteria-for-slot-presentation slot
660 date-before-criteria
))
662 (defslot-critera date-before-criteria
(criteria)
663 ((target :accessor target
))
664 :label
"Date Before:")
666 (defmethod render-on ((res response
) (dbc date-before-criteria
))
667 (<:as-html
"Date Before: "))
669 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
672 (defcomponent relation-slot-presentation
(slot-presentation)
673 ((presentation :accessor presentation
674 :initarg
:presentation
675 :documentation
"The class of presentation
676 objects used to fill the options of a select
678 (search-presentation :accessor search-presentation
679 :initarg
:search-presentation
681 (allow-nil-p :accessor allow-nil-p
682 :initarg
:allow-nil-p
684 :documentation
"Can this relation not exist.")))
686 (defmethod presentation ((slot relation-slot-presentation
))
687 (with-slots (presentation)
689 (if (or (symbolp presentation
)
690 (consp presentation
))
691 (setf presentation
(apply #'make-instance
(ensure-list presentation
)))
694 (defgeneric get-foreign-instances
(pres instance
))
696 (defcomponent relation-criteria
(criteria presentation-search
)
697 ((criteria :accessor criteria
:initform
'())))
699 (defmethod search-presentation ((criteria relation-criteria
))
700 (or (search-presentation (presentation criteria
))
701 (presentation (presentation criteria
))))
705 (defslot-presentation one-of-presentation
(relation-slot-presentation)
706 ((none-label :initarg
:none-label
:accessor none-label
710 (defmethod present-slot ((slot one-of-presentation
) instance
)
712 (<ucw
:select
:accessor
(presentation-slot-value slot instance
)
713 (when (allow-nil-p slot
)
714 (<ucw
:option
:value nil
(<:as-html
(none-label slot
))))
715 (dolist (option (get-foreign-instances (presentation slot
) instance
))
716 (setf (instance (presentation slot
)) option
)
717 (<ucw
:option
:value option
(present (presentation slot
)))))
718 (if (presentation-slot-value slot instance
)
720 (setf (instance (presentation slot
)) (presentation-slot-value slot instance
))
721 (present (presentation slot
)))
724 (defmethod applicable-criteria nconc
((slot one-of-presentation
))
725 (criteria-for-slot-presentation slot
729 (defslot-critera one-of-criteria
(relation-criteria)
732 (defmethod label ((ooc one-of-criteria
))
733 (strcat (label (presentation ooc
)) " with:"))
735 (defmethod render-on ((res response
) (ooc one-of-criteria
))
736 (<:as-html
(label (presentation ooc
)) " with:")
737 (render-criteria res ooc
))
739 (defmethod apply-criteria and
((ooc one-of-criteria
) instance
)
740 (let ((nested-instance (presentation-slot-value (presentation ooc
) instance
))
741 (criteria (criteria ooc
)))
744 (dolist (c (criteria ooc
) t
)
745 (unless (apply-criteria c nested-instance
)
746 (return-from apply-criteria nil
)))
750 (defslot-critera one-of-not-null
(criteria)
753 (defmethod label ((oonn one-of-not-null
))
754 (strcat (label (presentation oonn
)) " exists."))
756 (defmethod apply-criteria and
((oonn one-of-not-null
) instance
)
757 (not (null (presentation-slot-value (presentation oonn
) instance
))))
759 (defmethod render-on ((res response
) (oonn one-of-not-null
))
760 (<:as-html
(label (presentation oonn
)) " exists."))
764 (defslot-presentation some-of-presentation
(relation-slot-presentation)
766 (:type-name some-of
))
768 (defmethod present-slot ((slot some-of-presentation
) instance
)
770 (if (presentation-slot-value slot instance
)
772 for option in
(presentation-slot-value slot instance
)
774 do
(let ((option option
) ;; loop changes the values, it does
775 ;; not create fresh bindings
780 (<:td
(setf (instance (presentation slot
)) option
)
781 (present (presentation slot
)))
782 (when (editablep slot
)
783 (<:td
:align
"left" :valign
"top"
784 (<ucw
:input
:type
"submit"
785 :action
(delete-element slot instance option index
)
786 :value
(concatenate 'string
"Delete " (label slot
))))))))))
788 (render-add-new-item slot instance
)))
790 (defmethod render-add-new-item ((slot some-of-presentation
) instance
)
791 (let ((new-object nil
)
792 (foreign-instances (get-foreign-instances (presentation slot
) instance
)))
793 (when (and foreign-instances
(editablep slot
))
795 (<ucw
:select
:accessor new-object
796 (dolist (option foreign-instances
)
797 (setf (instance (presentation slot
)) option
)
798 (<ucw
:option
:value option
(present (presentation slot
)))))
799 (<ucw
:input
:type
"submit"
800 :action
(add-element slot instance new-object
)
803 (defaction add-element
((some-of some-of-presentation
) instance item
)
804 (push item
(presentation-slot-value some-of instance
)))
806 (defaction delete-element
((some-of some-of-presentation
) instance item index
)
807 (let ((nth (nth index
(presentation-slot-value some-of instance
))))
808 (unless (eq nth item
)
809 (error "Attempting to delete the ~Dth item, which should be ~S, but the ~Dth item is actually ~S."
810 index item index nth
))
811 (setf (presentation-slot-value some-of instance
)
813 (for element in
(presentation-slot-value some-of instance
))
816 (collect element
))))))
818 (defmethod applicable-criteria nconc
((slot some-of-presentation
))
819 (criteria-for-slot-presentation slot
823 (defslot-critera some-of-criteria
(relation-criteria)
826 (defmethod render-on ((res response
) (soa some-of-criteria
))
827 (<:as-html
(label soa
))
828 (render-criteria res soa
))
830 (defmacro defsome-of-criteria
(name supers slots
&key label apply-criteria
)
831 (with-unique-names (obj)
833 (defslot-critera ,name
,supers
,slots
)
834 (defmethod label ((,obj
,name
))
835 (format nil
,label
(label (presentation ,obj
))))
836 (defmethod apply-criteria and
((,obj
,name
) instance
)
837 (let ((nested-instances (presentation-slot-value (presentation ,obj
) instance
))
838 (criteria (criteria ,obj
)))
841 (funcall ,apply-criteria
(criteria ,obj
) nested-instances
)
845 (defsome-of-criteria some-of-any
(some-of-criteria)
847 :label
"Any ~A with:"
848 :apply-criteria
(lambda (criteria nested-instances
)
849 ;; return T if any nested-instance meets all of criteria
850 (some (lambda (instance)
851 (every (lambda (criteria)
852 (apply-criteria criteria instance
))
856 (defsome-of-criteria some-of-all
(some-of-criteria)
858 :label
"All ~A with:"
859 :apply-criteria
(lambda (criteria nested-instances
)
860 ;; return T only if every nested-instances meets
861 ;; all of our criteria
862 (every (lambda (instance)
863 (every (lambda (criteria)
864 (apply-criteria criteria instance
))
870 (defslot-presentation an-object-presentation
(one-of-presentation)
872 (:type-name an-object
))
874 (defmethod present-slot ((slot an-object-presentation
) instance
)
875 (if (presentation-slot-value slot instance
)
877 (setf (instance (presentation slot
)) (presentation-slot-value slot instance
))
878 (present (presentation slot
))
879 (<ucw
:input
:type
"submit" :action
(delete-an-object slot instance
)
880 :value
(concatenate 'string
"Delete " (label slot
))))
881 (<ucw
:input
:type
"submit" :action
(create-an-object slot instance
) :value
"Create")))
883 (defaction delete-an-object
((slot an-object-presentation
) instance
)
884 (setf (presentation-slot-value slot instance
) nil
))
886 (defaction create-an-object
((slot an-object-presentation
) instance
)
887 (let ((obj (make-new-instance (presentation slot
) instance
)))
888 (format t
"Setting (presentation-slot-value ~S ~S) to ~S.~%" slot instance obj
)
889 (setf (presentation-slot-value slot instance
) obj
)))
893 (defslot-presentation some-objects-presentation
(some-of-presentation)
895 (:type-name some-objects
))
897 (defmethod render-add-new-item ((slot some-objects-presentation
) instance
)
898 (when (editablep slot
)
899 (<:li
(<ucw
:input
:type
"submit"
900 :action
(add-an-object slot instance
)
901 :value
"Add new object."))))
903 (defgeneric make-new-instance
(presentation instance
)
904 (:documentation
"Create an new instance suitable for
905 PRESENTATION which will be added to INSTANCE (according to
908 (defaction add-an-object
((slot some-objects-presentation
) instance
)
909 (push (make-new-instance (presentation slot
) instance
) (presentation-slot-value slot instance
)))
911 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
912 ;;;; Convience macros/functions
914 (defmacro slot-presentations
(&rest slot-specs
)
915 `(list ,@(mapcar (lambda (slot)
916 (let ((class-name (gethash (car slot
) *presentation-slot-type-mapping
*)))
918 `(make-instance ',class-name
,@(cdr slot
))
919 (error "Unknown slot type ~S." (car slot
)))))
922 (defmacro defpresentation
(name supers slots
&rest default-initargs
)
923 `(defcomponent ,name
,supers
926 ,@(when slots
`(:slots
(slot-presentations ,@slots
)))
927 ,@default-initargs
)))