Commit | Line | Data |
---|---|---|
db3b46cb DC |
1 | (in-package :lol) |
2 | ||
a4e6154d DC |
3 | (defclass form-element (widget-component) |
4 | ((client-value :accessor client-value :initform "" | |
5 | :initarg :client-value | |
6 | :documentation "Whetever the client's browse sent for this form element." | |
7 | :backtrack t) | |
8 | (lisp-value :accessor lisp-value :initform +uninitialized+ | |
9 | :initarg :lisp-value | |
10 | :documentation "The current lisp object in this form element." | |
11 | :backtrack t)) | |
12 | (:metaclass standard-component-class) | |
13 | (:documentation "A single value in a form. | |
14 | ||
15 | A form-element is, simply put, a wrapper for a value in an html | |
16 | form.")) | |
17 | ||
db3b46cb DC |
18 | ;;;; Expiry date picker |
19 | ||
20 | (defslot-presentation date-slot-presentation (clsql-wall-time-slot-presentation) | |
21 | ((date-field :component (my-date-field :year-min 2005 :year-max 2015) | |
22 | :accessor date-field)) | |
23 | (:type-name date)) | |
24 | ||
25 | (defmethod update-value ((slot date-slot-presentation)) | |
26 | (multiple-value-bind (year month day) | |
27 | (time-ymd (presentation-slot-value slot (instance (ucw::parent slot)))) | |
28 | (multiple-value-bind (new-year new-month new-day) | |
29 | (time-ymd) | |
30 | (if (remove nil (map 'list #'(lambda (old new) | |
31 | (unless (equal (car old) (car new)) | |
32 | t)) | |
33 | (list year month day) | |
34 | (list new-year new-month new-day))) | |
35 | (setf (presentation-slot-value slot (instance (ucw::parent slot))) | |
36 | (make-time t)))))) | |
37 | ||
38 | (defmethod present-slot ((slot date-slot-presentation) instance) | |
39 | (let ((date (slot-value instance (slot-name slot)))) | |
40 | ;; Default values | |
41 | (when (and (not date) (default-to-now-p slot)) | |
42 | (setf date (clsql:get-time) | |
43 | (presentation-slot-value slot instance) date)) | |
44 | ;;simple viewer | |
45 | (if (and date (not (editablep slot))) | |
46 | (<:as-html date)) | |
47 | ;; editor | |
48 | (when (editablep slot) | |
49 | (with-slots ((m month) (y year)) | |
50 | (date-field slot) | |
51 | ||
52 | (multiple-value-bind (year month) (time-ymd date) | |
53 | (setf (lisp-value m) month | |
54 | (lisp-value y) year) | |
55 | (<ucw:render-component :component (date-field slot))))))) | |
56 | ||
57 | ||
58 | ||
59 | ||
bf12489a | 60 | (defcomponent %integer-range-field (integer-range-field) |
db3b46cb DC |
61 | ()) |
62 | ||
63 | (defmethod (setf lisp-value) :after (value (self %integer-range-field)) | |
64 | ()) | |
bf12489a DC |
65 | (defclass date-field (form-element) |
66 | ((day :component (integer-range-field :min-value 1 :max-value 31)) | |
67 | (month :component (integer-range-field :min-value 1 :max-value 12)) | |
68 | (year :component integer-range-field)) | |
69 | (:metaclass standard-component-class)) | |
70 | ||
71 | (defmethod shared-initialize :after ((field date-field) slot-names | |
72 | &key (year-min 1960) (year-max 2010)) | |
73 | (declare (ignore slot-names)) | |
74 | (setf (min-value (slot-value field 'year)) year-min | |
75 | (max-value (slot-value field 'year)) year-max | |
76 | (max-value (slot-value field 'day)) 31 | |
77 | (max-value (slot-value field 'month)) 12)) | |
78 | ||
79 | (defmethod read-client-value ((date date-field)) | |
80 | (with-slots (year month day) | |
81 | date | |
82 | (read-client-value year) | |
83 | (read-client-value month) | |
84 | (read-client-value day) | |
85 | (setf (lisp-value date) (encode-universal-time 0 0 0 | |
86 | (lisp-value day) | |
87 | (lisp-value month) | |
88 | (lisp-value year))))) | |
db3b46cb | 89 | |
bf12489a DC |
90 | |
91 | (defclass %date-field (date-field) | |
db3b46cb DC |
92 | ((day :component (%integer-range-field :min-value 1 :max-value 31)) |
93 | (month :component (%integer-range-field :min-value 1 :max-value 12)) | |
1e5d6797 | 94 | (year :component (%integer-range-field :min-value 2006 :max-value 2015) )) |
db3b46cb DC |
95 | (:metaclass standard-component-class)) |
96 | ||
97 | (defmethod shared-initialize :after ((field %date-field) slot-names | |
98 | &key (year-min 1960) (year-max 2010)) | |
99 | (declare (ignore slot-names year-min year-max)) | |
100 | (mapcar #'(lambda (x) (setf (slot-value (slot-value field x) 'ucw::parent) field)) | |
101 | '(year month day))) | |
102 | ||
103 | (defclass my-date-field (%date-field) | |
104 | () | |
105 | (:metaclass standard-component-class)) | |
106 | ||
107 | (defmethod present ((date my-date-field)) | |
108 | (with-slots (year month) | |
109 | date | |
110 | (<ucw:render-component :component month) | |
111 | "/" | |
112 | (<ucw:render-component :component year))) | |
113 | ||
bf12489a DC |
114 | |
115 | ||
116 | (defconstant +uninitialized+ '+uninitialized+ | |
117 | "The value used in UCW form elements to specify that there is no value. | |
118 | ||
119 | This obviously implies that you can't have a form element whose | |
120 | real value is +uninitialized+, since +uninitialized+ is a ucw | |
121 | internal symbol this shouldn't be a problem.") | |
122 | ||
bf12489a | 123 | |
bf12489a DC |
124 | |
125 | (defgeneric read-client-value (element) | |
126 | (:method ((element form-element)) | |
127 | (setf (lisp-value element) (client-value element)))) | |
128 | ||
129 | (defclass form-component (widget-component) | |
130 | () | |
131 | (:metaclass standard-component-class)) | |
132 | ||
133 | ;; remeber that actions are just methods | |
134 | (defgeneric/cc submit (form)) | |
135 | ||
136 | (defaction submit :before ((f form-component)) | |
137 | (iterate | |
138 | (with form-element-class = (find-class 'form-element)) | |
139 | (for slot in (mopp:class-slots (class-of f))) | |
140 | (for slot-name = (mopp:slot-definition-name slot)) | |
141 | (when (and (slot-boundp f slot-name) | |
142 | (subtypep (class-of (slot-value f slot-name)) form-element-class)) | |
143 | (read-client-value (slot-value f slot-name))))) | |
144 | ||
145 | (defaction submit ((f form-component)) t) | |
146 | ||
147 | ||
148 | (defclass select-field (form-element) | |
149 | ((options :accessor options :initform '() :initarg :options) | |
150 | (key :accessor key :initform #'identity :initarg :key) | |
151 | (test :accessor test :initform #'eql :initarg :test) | |
152 | (option-map :accessor option-map :initform (make-array 10 :adjustable t :fill-pointer 0)) | |
153 | (option-writer :accessor option-writer :initform #'princ-to-string)) | |
154 | (:metaclass standard-component-class)) | |
155 | ||
156 | (defmethod render-option ((select select-field) (object t)) | |
157 | (<:as-html (funcall (option-writer select) object))) | |
158 | ||
159 | (defmethod render ( (select select-field)) | |
160 | (setf (fill-pointer (option-map select)) 0) | |
161 | (<:select :name (make-new-callback (context.current-frame *context*) | |
162 | (lambda (v) (setf (client-value select) v))) | |
163 | (iterate | |
164 | (for o in (options select)) | |
165 | (for index upfrom 0) | |
166 | (vector-push-extend o (option-map select)) | |
167 | (<:option :value index | |
168 | :selected (funcall (test select) | |
169 | (funcall (key select) o) | |
170 | (funcall (key select) (lisp-value select))) | |
171 | (render-option res select o))))) | |
172 | ||
173 | (defmethod read-client-value ((select select-field)) | |
174 | (with-slots (lisp-value option-map client-value) | |
175 | select | |
176 | (setf lisp-value (aref option-map (parse-integer client-value))))) | |
177 | ||
178 | ;;;; Numbers from text inputs | |
179 | ||
180 | (defclass number-field (form-element) | |
181 | ((min-value :accessor min-value :initform nil :initarg :min-value) | |
182 | (max-value :accessor max-value :initform nil :initarg :max-value) | |
183 | (size :accessor size :initarg :size :initform 0) | |
184 | (maxlength :accessor maxlength :initarg :maxlength :initform 20)) | |
185 | (:metaclass standard-component-class)) | |
186 | ||
187 | (defmethod validate-form-element ((number number-field)) | |
188 | (with-slots (min-value max-value lisp-value) | |
189 | number | |
190 | (if (eql +uninitialized+ lisp-value) | |
191 | nil | |
192 | (if (numberp lisp-value) | |
193 | (cond | |
194 | ((and min-value max-value) | |
195 | (< min-value lisp-value max-value)) | |
196 | (min-value (< min-value lisp-value)) | |
197 | (max-value (< lisp-value max-value)) | |
198 | (t lisp-value)) | |
199 | nil)))) | |
200 | ||
201 | (defmethod read-client-value :around ((number number-field)) | |
202 | (unless (or (null (client-value number)) | |
203 | (string= "" (client-value number))) | |
204 | (ignore-errors ; returns NIL in case of SIMPLE-PARSE-ERROR | |
205 | (call-next-method)))) | |
206 | ||
207 | (defmethod render ( (n number-field)) | |
208 | (<ucw:input :type "text" :accessor (client-value n) | |
209 | :size (size n) | |
210 | :value (if (eql +uninitialized+ (lisp-value n)) | |
211 | "" | |
212 | (lisp-value n)) | |
213 | :maxlength (maxlength n))) | |
214 | ||
215 | (defclass decimal-field (number-field) | |
216 | ((precision :accessor precision :initarg :precision :initform nil | |
217 | :documentation "Number of significant digits.")) | |
218 | (:metaclass standard-component-class)) | |
219 | ||
220 | (defmethod read-client-value ((decimal number-field)) | |
221 | (setf (lisp-value decimal) (parse-float (client-value decimal)))) | |
222 | ||
223 | (defclass integer-field (number-field) | |
224 | () | |
225 | (:metaclass standard-component-class)) | |
226 | ||
227 | (defmethod read-client-value ((integer integer-field)) | |
228 | (setf (lisp-value integer) (parse-integer (client-value integer)))) | |
229 | ||
230 | (defclass integer-range-field (integer-field) | |
231 | () | |
232 | (:metaclass standard-component-class) | |
233 | (:default-initargs :min-value 1 :max-value 5)) | |
234 | ||
235 | (defmethod shared-initialize :after ((field integer-range-field) slot-names | |
236 | &rest initargs) | |
237 | (declare (ignore slot-names initargs)) | |
238 | (setf (lisp-value field) (min-value field))) | |
239 | ||
240 | (defmethod render ( (range integer-range-field)) | |
241 | (<:select :name (ucw::make-new-callback | |
242 | (lambda (v) (setf (client-value range) v))) | |
243 | (iterate | |
244 | (for value from (min-value range) to (max-value range)) | |
245 | (<:option :value value :selected (= value (lisp-value range)) | |
1e5d6797 | 246 | (<:as-html value))))) |