subclass UCW's form classes in the editor layer.
[clinton/lisp-on-lines.git] / src / standard-attributes.lisp
1 (in-package :lisp-on-lines)
2
3 ;;;; A few layers related to attributes
4 (deflayer omit-nil-attributes)
5
6 (defdisplay :in-layer omit-nil-attributes
7 :around ((attribute standard-attribute) object)
8 (when (attribute-value object attribute)
9 (call-next-method)))
10
11 (deflayer show-attribute-labels)
12
13 (defdisplay
14 :in-layer show-attribute-labels
15 :around ((attribute standard-attribute) object)
16
17 (<:span
18 :class "lol-label"
19 (<:as-html (or (label attribute) (attribute.name attribute)) " "))
20 (<:span
21 :class "lol-attribute"
22 (call-next-method)))
23
24 (deflayer use-pretty-labels)
25
26 (define-layered-method label
27 :in-layer use-pretty-labels
28 :around (standard-attribute)
29 (let ((label (call-next-method)))
30 (when label
31 (string-capitalize
32 (substitute #\Space #\- label)))))
33
34 (defattribute display ()
35 ()
36 (:documentation "Apply the display function to this object"))
37
38 (defdisplay ((attribute display) object)
39 (apply #'display self (attribute-value object attribute)
40 (description.properties attribute)))
41
42 ;;;; * Base Types
43
44 (defattribute base-attribute ()
45 ())
46
47 (defdisplay ((base base-attribute) object)
48 (<:as-html (attribute-value object base)))
49
50 (defattribute base-attribute (ucw::string-field)
51 ()
52 (:in-layer editor)
53 (:default-properties
54 :callback nil))
55
56 (defmethod ucw:client-value ((self base-attribute))
57 (attribute-value (object self) self))
58
59 (defmethod (setf ucw:client-value) (value (attribute base-attribute))
60 (setf (attribute-value (object attribute) attribute) value))
61
62
63 (defmethod render ((field base-attribute))
64 "this can only be used within a display-using-description call in the editor context,
65 it is a hack to integrate lol with ucw's new form stuff"
66 (call-next-method))
67
68 #+ (or)
69 (LET ((value (attribute-value (object field) field)))
70 (<:as-html "asd" value)
71 (<:input
72 :NAME
73 (callback field)
74 :VALUE (escape-as-html value)
75 :TYPE
76 "text"
77 :ID
78 (DOM-ID FIELD)
79 :SIZE
80 (ucw::INPUT-SIZE FIELD)))
81
82
83
84 (defdisplay
85 :in-layer editor ((string base-attribute) object)
86 (render string))
87
88
89 (defdisplay
90 :in-layer editor :around ((string base-attribute) object)
91 (dletf (((callback string) (ucw::make-new-callback
92 #'(lambda (val)
93 (setf (attribute-value object string) val))))
94 ((object string) object))
95 (call-next-method)))
96
97 ;;;; Strings
98
99 (defattribute string-attribute (base-attribute)
100 ()
101 (:type-name string)
102 (:default-properties
103 :escape-html-p t
104 :size nil
105 :max-length nil))
106
107 (defdisplay :in-layer omit-nil-attributes
108 :around ((attribute string-attribute) object)
109 (when (< 0 (length (attribute-value object attribute)))
110 (call-next-method)))
111
112 ;;;; default
113 (defdisplay :in-layer viewer
114 ((string string-attribute) object)
115 (if (escape-html-p string)
116 (<:as-html (attribute-value object string))
117 (<:as-is (attribute-value object string))))
118
119
120 ;;;; editor
121 (defattribute string-attribute (base-attribute)
122 ()
123 (:in-layer editor)
124 (:default-properties
125 :callback nil))
126
127
128 (defattribute string-search-attribute (string-attribute)
129 ()
130 (:default-properties
131 ;; the func that find search results
132
133 :search-action #'(lambda ()
134 (with-call/cc
135 nil))
136 ;; when chosing from a list of results, this function selects one.
137 :select-function (constantly t))
138 (:type-name string-search))
139
140 (defdisplay
141 :in-layer editor :after ((search string-search-attribute) object)
142 (<:input
143 :TYPE "submit"
144 :VALUE "search"
145 :ONCLICK
146 (JS:JS-INLINE*
147 `(PROGN
148 (IT.BESE.UCW::SET-ACTION-PARAMETER
149 ,(IT.BESE.UCW::MAKE-NEW-ACTION
150 (IT.BESE.UCW::CONTEXT.CURRENT-FRAME *CONTEXT*)
151 (search-action search)))
152 (RETURN T)))))
153
154 ;;;; textarea
155
156 (defattribute text-attribute (string-attribute)
157 ()
158 (:type-name text))
159
160 (defdisplay :in-layer editor ((string text-attribute) object)
161 (<:textarea
162 :id (id string)
163 :name (callback string)
164 (or (attribute-value object string) "")))
165
166
167
168 ;;;; WALL-TIME
169
170 (defattribute wall-time-attribute (string-attribute)
171 ()
172 (:type-name clsql-sys:wall-time))
173
174 (define-layered-method attribute-value (object (attribute wall-time-attribute))
175 (let ((date (call-next-method)))
176 (when date (multiple-value-bind (y m d) (clsql:time-ymd date)
177 (format nil "~a/~a/~a" m d y)))))
178
179 (defdisplay
180 ((time wall-time-attribute) object)
181 (<:as-html (attribute-value object time)))
182
183
184
185 (defattribute image ()
186 ()
187 (:default-properties
188 :css-class "lol-image"
189 :prefix "images/"))
190
191 (defdisplay ((buttons (eql 'image-editor-buttons)) object)
192 (<ucw:a :action (ok component object)
193 (<:as-html "select this image")))
194
195 (defdisplay ((image image) object)
196 (<:img
197 :class (or (css-class image) "lol-image")
198 :src (arnesi:strcat
199 (or (prefix image) "images/")
200 (escape-as-uri
201 (attribute-value object image)))))
202
203 (defdisplay
204 :in-layer editor ((image image) object)
205
206 (<:div
207 :class "lol-image-thumbnails"
208 (<:as-html "imagie")))
209
210
211
212
213
214