4358148e |
1 | (in-package :lisp-on-lines) |
2 | |
81d70610 |
3 | (export '(html-description) (find-package :lisp-on-lines)) |
4358148e |
4 | |
b7657b86 |
5 | (defvar *escape-html* t) |
6 | |
46440824 |
7 | (defmethod generic-format ((display ucw-core:component) string &rest args) |
b7657b86 |
8 | (<:as-html (with-output-to-string (stream) |
9 | (apply #'call-next-method stream string args)))) |
10 | |
4358148e |
11 | (define-description html-description () |
81d70610 |
12 | ()) |
13 | |
81d70610 |
14 | (define-description t () |
6de8d300 |
15 | ((css-class :value "lol-description" :activep nil) |
4358148e |
16 | (dom-id :function (lambda (x) |
17 | (declare (ignore x)) |
18 | (symbol-name |
6de8d300 |
19 | (gensym "DOM-ID-"))) |
20 | :activep nil)) |
4358148e |
21 | (:in-description html-description)) |
22 | |
23 | (define-layered-class html-attribute () |
24 | ((css-class :accessor attribute-css-class |
25 | :initform "lol-attribute") |
2548f054 |
26 | (dom-id :accessor attribute-dom-id :initform nil) |
27 | (display-empty-label :accessor attribute-display-empty-label-p :initarg :display-empty-label-p :initform t))) |
4358148e |
28 | |
29 | (define-layered-class standard-attribute |
30 | :in-layer #.(defining-description 'html-description) |
31 | (html-attribute) |
32 | ()) |
33 | |
6de8d300 |
34 | (define-layered-function display-html-attribute-label (object attribute) |
35 | (:method (object attribute) |
2548f054 |
36 | |
6de8d300 |
37 | (let ((label (attribute-label attribute))) |
2548f054 |
38 | (when (or label (attribute-display-empty-label-p attribute)) |
39 | (<:td (<:label |
6de8d300 |
40 | :class "lol-attribute-label" |
41 | (when label |
42 | (<:as-html |
43 | (with-output-to-string (*display*) |
2548f054 |
44 | (display-attribute-label attribute))))))))) |
b7657b86 |
45 | (:method |
46 | :in-layer #.(defining-description 'inline) |
47 | (object attribute) |
48 | (let ((label (attribute-label attribute))) |
49 | (when label |
2548f054 |
50 | (<:as-html |
b7657b86 |
51 | (with-output-to-string (*display*) |
52 | (display-attribute-label attribute))))))) |
6de8d300 |
53 | |
54 | (define-layered-function display-html-attribute-value (object attribute) |
55 | (:method (object attribute) |
2548f054 |
56 | (<:td |
6de8d300 |
57 | :class "lol-attribute-value" |
e8d4fa45 |
58 | (<:as-html |
b7657b86 |
59 | (display-attribute-value attribute)))) |
60 | |
61 | (:method |
62 | :in-layer #.(defining-description 'inline) (object attribute) |
63 | (display-attribute-value attribute))) |
6de8d300 |
64 | |
65 | (define-layered-function display-html-attribute (object attribute) |
b7657b86 |
66 | |
6de8d300 |
67 | (:method (object attribute) |
2548f054 |
68 | (<:tr |
b7657b86 |
69 | :class (attribute-css-class attribute) |
70 | (when (attribute-dom-id attribute) |
71 | :id (attribute-dom-id attribute)) |
72 | (display-html-attribute-label object attribute) |
73 | (display-html-attribute-value object attribute))) |
74 | |
75 | (:method |
76 | :in-layer #.(defining-description 'inline) |
77 | (object attribute) |
78 | (<:span |
6de8d300 |
79 | :class (attribute-css-class attribute) |
80 | (when (attribute-dom-id attribute) |
81 | :id (attribute-dom-id attribute)) |
82 | (display-html-attribute-label object attribute) |
b7657b86 |
83 | (display-html-attribute-value object attribute)))) |
84 | |
85 | (define-layered-method display-using-description |
86 | :in-layer #.(defining-description 'html-description) |
87 | :around ((attribute standard-attribute) display object &rest args) |
88 | (declare (ignore args)) |
89 | (display-html-attribute object attribute)) |
90 | |
91 | |
2548f054 |
92 | (defun capture-description (attribute function) |
93 | (let ((obj (described-object (attribute-description attribute)))) |
94 | (lambda (&rest args) |
95 | (dletf (((described-object attribute) obj)) |
96 | (apply function args))))) |
97 | |
f4efa7ff |
98 | (defun make-attribute-value-writer (attribute) |
2548f054 |
99 | (let ((obj (described-object (attribute-description attribute))) |
100 | (value (attribute-value attribute))) |
f4efa7ff |
101 | (lambda (val) |
102 | (dletf (((described-object attribute) obj)) |
2548f054 |
103 | (with-active-descriptions (editable) |
104 | (unless (and (unbound-slot-value-p value) |
105 | (equal "" val)) |
106 | (setf (attribute-value attribute) |
107 | (parse-attribute-value attribute val)))))))) |
108 | |
f4efa7ff |
109 | |
2548f054 |
110 | (defmethod html-attribute-value (attribute) |
111 | (let ((val (attribute-value attribute))) |
112 | (if (unbound-slot-value-p val) |
113 | "" |
114 | val))) |
f4efa7ff |
115 | |
116 | (defmethod display-html-attribute-editor (attribute editor) |
46440824 |
117 | (<ucw:input :type "text" |
2548f054 |
118 | :reader (html-attribute-value attribute) |
f4efa7ff |
119 | :writer (make-attribute-value-writer attribute))) |
120 | |
2548f054 |
121 | (defmethod display-html-attribute-editor ((attribute slot-definition-attribute) editor) |
122 | (call-next-method)) |
123 | |
f4efa7ff |
124 | (defmethod display-html-attribute-editor (attribute (editor password-attribute-editor)) |
46440824 |
125 | (<ucw:input :type "password" |
2548f054 |
126 | :reader (html-attribute-value attribute) |
f4efa7ff |
127 | :writer (make-attribute-value-writer attribute))) |
128 | |
129 | |
ec6dde1e |
130 | |
131 | |
f4efa7ff |
132 | (define-layered-method display-attribute-editor |
133 | :in-layer #.(defining-description 'html-description) (attribute) |
134 | (display-html-attribute-editor attribute (attribute-editor attribute))) |
135 | |
6de8d300 |
136 | |
137 | (define-layered-method display-html-attribute-value |
138 | :in-layer #.(defining-description 'editable) (object attribute) |
139 | |
2548f054 |
140 | (<:td |
6de8d300 |
141 | :class "lol-attribute-value" |
f4efa7ff |
142 | (if (attribute-editp attribute) |
143 | (display-attribute-editor attribute) |
f4efa7ff |
144 | (call-next-method)))) |
6de8d300 |
145 | |
b7657b86 |
146 | (define-layered-function display-html-description (description display object &optional next-method) |
147 | (:method (description display object &optional (next-method #'display-using-description)) |
6de8d300 |
148 | (<:style |
149 | (<:as-html " |
81d70610 |
150 | |
2548f054 |
151 | |
152 | |
6de8d300 |
153 | div.lol-description .lol-attribute-label, |
154 | div.lol-description .lol-attribute-value { |
81d70610 |
155 | display: block; |
6de8d300 |
156 | width: 69%; |
81d70610 |
157 | float: left; |
6de8d300 |
158 | margin-bottom: 1em; |
2548f054 |
159 | border:1px solid black; |
81d70610 |
160 | |
161 | } |
6de8d300 |
162 | div.lol-description |
81d70610 |
163 | .lol-attribute-label { |
164 | text-align: right; |
165 | width: 24%; |
2548f054 |
166 | padding-right: 1em; |
81d70610 |
167 | } |
168 | |
2548f054 |
169 | span.lol-attribute-value .lol-attribute-value ( |
170 | border: 1px solid red;} |
171 | |
81d70610 |
172 | |
6de8d300 |
173 | div.lol-description |
81d70610 |
174 | br { |
175 | clear: left; |
2548f054 |
176 | } |
177 | |
178 | .clear {clear:left}" |
179 | |
180 | )) |
6de8d300 |
181 | |
182 | (with-attributes (css-class dom-id) description |
183 | |
81d70610 |
184 | |
2548f054 |
185 | (<:table |
b7657b86 |
186 | :class (list (attribute-value css-class) "lol-description" "t") |
187 | :id (attribute-value dom-id) |
2548f054 |
188 | (funcall next-method) |
189 | (<:br :class "clear"))))) |
6de8d300 |
190 | |
191 | |
192 | (define-layered-method display-html-description |
b7657b86 |
193 | :in-layer #.(defining-description 'inline) (description display object &optional next-method) |
6de8d300 |
194 | (with-attributes (css-class dom-id) description |
6de8d300 |
195 | (<:span |
b7657b86 |
196 | :class (list (attribute-value css-class) "lol-description") |
197 | :id (attribute-value dom-id) |
198 | (funcall next-method)))) |
199 | |
6de8d300 |
200 | |
201 | (define-display |
e8d4fa45 |
202 | :in-description html-description ((description t) |
46440824 |
203 | (display ucw-core:component) |
e8d4fa45 |
204 | object) |
b7657b86 |
205 | (display-html-description description display object (lambda () |
206 | (call-next-method)))) |
207 | |
2548f054 |
208 | (define-layered-method display-html-attribute-value |
209 | (object (attribute list-attribute)) |
ec6dde1e |
210 | (let ((val (attribute-value attribute))) |
211 | (when (listp val) |
212 | (<:ul |
213 | (arnesi:dolist* (item (attribute-value attribute)) |
46440824 |
214 | |
215 | (dletf (((attribute-object attribute) item)) |
216 | (<:li (apply #'display *display* item (slot-value attribute 'item-args))))))))) |