3 ;;;; Expiry date picker
5 (defslot-presentation date-slot-presentation
(clsql-wall-time-slot-presentation)
6 ((date-field :component
(my-date-field :year-min
2005 :year-max
2015)
10 (defmethod update-value ((slot date-slot-presentation
))
11 (multiple-value-bind (year month day
)
12 (time-ymd (presentation-slot-value slot
(instance (ucw::parent slot
))))
13 (multiple-value-bind (new-year new-month new-day
)
15 (if (remove nil
(map 'list
#'(lambda (old new
)
16 (unless (equal (car old
) (car new
))
19 (list new-year new-month new-day
)))
20 (setf (presentation-slot-value slot
(instance (ucw::parent slot
)))
23 (defmethod present-slot ((slot date-slot-presentation
) instance
)
24 (let ((date (slot-value instance
(slot-name slot
))))
26 (when (and (not date
) (default-to-now-p slot
))
27 (setf date
(clsql:get-time
)
28 (presentation-slot-value slot instance
) date
))
30 (if (and date
(not (editablep slot
)))
33 (when (editablep slot
)
34 (with-slots ((m month
) (y year
))
37 (multiple-value-bind (year month
) (time-ymd date
)
38 (setf (lisp-value m
) month
40 (<ucw
:render-component
:component
(date-field slot
)))))))
45 (defcomponent %integer-range-field
(integer-range-field)
48 (defmethod (setf lisp-value
) :after
(value (self %integer-range-field
))
50 (defclass date-field
(form-element)
51 ((day :component
(integer-range-field :min-value
1 :max-value
31))
52 (month :component
(integer-range-field :min-value
1 :max-value
12))
53 (year :component integer-range-field
))
54 (:metaclass standard-component-class
))
56 (defmethod shared-initialize :after
((field date-field
) slot-names
57 &key
(year-min 1960) (year-max 2010))
58 (declare (ignore slot-names
))
59 (setf (min-value (slot-value field
'year
)) year-min
60 (max-value (slot-value field
'year
)) year-max
61 (max-value (slot-value field
'day
)) 31
62 (max-value (slot-value field
'month
)) 12))
64 (defmethod read-client-value ((date date-field
))
65 (with-slots (year month day
)
67 (read-client-value year
)
68 (read-client-value month
)
69 (read-client-value day
)
70 (setf (lisp-value date
) (encode-universal-time 0 0 0
76 (defclass %date-field
(date-field)
77 ((day :component
(%integer-range-field
:min-value
1 :max-value
31))
78 (month :component
(%integer-range-field
:min-value
1 :max-value
12))
79 (year :component
(%integer-range-field
:min-value
2005 :max-value
2015) ))
80 (:metaclass standard-component-class
))
82 (defmethod shared-initialize :after
((field %date-field
) slot-names
83 &key
(year-min 1960) (year-max 2010))
84 (declare (ignore slot-names year-min year-max
))
85 (mapcar #'(lambda (x) (setf (slot-value (slot-value field x
) 'ucw
::parent
) field
))
88 (defclass my-date-field
(%date-field
)
90 (:metaclass standard-component-class
))
92 (defmethod present ((date my-date-field
))
93 (with-slots (year month
)
95 (<ucw
:render-component
:component month
)
97 (<ucw
:render-component
:component year
)))
101 (defconstant +uninitialized
+ '+uninitialized
+
102 "The value used in UCW form elements to specify that there is no value.
104 This obviously implies that you can't have a form element whose
105 real value is +uninitialized+, since +uninitialized+ is a ucw
106 internal symbol this shouldn't be a problem.")
108 (defclass form-element
(widget-component)
109 ((client-value :accessor client-value
:initform
""
110 :initarg
:client-value
111 :documentation
"Whetever the client's browse sent for this form element."
113 (lisp-value :accessor lisp-value
:initform
+uninitialized
+
115 :documentation
"The current lisp object in this form element."
117 (:metaclass standard-component-class
)
118 (:documentation
"A single value in a form.
120 A form-element is, simply put, a wrapper for a value in an html
123 (defgeneric read-client-value
(element)
124 (:method
((element form-element
))
125 (setf (lisp-value element
) (client-value element
))))
127 (defclass form-component
(widget-component)
129 (:metaclass standard-component-class
))
131 ;; remeber that actions are just methods
132 (defgeneric/cc submit
(form))
134 (defaction submit
:before
((f form-component
))
136 (with form-element-class
= (find-class 'form-element
))
137 (for slot in
(mopp:class-slots
(class-of f
)))
138 (for slot-name
= (mopp:slot-definition-name slot
))
139 (when (and (slot-boundp f slot-name
)
140 (subtypep (class-of (slot-value f slot-name
)) form-element-class
))
141 (read-client-value (slot-value f slot-name
)))))
143 (defaction submit
((f form-component
)) t
)
146 (defclass select-field
(form-element)
147 ((options :accessor options
:initform
'() :initarg
:options
)
148 (key :accessor key
:initform
#'identity
:initarg
:key
)
149 (test :accessor test
:initform
#'eql
:initarg
:test
)
150 (option-map :accessor option-map
:initform
(make-array 10 :adjustable t
:fill-pointer
0))
151 (option-writer :accessor option-writer
:initform
#'princ-to-string
))
152 (:metaclass standard-component-class
))
154 (defmethod render-option ((select select-field
) (object t
))
155 (<:as-html
(funcall (option-writer select
) object
)))
157 (defmethod render ( (select select-field
))
158 (setf (fill-pointer (option-map select
)) 0)
159 (<:select
:name
(make-new-callback (context.current-frame
*context
*)
160 (lambda (v) (setf (client-value select
) v
)))
162 (for o in
(options select
))
164 (vector-push-extend o
(option-map select
))
165 (<:option
:value index
166 :selected
(funcall (test select
)
167 (funcall (key select
) o
)
168 (funcall (key select
) (lisp-value select
)))
169 (render-option res select o
)))))
171 (defmethod read-client-value ((select select-field
))
172 (with-slots (lisp-value option-map client-value
)
174 (setf lisp-value
(aref option-map
(parse-integer client-value
)))))
176 ;;;; Numbers from text inputs
178 (defclass number-field
(form-element)
179 ((min-value :accessor min-value
:initform nil
:initarg
:min-value
)
180 (max-value :accessor max-value
:initform nil
:initarg
:max-value
)
181 (size :accessor size
:initarg
:size
:initform
0)
182 (maxlength :accessor maxlength
:initarg
:maxlength
:initform
20))
183 (:metaclass standard-component-class
))
185 (defmethod validate-form-element ((number number-field
))
186 (with-slots (min-value max-value lisp-value
)
188 (if (eql +uninitialized
+ lisp-value
)
190 (if (numberp lisp-value
)
192 ((and min-value max-value
)
193 (< min-value lisp-value max-value
))
194 (min-value (< min-value lisp-value
))
195 (max-value (< lisp-value max-value
))
199 (defmethod read-client-value :around
((number number-field
))
200 (unless (or (null (client-value number
))
201 (string= "" (client-value number
)))
202 (ignore-errors ; returns NIL in case of SIMPLE-PARSE-ERROR
203 (call-next-method))))
205 (defmethod render ( (n number-field
))
206 (<ucw
:input
:type
"text" :accessor
(client-value n
)
208 :value
(if (eql +uninitialized
+ (lisp-value n
))
211 :maxlength
(maxlength n
)))
213 (defclass decimal-field
(number-field)
214 ((precision :accessor precision
:initarg
:precision
:initform nil
215 :documentation
"Number of significant digits."))
216 (:metaclass standard-component-class
))
218 (defmethod read-client-value ((decimal number-field
))
219 (setf (lisp-value decimal
) (parse-float (client-value decimal
))))
221 (defclass integer-field
(number-field)
223 (:metaclass standard-component-class
))
225 (defmethod read-client-value ((integer integer-field
))
226 (setf (lisp-value integer
) (parse-integer (client-value integer
))))
228 (defclass integer-range-field
(integer-field)
230 (:metaclass standard-component-class
)
231 (:default-initargs
:min-value
1 :max-value
5))
233 (defmethod shared-initialize :after
((field integer-range-field
) slot-names
235 (declare (ignore slot-names initargs
))
236 (setf (lisp-value field
) (min-value field
)))
238 (defmethod render ( (range integer-range-field
))
239 (<:select
:name
(ucw::make-new-callback
240 (lambda (v) (setf (client-value range
) v
)))
242 (for value from
(min-value range
) to
(max-value range
))
243 (<:option
:value value
:selected
(= value
(lisp-value range
))
244 (<:as-html value
)))))