Major patch touching a lot, representing the new lol. is mostly drop-in backwards...
[clinton/lisp-on-lines.git] / src / ucw-test-component.lisp
1 (in-package :lisp-on-lines)
2
3 ;;;; LoL CLOS Test Class
4 (defclass lol-test-class ()
5 ((test-string :initform "test string"))
6 (:documentation "foo"))
7
8 (set-default-attributes 'lol-test-class)
9
10 (define-attributes (lol-test-class)
11 (test-string t :label "String :"))
12
13 (defcomponent test-component ()
14 ((display-types :accessor display-types :initform (list 'viewer 'editor 'creator 'one-line 'as-string))
15 (current-type :accessor current-type :initform 'viewer)
16 (instance :accessor instance :initform (make-instance 'test-class))))
17
18 (defmethod render ((self test-component))
19 (let ((test (instance self)))
20 (<:h1 (<:as-html "Lisp on Lines Test Component"))
21 (with-component (self)
22 (<ucw:form
23 :action (refresh-component self)
24 (<ucw:select :accessor (current-type self)
25 (dolist* (type (display-types self))
26 (<ucw:option :value type (<:as-html type))))
27 (<:input :type "Submit" :value "update")
28 (<:fieldset
29 (<:legend (<:as-html (current-type self)))
30 (display test :type (current-type self)))))
31
32 (<:div
33 (<:h2
34 (<:as-html "UCW Presentation based displays (the old school"))
35 (dolist (type '(:viewer :editor :creator :one-line :as-string))
36 (<:h3 (<:as-html type))
37 (present-view (test type self))
38 (<ucw:a :action (call-view (test type self))
39 (<:as-html "Call to " type))))))
40
41
42 (defcomponent standard-display-component ()
43 ((display-function :accessor display-function :initarg :display)))
44
45 (defmethod render ((self standard-display-component))
46 (funcall (display-function self) self))