Added standard descriptions and UCW integration.
[clinton/lisp-on-lines.git] / src / ucw / ucw-test.lisp
CommitLineData
4358148e 1(in-package :lol-test)
2
3(defclass lol-test-server (standard-server)
4 ())
5
6(defclass lol-test-application (standard-application)
7 ()
8 (:default-initargs
9 :url-prefix "/lisp-on-lines.test/"
10; :www-roots (list (cons "static/" (project-relative-pathname #P"wwwroot/")))
11))
12
13(defparameter *lol-test-ucw-application* (make-instance 'lol-test-application))
14
15(defun make-backend ()
16 (ucw::make-backend
17 :httpd
18 :host "localhost"
19 :port 9090))
20
21(defun make-server ()
22 (make-instance
23 'lol-test-server
24 :backend (make-backend)))
25
26(defparameter *lol-test-ucw-server* (make-server))
27
28(register-application *lol-test-ucw-server* *lol-test-ucw-application*)
29
30(defentry-point "index.ucw" (:application *lol-test-ucw-application*) ()
31 (call 'lol-test-window))
32
33(defun startup-lol-ucw-test ()
34 (startup-server *lol-test-ucw-server*))
35
36(defun shutdown-lol-ucw-test ()
37 (shutdown-server *lol-test-ucw-server*))
38
39(defcomponent lol-test-window (standard-window-component)
40 ()
41 (:default-initargs
42 :body (make-instance 'lol-test-suite-component)))
43
44(define-symbol-macro $window (lol-ucw:context.window-component *context*))
45
46(define-symbol-macro $body (window-body $window))
47
48(defcomponent lol-test-suite-component ()
49 ((test :component lol-test-simple-action :accessor test)
50 (component :component lol-test-render :accessor component)))
51
52(define-symbol-macro $test (test $body))
53
54(define-symbol-macro $component (component $body))
55
56(defmethod render ((self lol-test-suite-component))
57 (<:H1 "Lisp On Lines Web test suite")
58 (render (slot-value self 'test))
59 (<:div
60 :style "border:1px solid black;"
61 (render (slot-value self 'component))))
62
63(defcomponent lol-test-render ()
64 ((message :initform "test" :accessor message :initarg :message)))
65
66(defmethod render ((self lol-test-render))
67 (<:h3 :id "test-render"
68 (<:as-html (format nil "Hello ~A." (message self)))))
69
70(defcomponent lol-test-simple-action ()
71 ())
72
73(defmethod render ((self lol-test-simple-action))
74 (<:ul
75 (<:li (<lol:a
76 :function
77 (lambda ()
78 (setf (message $component)
79 (format nil "~A : ~A" (message $component) "FUNCTION")))
80 "Test <:A :FUNCTION type actions"))
81 (<:li
82 (<lol:a
83 :action (setf (message $component)
84 (format nil "~A : ~A" (message $component) "ACTION"))
85 "Test <:A :ACTION type actions"))
86 (<:li
87 (<lol:a
88 :action* (make-action
89 (lambda ()
90 (setf (message $component)
91 (format nil "~A : ~A" (message $component) "ACTION*"))))
92 "Test <:A :ACTION* type actions"))
93 (<:li
94 (<lol:a
95 :action (call-component $component (make-instance 'lol-test-answer))
96 "Test CALL/ANSWER"))
97 (<:li
98 (<lol:a
99 :action (call-component $component (make-instance 'lol-test-simple-form))
100 "Test Simple Form"))
101 (<:li
102 (<lol:a
103 :action (call-component $component (make-instance 'lol-test-multi-submit-form))
104 "Test Multi Form"))
105 (<:li
106 (<lol:a
107 :action (call-component $component (make-instance 'lol-test-input))
108 "Test Form input"))))
109
110(defcomponent lol-test-answer (lol-test-render) ()
111 (:default-initargs :message "CALL was ok. Go Back will answer"))
112
113(defmethod render :wrapping ((self lol-test-answer))
114 (call-next-method)
115 (<lol:a :action (answer-component self nil) "Go Back."))
116
117(defcomponent lol-test-simple-form (lol-test-render) ()
118 (:default-initargs :message "Testing Simple Form:"))
119
120(defmethod render :wrapping ((self lol-test-simple-form))
121 (call-next-method)
122 (<lol:form
123 :action (setf (message self) "Form Submitted")
124 (<:submit))
125 (<lol:a :action (answer-component self nil) "Go Back."))
126
127(defcomponent lol-test-multi-submit-form (lol-test-render) ()
128 (:default-initargs :message "Testing Simple Form:"))
129
130(defmethod render :wrapping ((self lol-test-multi-submit-form))
131 (call-next-method)
132 (<lol:form
133 :action (setf (message self) "Form Submitted")
134 (<:submit)
135 (<lol:submit :action (setf (message self) "Submit 2" )
136 :value "2")
137 (<lol:submit :action (setf (message self) "Submit 3")
138 3))
139 (<lol:a :action (answer-component self nil) "Go Back."))
140
141(defcomponent lol-test-input (lol-test-render)
142 ()
143 (:default-initargs :message "Testing INPUTS"))
144
145(defmethod render :wrapping ((self lol-test-input))
146 (call-next-method)
147 (<lol:form
148 :function (constantly t)
149 (<lol:input :type "text" :accessor (message self))
150
151 (<:submit)
152 )
153 (<lol:a :action (answer-component self nil) "Go Back."))
154
155
156
157
158
159
160
161