massive refactoring in preparation of release.
[clinton/lisp-on-lines.git] / src / ucw-test-component.lisp
1 (in-package :lisp-on-lines)
2
3 ;;;; LoL CLOS Tests
4 ;;;;
5 (defclass lol-test-class ()
6 ((test-slot-value :initform "slot-value")
7 (test-string :initform "Test String"))
8 (:documentation "foo"))
9
10 (defvar *foo* nil)
11
12 (defvar *standard-layers* '(viewer editor creator one-line as-string))
13
14 (define-attributes (lol-test-class)
15 (test-getter t
16 :label "Getter"
17 :getter (constantly "Hello World"))
18 (test-getter/setter t
19 :label "Getter/Setter:"
20 :getter (lambda ()
21 *foo*)
22 :setter #'(lambda (value)
23 (setf *foo* value)))
24 (test-slot-value t)
25 (test-string string :label "String" :documentation))
26
27 (defcomponent test-component ()
28 (current-layer :accessor current-type :initform 'viewer)
29 (layer-spec :accessor layer-spec :initform nil)
30 (instance :accessor instance :initform (make-instance 'test-class))))
31
32 (defmethod render ((self test-component))
33 (let ((test (instance self)))
34 (<:h1 (<:as-html "Lisp on Lines Test Component"))
35 (with-component (self)
36 (<ucw:form
37 :action (refresh-component self)
38 (<ucw:select :accessor (current-layer self)
39 (dolist* (type (display-types self))
40 (<ucw:option :value type (<:as-html type))))
41 (<:input :type "Submit" :value "update")
42 (<:fieldset
43 (<:legend (<:as-html (current-type self)))
44 (display test :type (current-type self)))))))
45
46
47 (defcomponent standard-display-component ()
48 ((display-function :accessor display-function :initarg :display)))
49
50 (defmethod render ((self standard-display-component))
51 (funcall (display-function self) self))