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)))))