Commit | Line | Data |
---|---|---|
db3b46cb DC |
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 | ||
bf12489a | 45 | (defcomponent %integer-range-field (integer-range-field) |
db3b46cb DC |
46 | ()) |
47 | ||
48 | (defmethod (setf lisp-value) :after (value (self %integer-range-field)) | |
49 | ()) | |
bf12489a DC |
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))))) | |
db3b46cb | 74 | |
bf12489a DC |
75 | |
76 | (defclass %date-field (date-field) | |
db3b46cb DC |
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 | ||
bf12489a DC |
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))))) |