fixes, enhancements, and more update-to-latest-ucw stuff. minor, all of it.
[clinton/lisp-on-lines.git] / src / slot-presentations / date.lisp
1 (in-package :lol)
2
3 ;;;; Expiry date picker
4
5 (defslot-presentation date-slot-presentation (clsql-wall-time-slot-presentation)
6 ((date-field :component (my-date-field :year-min 2005 :year-max 2015)
7 :accessor date-field))
8 (:type-name date))
9
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)
14 (time-ymd)
15 (if (remove nil (map 'list #'(lambda (old new)
16 (unless (equal (car old) (car new))
17 t))
18 (list year month day)
19 (list new-year new-month new-day)))
20 (setf (presentation-slot-value slot (instance (ucw::parent slot)))
21 (make-time t))))))
22
23 (defmethod present-slot ((slot date-slot-presentation) instance)
24 (let ((date (slot-value instance (slot-name slot))))
25 ;; Default values
26 (when (and (not date) (default-to-now-p slot))
27 (setf date (clsql:get-time)
28 (presentation-slot-value slot instance) date))
29 ;;simple viewer
30 (if (and date (not (editablep slot)))
31 (<:as-html date))
32 ;; editor
33 (when (editablep slot)
34 (with-slots ((m month) (y year))
35 (date-field slot)
36
37 (multiple-value-bind (year month) (time-ymd date)
38 (setf (lisp-value m) month
39 (lisp-value y) year)
40 (<ucw:render-component :component (date-field slot)))))))
41
42
43
44
45 (defcomponent %integer-range-field (integer-range-field)
46 ())
47
48 (defmethod (setf lisp-value) :after (value (self %integer-range-field))
49 ())
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))
55
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))
63
64 (defmethod read-client-value ((date date-field))
65 (with-slots (year month day)
66 date
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
71 (lisp-value day)
72 (lisp-value month)
73 (lisp-value year)))))
74
75
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))
81
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))
86 '(year month day)))
87
88 (defclass my-date-field (%date-field)
89 ()
90 (:metaclass standard-component-class))
91
92 (defmethod present ((date my-date-field))
93 (with-slots (year month)
94 date
95 (<ucw:render-component :component month)
96 "/"
97 (<ucw:render-component :component year)))
98
99
100
101 (defconstant +uninitialized+ '+uninitialized+
102 "The value used in UCW form elements to specify that there is no value.
103
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.")
107
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."
112 :backtrack t)
113 (lisp-value :accessor lisp-value :initform +uninitialized+
114 :initarg :lisp-value
115 :documentation "The current lisp object in this form element."
116 :backtrack t))
117 (:metaclass standard-component-class)
118 (:documentation "A single value in a form.
119
120 A form-element is, simply put, a wrapper for a value in an html
121 form."))
122
123 (defgeneric read-client-value (element)
124 (:method ((element form-element))
125 (setf (lisp-value element) (client-value element))))
126
127 (defclass form-component (widget-component)
128 ()
129 (:metaclass standard-component-class))
130
131 ;; remeber that actions are just methods
132 (defgeneric/cc submit (form))
133
134 (defaction submit :before ((f form-component))
135 (iterate
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)))))
142
143 (defaction submit ((f form-component)) t)
144
145
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))
153
154 (defmethod render-option ((select select-field) (object t))
155 (<:as-html (funcall (option-writer select) object)))
156
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)))
161 (iterate
162 (for o in (options select))
163 (for index upfrom 0)
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)))))
170
171 (defmethod read-client-value ((select select-field))
172 (with-slots (lisp-value option-map client-value)
173 select
174 (setf lisp-value (aref option-map (parse-integer client-value)))))
175
176 ;;;; Numbers from text inputs
177
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))
184
185 (defmethod validate-form-element ((number number-field))
186 (with-slots (min-value max-value lisp-value)
187 number
188 (if (eql +uninitialized+ lisp-value)
189 nil
190 (if (numberp lisp-value)
191 (cond
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))
196 (t lisp-value))
197 nil))))
198
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))))
204
205 (defmethod render ( (n number-field))
206 (<ucw:input :type "text" :accessor (client-value n)
207 :size (size n)
208 :value (if (eql +uninitialized+ (lisp-value n))
209 ""
210 (lisp-value n))
211 :maxlength (maxlength n)))
212
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))
217
218 (defmethod read-client-value ((decimal number-field))
219 (setf (lisp-value decimal) (parse-float (client-value decimal))))
220
221 (defclass integer-field (number-field)
222 ()
223 (:metaclass standard-component-class))
224
225 (defmethod read-client-value ((integer integer-field))
226 (setf (lisp-value integer) (parse-integer (client-value integer))))
227
228 (defclass integer-range-field (integer-field)
229 ()
230 (:metaclass standard-component-class)
231 (:default-initargs :min-value 1 :max-value 5))
232
233 (defmethod shared-initialize :after ((field integer-range-field) slot-names
234 &rest initargs)
235 (declare (ignore slot-names initargs))
236 (setf (lisp-value field) (min-value field)))
237
238 (defmethod render ( (range integer-range-field))
239 (<:select :name (ucw::make-new-callback
240 (lambda (v) (setf (client-value range) v)))
241 (iterate
242 (for value from (min-value range) to (max-value range))
243 (<:option :value value :selected (= value (lisp-value range))
244 (<:as-html value)))))