add support for lines to default display
[clinton/lisp-on-lines.git] / src / slot-presentations / date.lisp
CommitLineData
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
15A form-element is, simply put, a wrapper for a value in an html
16form."))
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
119This obviously implies that you can't have a form element whose
120real value is +uninitialized+, since +uninitialized+ is a ucw
121internal 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)))))