3 (defclass form-element
(widget-component)
4 ((client-value :accessor client-value
:initform
""
6 :documentation
"Whetever the client's browse sent for this form element."
8 (lisp-value :accessor lisp-value
:initform
+uninitialized
+
10 :documentation
"The current lisp object in this form element."
12 (:metaclass standard-component-class
)
13 (:documentation
"A single value in a form.
15 A form-element is, simply put, a wrapper for a value in an html
18 ;;;; Expiry date picker
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
))
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
)
30 (if (remove nil
(map 'list
#'(lambda (old new
)
31 (unless (equal (car old
) (car new
))
34 (list new-year new-month new-day
)))
35 (setf (presentation-slot-value slot
(instance (ucw::parent slot
)))
38 (defmethod present-slot ((slot date-slot-presentation
) instance
)
39 (let ((date (slot-value instance
(slot-name slot
))))
41 (when (and (not date
) (default-to-now-p slot
))
42 (setf date
(clsql:get-time
)
43 (presentation-slot-value slot instance
) date
))
45 (if (and date
(not (editablep slot
)))
48 (when (editablep slot
)
49 (with-slots ((m month
) (y year
))
52 (multiple-value-bind (year month
) (time-ymd date
)
53 (setf (lisp-value m
) month
55 (<ucw
:render-component
:component
(date-field slot
)))))))
60 (defcomponent %integer-range-field
(integer-range-field)
63 (defmethod (setf lisp-value
) :after
(value (self %integer-range-field
))
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
))
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))
79 (defmethod read-client-value ((date date-field
))
80 (with-slots (year month day
)
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
91 (defclass %date-field
(date-field)
92 ((day :component
(%integer-range-field
:min-value
1 :max-value
31))
93 (month :component
(%integer-range-field
:min-value
1 :max-value
12))
94 (year :component
(%integer-range-field
:min-value
2006 :max-value
2015) ))
95 (:metaclass standard-component-class
))
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
))
103 (defclass my-date-field
(%date-field
)
105 (:metaclass standard-component-class
))
107 (defmethod present ((date my-date-field
))
108 (with-slots (year month
)
110 (<ucw
:render-component
:component month
)
112 (<ucw
:render-component
:component year
)))
116 (defconstant +uninitialized
+ '+uninitialized
+
117 "The value used in UCW form elements to specify that there is no value.
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.")
125 (defgeneric read-client-value
(element)
126 (:method
((element form-element
))
127 (setf (lisp-value element
) (client-value element
))))
129 (defclass form-component
(widget-component)
131 (:metaclass standard-component-class
))
133 ;; remeber that actions are just methods
134 (defgeneric/cc submit
(form))
136 (defaction submit
:before
((f form-component
))
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
)))))
145 (defaction submit
((f form-component
)) t
)
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
))
156 (defmethod render-option ((select select-field
) (object t
))
157 (<:as-html
(funcall (option-writer select
) object
)))
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
)))
164 (for o in
(options select
))
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
)))))
173 (defmethod read-client-value ((select select-field
))
174 (with-slots (lisp-value option-map client-value
)
176 (setf lisp-value
(aref option-map
(parse-integer client-value
)))))
178 ;;;; Numbers from text inputs
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
))
187 (defmethod validate-form-element ((number number-field
))
188 (with-slots (min-value max-value lisp-value
)
190 (if (eql +uninitialized
+ lisp-value
)
192 (if (numberp lisp-value
)
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
))
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))))
207 (defmethod render ( (n number-field
))
208 (<ucw
:input
:type
"text" :accessor
(client-value n
)
210 :value
(if (eql +uninitialized
+ (lisp-value n
))
213 :maxlength
(maxlength n
)))
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
))
220 (defmethod read-client-value ((decimal number-field
))
221 (setf (lisp-value decimal
) (parse-float (client-value decimal
))))
223 (defclass integer-field
(number-field)
225 (:metaclass standard-component-class
))
227 (defmethod read-client-value ((integer integer-field
))
228 (setf (lisp-value integer
) (parse-integer (client-value integer
))))
230 (defclass integer-range-field
(integer-field)
232 (:metaclass standard-component-class
)
233 (:default-initargs
:min-value
1 :max-value
5))
235 (defmethod shared-initialize :after
((field integer-range-field
) slot-names
237 (declare (ignore slot-names initargs
))
238 (setf (lisp-value field
) (min-value field
)))
240 (defmethod render ( (range integer-range-field
))
241 (<:select
:name
(ucw::make-new-callback
242 (lambda (v) (setf (client-value range
) v
)))
244 (for value from
(min-value range
) to
(max-value range
))
245 (<:option
:value value
:selected
(= value
(lisp-value range
))
246 (<:as-html value
)))))