Massive patch to catch up to ucw_dev
[clinton/lisp-on-lines.git] / src / slot-presentations / date.lisp
CommitLineData
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