3 (in-package :lisp-on-lines
)
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
)
426 (let ((callback (ucw::make-new-callback
430 (setf (presentation-slot-value slot instance
) t
)
431 (setf (presentation-slot-value slot instance
) nil
))))))
432 (<:input
:type
"hidden" :name callback
:value
"DEFAULT")
433 (<:input
:type
"checkbox"
435 :checked
(slot-value instance
(slot-name slot
))))
437 (if (presentation-slot-value slot instance
)
441 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
444 (defslot-presentation string-slot-presentation
()
445 ((max-length :accessor max-length
:initarg
:max-length
:initform nil
)
446 (size :accessor size
:initarg
:size
:initform nil
))
449 (defmethod present-slot ((slot string-slot-presentation
) instance
)
451 (<ucw
:input
:type
"text"
452 :accessor
(presentation-slot-value slot instance
)
453 :size
(or (size slot
)
454 (if (string= "" (presentation-slot-value slot instance
))
456 (+ 3 (length (presentation-slot-value slot instance
)))))
457 :maxlength
(max-length slot
))
458 (<:as-html
(presentation-slot-value slot instance
))))
462 (defmethod applicable-criteria nconc
((s string-slot-presentation
))
463 (criteria-for-slot-presentation s
468 (defcomponent string-criteria
(criteria)
469 ((search-text :accessor search-text
:initform nil
)))
471 (defmethod render-on ((res response
) (criteria string-criteria
))
472 (<:as-html
(label criteria
) " ")
473 (<ucw
:input
:type
"text" :accessor
(search-text criteria
) :size
10))
475 (defslot-critera string-contains
(string-criteria)
477 :label
"~A contains:"
478 :apply-criteria
(lambda (criteria instance slot-value
)
479 (declare (ignore instance
))
480 (and (<= (length (search-text criteria
)) (length slot-value
))
481 (search (search-text criteria
) slot-value
:test
#'char-equal
))))
483 (defslot-critera string-starts-with
(string-contains)
485 :label
"~A starts with:"
486 :apply-criteria
(lambda (criteria instance slot-value
)
487 (declare (ignore instance
))
488 (and (<= (length (search-text criteria
)) (length slot-value
))
489 (= 0 (or (search (search-text criteria
) slot-value
493 (defslot-critera string-ends-with
(string-contains)
495 :label
"~A ends with:"
496 :apply-criteria
(lambda (criteria instance slot-value
)
497 (declare (ignore instance
))
498 (and (<= (length (search-text criteria
)) (length slot-value
))
499 (= (- (length slot-value
) (length (search-text criteria
)))
500 (or (search (search-text criteria
) slot-value
505 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
508 (defslot-presentation number-slot-presentation
()
509 ((min-value :accessor min-value
:initarg
:min-value
:initform nil
)
510 (max-value :accessor max-value
:initarg
:max-value
:initform nil
)))
512 (defcomponent number-criteria
(criteria)
513 ((number-input :accessor number-input
:initform nil
)))
515 (defmethod applicable-criteria nconc
((s number-slot-presentation
))
516 (criteria-for-slot-presentation s
521 (defmacro defnumber-criteria
(name &key label render-on-prefix apply-criteria
)
523 (defslot-critera ,name
(number-criteria)
526 :apply-criteria
(lambda (criteria instance slot-value
)
527 (declare (ignore instance
))
528 (if (numberp slot-value
)
529 (if (number-input criteria
)
530 (funcall ,apply-criteria slot-value
(number-input criteria
))
534 (defmethod render-on ((res response
) (obj ,name
))
535 (<:as-html
(format nil
,render-on-prefix
(label (presentation obj
))))
536 (<ucw
:input
:type
"text"
537 :reader
(or (number-input obj
) "")
539 (unless (string= "" v
)
540 (let ((n (parse-float v
)))
542 (setf (number-input obj
) n
)))))))))
544 (defnumber-criteria number-equal-to
545 :apply-criteria
(lambda (slot-value number-input
)
546 (= slot-value number-input
))
547 :label
"~A is equal to:"
548 :render-on-prefix
"~A = ")
550 (defnumber-criteria number-less-than
551 :apply-criteria
(lambda (slot-value number-input
)
552 (< slot-value number-input
))
553 :label
"~A is less than:"
554 :render-on-prefix
"~A < ")
556 (defnumber-criteria number-greater-than
557 :apply-criteria
(lambda (slot-value number-input
)
558 (> slot-value number-input
))
559 :label
"~A is greater than:"
560 :render-on-prefix
"~A > ")
563 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
566 (defslot-presentation integer-slot-presentation
(number-slot-presentation)
568 (:type-name integer
))
570 (defmethod presentation-slot-value ((slot integer-slot-presentation
) instance
)
571 (declare (ignore instance
))
572 (or (call-next-method) ""))
574 (defmethod (setf presentation-slot-value
) ((value string
) (slot integer-slot-presentation
) instance
)
575 (unless (string= "" value
)
576 (let ((i (parse-integer value
:junk-allowed t
)))
578 (setf (presentation-slot-value slot instance
) i
)))))
580 (defmethod present-slot ((slot integer-slot-presentation
) instance
)
582 (<ucw
:input
:type
"text"
583 :accessor
(presentation-slot-value slot instance
))
584 (<:as-html
(presentation-slot-value slot instance
))))
586 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
589 (defcomponent real-slot-presentation
(number-slot-presentation)
592 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
593 ;;;; Currency (double precision reals)
595 (defslot-presentation currency-slot-presentation
(real-slot-presentation)
596 ((as-money-p :accessor as-money-p
:initarg
:as-money-p
:initform nil
))
597 (:type-name currency
))
599 (defmethod (setf presentation-slot-value
) ((value string
) (c currency-slot-presentation
) instance
)
600 (let ((*read-eval
* nil
))
601 (unless (string= "" value
)
602 (let ((value (read-from-string value
)))
603 (when (numberp value
)
604 (setf (presentation-slot-value c instance
) value
))))))
606 (defmethod present-slot ((currency currency-slot-presentation
) instance
)
607 (if (editablep currency
)
608 (<ucw
:input
:type
"text" :size
10
609 :accessor
(presentation-slot-value currency instance
))
610 (<:as-html
(format nil
(if (as-money-p currency
)
613 (presentation-slot-value currency instance
)) )))
615 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
618 (defslot-presentation timestamp-slot-presentation
(slot-presentation)
620 (:type-name timestamp
))
622 (defmacro deftimestamp-slot-accessor
(accessor time-accessor nth-value make-time-arg
)
623 (let ((accessor-name (intern (strcat '#:timestamp-slot- accessor
))))
625 (defgeneric ,accessor-name
(slot instance
))
626 (defgeneric (setf ,accessor-name
) (value slot instance
))
627 (defmethod ,accessor-name
((slot timestamp-slot-presentation
) instance
)
628 (when (presentation-slot-value slot instance
)
629 (nth-value ,nth-value
(,time-accessor
(presentation-slot-value slot instance
)))))
630 (defmethod (setf ,accessor-name
) ((value integer
) (slot timestamp-slot-presentation
) instance
)
631 (if (presentation-slot-value slot instance
)
632 (setf (presentation-slot-value slot instance
)
633 (make-time ,make-time-arg value
:defaults
(presentation-slot-value slot instance
)))
634 (setf (presentation-slot-value slot instance
) (make-time ,make-time-arg value
))))
635 (defmethod (setf ,accessor-name
) ((value string
) (slot timestamp-slot-presentation
) instance
)
636 (setf (,accessor-name slot instance
)
637 (if (string= "" value
)
639 (parse-integer value
))))
640 (defmethod (setf ,accessor-name
) ((value null
) (slot timestamp-slot-presentation
) instance
)
641 (setf (presentation-slot-value slot instance
) nil
)))))
643 (deftimestamp-slot-accessor second time-hms
2 :second
)
644 (deftimestamp-slot-accessor minute time-hms
1 :minute
)
645 (deftimestamp-slot-accessor hour time-hms
0 :hour
)
646 (deftimestamp-slot-accessor year time-ymd
0 :year
)
647 (deftimestamp-slot-accessor month time-ymd
1 :month
)
648 (deftimestamp-slot-accessor day time-ymd
2 :day
)
650 (defslot-presentation ymd-slot-presentation
(timestamp-slot-presentation)
654 (defmethod present-slot ((slot ymd-slot-presentation
) instance
)
657 (<ucw
:input
:class
(css-class slot
) :type
"text" :size
2
658 :accessor
(timestamp-slot-day slot instance
))
660 (<ucw
:input
:class
(css-class slot
) :type
"text" :size
2
661 :accessor
(timestamp-slot-month slot instance
))
663 (<ucw
:input
:class
(css-class slot
) :type
"text" :size
4
664 :accessor
(timestamp-slot-year slot instance
)))
665 (if (presentation-slot-value slot instance
)
667 (<:as-html
(timestamp-slot-day slot instance
))
669 (<:as-html
(timestamp-slot-month slot instance
))
671 (<:as-html
(timestamp-slot-year slot instance
)))
674 (defmethod applicable-criteria nconc
((slot ymd-slot-presentation
))
675 (criteria-for-slot-presentation slot
676 date-before-criteria
))
678 (defslot-critera date-before-criteria
(criteria)
679 ((target :accessor target
))
680 :label
"Date Before:")
682 (defmethod render-on ((res response
) (dbc date-before-criteria
))
683 (<:as-html
"Date Before: "))
685 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
688 (defcomponent relation-slot-presentation
(slot-presentation)
689 ((presentation :accessor presentation
690 :initarg
:presentation
691 :documentation
"The class of presentation
692 objects used to fill the options of a select
694 (search-presentation :accessor search-presentation
695 :initarg
:search-presentation
697 (allow-nil-p :accessor allow-nil-p
698 :initarg
:allow-nil-p
700 :documentation
"Can this relation not exist.")))
702 (defmethod presentation ((slot relation-slot-presentation
))
703 (with-slots (presentation)
705 (if (or (symbolp presentation
)
706 (consp presentation
))
707 (setf presentation
(apply #'make-instance
(ensure-list presentation
)))
710 (defgeneric get-foreign-instances
(pres instance
))
712 (defcomponent relation-criteria
(criteria presentation-search
)
713 ((criteria :accessor criteria
:initform
'())))
715 (defmethod search-presentation ((criteria relation-criteria
))
716 (or (search-presentation (presentation criteria
))
717 (presentation (presentation criteria
))))
721 (defslot-presentation one-of-presentation
(relation-slot-presentation)
722 ((none-label :initarg
:none-label
:accessor none-label
726 (defmethod present-slot ((slot one-of-presentation
) instance
)
728 (<ucw
:select
:accessor
(presentation-slot-value slot instance
)
729 (when (allow-nil-p slot
)
730 (<ucw
:option
:value nil
(<:as-html
(none-label slot
))))
731 (dolist (option (get-foreign-instances (presentation slot
) instance
))
732 (setf (instance (presentation slot
)) option
)
733 (<ucw
:option
:value option
(present (presentation slot
)))))
734 (if (presentation-slot-value slot instance
)
736 (setf (instance (presentation slot
)) (presentation-slot-value slot instance
))
737 (present (presentation slot
)))
740 (defmethod applicable-criteria nconc
((slot one-of-presentation
))
741 (criteria-for-slot-presentation slot
745 (defslot-critera one-of-criteria
(relation-criteria)
748 (defmethod label ((ooc one-of-criteria
))
749 (strcat (label (presentation ooc
)) " with:"))
751 (defmethod render-on ((res response
) (ooc one-of-criteria
))
752 (<:as-html
(label (presentation ooc
)) " with:")
753 (render-criteria res ooc
))
755 (defmethod apply-criteria and
((ooc one-of-criteria
) instance
)
756 (let ((nested-instance (presentation-slot-value (presentation ooc
) instance
))
757 (criteria (criteria ooc
)))
760 (dolist (c (criteria ooc
) t
)
761 (unless (apply-criteria c nested-instance
)
762 (return-from apply-criteria nil
)))
766 (defslot-critera one-of-not-null
(criteria)
769 (defmethod label ((oonn one-of-not-null
))
770 (strcat (label (presentation oonn
)) " exists."))
772 (defmethod apply-criteria and
((oonn one-of-not-null
) instance
)
773 (not (null (presentation-slot-value (presentation oonn
) instance
))))
775 (defmethod render-on ((res response
) (oonn one-of-not-null
))
776 (<:as-html
(label (presentation oonn
)) " exists."))
780 (defslot-presentation some-of-presentation
(relation-slot-presentation)
782 (:type-name some-of
))
784 (defmethod present-slot ((slot some-of-presentation
) instance
)
786 (if (presentation-slot-value slot instance
)
788 for option in
(presentation-slot-value slot instance
)
790 do
(let ((option option
) ;; loop changes the values, it does
791 ;; not create fresh bindings
796 (<:td
(setf (instance (presentation slot
)) option
)
797 (present (presentation slot
)))
798 (when (editablep slot
)
799 (<:td
:align
"left" :valign
"top"
800 (<ucw
:input
:type
"submit"
801 :action
(delete-element slot instance option index
)
802 :value
(concatenate 'string
"Delete " (label slot
))))))))))
804 (render-add-new-item slot instance
)))
806 (defmethod render-add-new-item ((slot some-of-presentation
) instance
)
807 (let ((new-object nil
)
808 (foreign-instances (get-foreign-instances (presentation slot
) instance
)))
809 (when (and foreign-instances
(editablep slot
))
811 (<ucw
:select
:accessor new-object
812 (dolist (option foreign-instances
)
813 (setf (instance (presentation slot
)) option
)
814 (<ucw
:option
:value option
(present (presentation slot
)))))
815 (<ucw
:input
:type
"submit"
816 :action
(add-element slot instance new-object
)
819 (defaction add-element
((some-of some-of-presentation
) instance item
)
820 (push item
(presentation-slot-value some-of instance
)))
822 (defaction delete-element
((some-of some-of-presentation
) instance item index
)
823 (let ((nth (nth index
(presentation-slot-value some-of instance
))))
824 (unless (eq nth item
)
825 (error "Attempting to delete the ~Dth item, which should be ~S, but the ~Dth item is actually ~S."
826 index item index nth
))
827 (setf (presentation-slot-value some-of instance
)
829 (for element in
(presentation-slot-value some-of instance
))
832 (collect element
))))))
834 (defmethod applicable-criteria nconc
((slot some-of-presentation
))
835 (criteria-for-slot-presentation slot
839 (defslot-critera some-of-criteria
(relation-criteria)
842 (defmethod render-on ((res response
) (soa some-of-criteria
))
843 (<:as-html
(label soa
))
844 (render-criteria res soa
))
846 (defmacro defsome-of-criteria
(name supers slots
&key label apply-criteria
)
847 (with-unique-names (obj)
849 (defslot-critera ,name
,supers
,slots
)
850 (defmethod label ((,obj
,name
))
851 (format nil
,label
(label (presentation ,obj
))))
852 (defmethod apply-criteria and
((,obj
,name
) instance
)
853 (let ((nested-instances (presentation-slot-value (presentation ,obj
) instance
))
854 (criteria (criteria ,obj
)))
857 (funcall ,apply-criteria
(criteria ,obj
) nested-instances
)
861 (defsome-of-criteria some-of-any
(some-of-criteria)
863 :label
"Any ~A with:"
864 :apply-criteria
(lambda (criteria nested-instances
)
865 ;; return T if any nested-instance meets all of criteria
866 (some (lambda (instance)
867 (every (lambda (criteria)
868 (apply-criteria criteria instance
))
872 (defsome-of-criteria some-of-all
(some-of-criteria)
874 :label
"All ~A with:"
875 :apply-criteria
(lambda (criteria nested-instances
)
876 ;; return T only if every nested-instances meets
877 ;; all of our criteria
878 (every (lambda (instance)
879 (every (lambda (criteria)
880 (apply-criteria criteria instance
))
886 (defslot-presentation an-object-presentation
(one-of-presentation)
888 (:type-name an-object
))
890 (defmethod present-slot ((slot an-object-presentation
) instance
)
891 (if (presentation-slot-value slot instance
)
893 (setf (instance (presentation slot
)) (presentation-slot-value slot instance
))
894 (present (presentation slot
))
895 (<ucw
:input
:type
"submit" :action
(delete-an-object slot instance
)
896 :value
(concatenate 'string
"Delete " (label slot
))))
897 (<ucw
:input
:type
"submit" :action
(create-an-object slot instance
) :value
"Create")))
899 (defaction delete-an-object
((slot an-object-presentation
) instance
)
900 (setf (presentation-slot-value slot instance
) nil
))
902 (defaction create-an-object
((slot an-object-presentation
) instance
)
903 (let ((obj (make-new-instance (presentation slot
) instance
)))
904 (format t
"Setting (presentation-slot-value ~S ~S) to ~S.~%" slot instance obj
)
905 (setf (presentation-slot-value slot instance
) obj
)))
909 (defslot-presentation some-objects-presentation
(some-of-presentation)
911 (:type-name some-objects
))
913 (defmethod render-add-new-item ((slot some-objects-presentation
) instance
)
914 (when (editablep slot
)
915 (<:li
(<ucw
:input
:type
"submit"
916 :action
(add-an-object slot instance
)
917 :value
"Add new object."))))
919 (defgeneric make-new-instance
(presentation instance
)
920 (:documentation
"Create an new instance suitable for
921 PRESENTATION which will be added to INSTANCE (according to
924 (defaction add-an-object
((slot some-objects-presentation
) instance
)
925 (push (make-new-instance (presentation slot
) instance
) (presentation-slot-value slot instance
)))
927 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
928 ;;;; Convience macros/functions
930 (defmacro slot-presentations
(&rest slot-specs
)
931 `(list ,@(mapcar (lambda (slot)
932 (let ((class-name (gethash (car slot
) *presentation-slot-type-mapping
*)))
934 `(make-instance ',class-name
,@(cdr slot
))
935 (error "Unknown slot type ~S." (car slot
)))))
938 (defmacro defpresentation
(name supers slots
&rest default-initargs
)
939 `(defcomponent ,name
,supers
942 ,@(when slots
`(:slots
(slot-presentations ,@slots
)))
943 ,@default-initargs
)))