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 | ||
45 | (defcomponent %integer-range-field (ucw::integer-range-field) | |
46 | ()) | |
47 | ||
48 | (defmethod (setf lisp-value) :after (value (self %integer-range-field)) | |
49 | ()) | |
50 | ||
51 | ||
52 | ||
53 | (defclass %date-field (ucw::date-field) | |
54 | ((day :component (%integer-range-field :min-value 1 :max-value 31)) | |
55 | (month :component (%integer-range-field :min-value 1 :max-value 12)) | |
56 | (year :component (%integer-range-field :min-value 2005 :max-value 2015) )) | |
57 | (:metaclass standard-component-class)) | |
58 | ||
59 | (defmethod shared-initialize :after ((field %date-field) slot-names | |
60 | &key (year-min 1960) (year-max 2010)) | |
61 | (declare (ignore slot-names year-min year-max)) | |
62 | (mapcar #'(lambda (x) (setf (slot-value (slot-value field x) 'ucw::parent) field)) | |
63 | '(year month day))) | |
64 | ||
65 | (defclass my-date-field (%date-field) | |
66 | () | |
67 | (:metaclass standard-component-class)) | |
68 | ||
69 | (defmethod present ((date my-date-field)) | |
70 | (with-slots (year month) | |
71 | date | |
72 | (<ucw:render-component :component month) | |
73 | "/" | |
74 | (<ucw:render-component :component year))) | |
75 |