;; -*- lisp -*-

(in-package :ucw-forms)

;;;; * UCW Web Form Library

;;;; ** FORM-FIELDS

;;;; Every input (or a set of inputs which correspond to one "value")
;;;; are represented by a form-field instance.

(defclass form-field ()
  ((client-value :accessor client-value :initarg :client-value
                 :initform ""
                 :documentation "The string the client submitted along with this field.")
   (validators :accessor validators :initform '() :initarg :validators
               :documentation "List of validators which will be
               applied to this field.")
   (initially-validate :accessor initially-validate :initform t
		       :initarg :initially-validate
                       :documentation "When non-NIL the
                       validotars will be run as soon as the page
                       is rendered.")))

(defmethod shared-initialize :after ((field form-field)
                                     slot-names
                                     &key (value nil value-p) &allow-other-keys)
  (declare (ignore slot-names))
  (when value-p
    (setf (value field) value)))

(defprint-object (field form-field)
  (format *standard-output* "~S" (value field)))

(defgeneric form-field-p (object)
  (:method ((object form-field)) t)
  (:method ((object t)) nil))

(defgeneric value (form-field)
  (:documentation "The lispish translated value that represents the form-field."))

(defgeneric (setf value) (new-value form-field)
  (:documentation "Set the value of a form-field with translation to client."))

(defmethod value ((field form-field))
  (let ((client-value (client-value field)))
    (if (string= client-value "")
        nil
        client-value)))

(defmethod (setf value) (new-value (form-field form-field))
  (setf (client-value form-field) new-value))

(defclass html-input (form-field html-element-mixin)
  ((name :accessor name :initarg :name :initform nil)
   (accesskey :accessor accesskey :initarg :accesskey :initform nil)
   (tooltip :accessor tooltip :initarg :tooltip :initform nil)
   (tabindex :accessor tabindex :initarg :tabindex :initform nil)
   (ucw::dom-id :initform (unique-dom-id))))

;;;; ** Validators

(defclass validator ()
  ((message :accessor message :initarg :message :initform nil)))

(defgeneric validate (field validator)
  (:documentation "Validate a form-field with a validator."))

;;;; *** validp Top-level function to determine the validity of a form field
(defgeneric validp (form-field)
  (:documentation "Is a form-field valid?"))

(defmethod validp ((field form-field))
  (loop
     for validator in (validators field)
     when (null (validate field validator))
       collect validator into failed-validators
     finally (return (values (null failed-validators)
                             failed-validators))))

(defgeneric form-fields-of (component))

(defmethod form-fields-of ((component standard-component))
  "Return slot values of COMPONENT which are FORM-FIELDs"
  (remove-if-not #'ucw-forms::form-field-p
		 (mapcar (arnesi:curry #'slot-value component)
			 (remove-if-not #'(lambda (name) (slot-boundp component name))
					(mapcar #'c2mop:slot-definition-name
						(c2mop:class-slots (class-of component)))))))

(defmethod form-fields-of ((field form-field))
  (list field))

(defun default-validp (form)
  ;; Mostly yanked from ucw update (C) notices
  (flet ((do-validate-field (field)
           "Run validators on FIELD, return list of (FIELD . VALIDATOR) conses."
           (multiple-value-bind (validp failed) (validp field)
             (declare (ignore validp))
             (mapcar #'(lambda (failed) (cons field failed))
                     failed))))
    (let ((failed (apply #'nconc
                         (mapcar #'do-validate-field
                                 (form-fields-of form)))))
      (values (null failed) failed))))

(defmethod validp ((form standard-component))
  (default-validp form))

;;;; ** Standard Form Validators

;;;; *** not empty

(defclass not-empty-validator (validator)
  ())

(defmethod validate ((field form-field) (validator not-empty-validator))
  (and (client-value field)
       (not (string= "" (client-value field)))))

;;;; *** Value-validators

;;;; These are validators that should only be run if there is actually
;;;; a value to test.

(defclass value-validator (validator)
  ()
  (:documentation "Validators that should only be applied if there is a value.
That is, they always succeed on nil."))

(defmethod validate :around ((field form-field) (validator value-validator))
  "Value validators should only be checked if they are not null or empty-strings."
  (or (null (client-value field))
      (= 0 (length (string-trim '(#\Space #\Tab) (client-value field))))
      (call-next-method)))

;;;; *** length

(defclass length-validator (value-validator)
  ((min-length :accessor min-length :initarg :min-length
               :initform nil)
   (max-length :accessor max-length :initarg :max-length
               :initform nil)))

(defmethod initialize-instance :after ((self length-validator) &key length min-length max-length)
  (assert (or (null length)
              (and (null min-length)
                   (null max-length))))
  (setf (min-length self) length)
  (setf (max-length self) length))

(defmethod validate ((field form-field) (validator length-validator))
  (with-slots (min-length max-length)
      validator
    (let ((length (length (client-value field))))
      (cond
        ((and min-length max-length)
         (<= min-length length max-length))
        (min-length
         (<= min-length length))
        (max-length
         (<= length max-length))
        (t t)))))

;;;; *** same (string=) value

(defclass string=-validator (validator)
  ((other-field :accessor other-field :initarg :other-field))
  (:documentation "Ensures that a field is string= to another one."))

(defmethod validate ((field form-field) (validator string=-validator))
  (let ((value (value field))
        (other-value (value (other-field validator))))
    (string= value other-value)))

;;;; Regular expression validator.

(defclass regex-validator (value-validator)
  ((regex :accessor regex :initarg :regex :initform nil)))

(defmethod validate ((field form-field) (validator regex-validator))
  (let ((val (string-trim '(#\Space #\Tab) (value field)))
        (regex (regex validator)))
    (or (null regex)
        (cl-ppcre:scan regex val))))

;;;; *** simple e-mail address check.

(defclass e-mail-address-validator (regex-validator)
  ()
  (:default-initargs
   :regex "^([a-zA-Z0-9_\\.\\-\\%])+\\@([a-zA-Z0-9][a-zA-Z0-9\\-]*\\.)+([a-zA-Z0-9]{2,4})\\.?$"))

(defclass hostname-validator (regex-validator)
  ()
  (:default-initargs
   :regex "^([a-zA-Z0-9][a-zA-Z0-9\\-]*\\.)+([a-zA-Z0-9]{2,4})\\.?$"))

(defclass phone-number-validator (regex-validator)
  ()
  (:default-initargs
   :regex "^((\\+\\d{1,3}(-| |\\.)?\\(?\\d\\)?(-| |\\.)?\\d{1,3})|(\\(?\\d{2,3}\\)?))(-| |\\.)?(\\d{3,4})(-| |\\.)?(\\d{4})(( x| ext)\\d{1,5}){0,1}$" ))

;;;; ** Form Inputs

;;;; *** Textarea inputs

(defclass textarea-field (html-input)
  ((rows :accessor rows :initarg :rows :initform nil)
   (cols :accessor cols :initarg :cols :initform nil)))

(defmethod render ((field textarea-field))
  (<ucw:textarea :id (html-element.dom-id field)
                 :accessor (client-value field)
                 :rows (rows field)
                 :cols (cols field)
                 :title (tooltip field)
                 :tabindex (tabindex field)
                 :class (html-element.css-class field)
                 :style (html-element.css-style field)
		 (client-value field)))

;;;; *** Strings

(defclass string-field (html-input)
  ((input-size :accessor input-size
               :initarg :input-size
               :initform nil)
   (maxlength :accessor maxlength
              :initarg :maxlength
              :initform nil)))

(defmethod render ((field string-field))
  (<ucw:text :id (html-element.dom-id field)
             :accesskey (accesskey field)
             :accessor (client-value field)
             :title (tooltip field)
             :tabindex (tabindex field)
             :size (input-size field)
             :maxlength (maxlength field)
             :class (html-element.css-class field)
             :style (html-element.css-style field)))

;;;; **** Hidden Strings (passwords)

(defclass password-field (string-field)
  ())

(defmethod render ((field password-field))
  (<ucw:password :id (html-element.dom-id field)
                 :accesskey (accesskey field)
                 :accessor (client-value field)
                 :size (input-size field)
                 :title (tooltip field)
                 :tabindex (tabindex field)
                 :class (html-element.css-class field)
                 :style (html-element.css-style field)))

;;;; *** Hidden field

(defclass hidden-field (html-input)
  ()
  (:documentation "A widget representing a hidden input field."))

(defmethod render ((field hidden-field))
  (<ucw:input :id (html-element.dom-id field)
              :type "hidden"
	      :accessor (client-value field)
              :title (tooltip field)
              :tabindex (tabindex field)
              :class (html-element.css-class field)
              :style (html-element.css-style field)))

;;;; *** Numbers

(defclass number-field (string-field)
  ())

(defmethod (setf value) (new-value (field number-field))
  (let ((*print-radix* nil)
        (*print-base* 10))
    (setf (client-value field) (when new-value
                                 (format nil (if (integerp new-value) "~d" "~f") new-value)))))

(defmethod initialize-instance :after ((field number-field) &key)
  (push (make-instance 'is-a-number-validator)
        (validators field)))

;; KLUDGE this is, well, ...
(defun read-number (str)
  "Read a string from an untrusted source (don't eval anything)."
  (let ((*read-eval* nil)
        ;; avoid interning into random packages
        (*package* (make-package (gensym))))
    (unwind-protect
         (multiple-value-bind (value position)
             (read-from-string str)
           (when (numberp value)
             (values value position)))
      (delete-package *package*))))

(defmethod value ((field number-field) )
  (if (= 0 (length (client-value field)))
      nil
      (read-number (client-value field))))

(defclass is-a-number-validator (value-validator)
  ())

(defmethod validate ((field number-field) (validator is-a-number-validator))
  (let ((in-len (length (client-value field))))
    (multiple-value-bind (num len)
        (read-number (client-value field))
      (declare (ignore num))
      (= len in-len))))

(defclass value-range-validator (value-validator)
  ((min-value :accessor min-value :initarg :min-value :initform nil)
   (max-value :accessor max-value :initarg :max-value :initform nil)))

(defclass number-range-validator (value-range-validator is-a-number-validator)
  ())

(defmethod validate ((field number-field) (validator number-range-validator))
  (with-slots (min-value max-value)
      validator
    ;; we shouldn't try to see if it is in a numerical range if it
    ;; isn't a number.
    (and (call-next-method) ;; should be is-a-number-validator
         (<= (or min-value (1- (value field)))
             (value field)
             (or max-value (1+ (value field)))))))

;;;; *** Integers

(defclass integer-field (number-field)
  ())

(defmethod initialize-instance :after ((field integer-field) &key validators)
  (setf (validators field) (cons (make-instance 'is-an-integer-validator) validators)))

(defmethod value ((field integer-field))
  (parse-integer (client-value field) :junk-allowed t))

(defclass is-an-integer-validator (is-a-number-validator)
  ())

(defmethod validate ((field integer-field) (validator is-an-integer-validator))
  (let ((in-len (length (client-value field))))
    (multiple-value-bind (num len)
        (parse-integer (client-value field) :junk-allowed t)
      (and (= len in-len)
           (integerp num)))))

;;;; *** Ranges

(defclass range-field (html-input)
  ((min-field :accessor min-field-of)
   (max-field :accessor max-field-of)
   (separator :accessor separator-of :initarg :separator :initform " ... ")))

(defmethod render ((self range-field))
  (<:table
      (<:tr (<:td (render (min-field-of self)))
            (<:td (etypecase (separator-of self)
                    (string (<:as-html (separator-of self)))
                    (component (render (separator-of self)))))
            (<:td (render (max-field-of self))))))

(defmethod initialize-instance :after ((self range-field) &key field-type)
  (setf (min-field-of self) (make-instance field-type))
  (setf (max-field-of self) (make-instance field-type)))

(defmethod value ((self range-field))
  (cons (value (min-field-of self)) (value (max-field-of self))))

;;;; *** Dates

(defclass universal-time-based-date-field ()
  ()
  (:documentation "A date field that communicates with universal time (as in CLHS) through the value and (setf value) methods."))

;; (defclass local-time-based-date-field (form-field)
;;   ()
;;   (:documentation "A date field that accepts/provides local-time objects through the value and (setf value) methods."))

;; (defmethod (setf value) ((utime integer) (self local-time-based-date-field))
;;   (setf (value self) (local-time :universal utime)))

(defclass date-field (universal-time-based-date-field form-field
		     html-block-element-mixin)
  ((year :accessor year :initform (make-instance 'integer-field
                                                 :input-size 4
                                                 :validators (list
                                                              (make-instance 'number-range-validator
                                                                             :min-value 0
                                                                             :max-value nil))))
   (month :accessor month :initform (make-instance 'integer-field
                                                   :input-size 2
                                                   :validators (list (make-instance 'number-range-validator
                                                                                    :min-value 0
                                                                                    :max-value 12))))
   (day :accessor day :initform (make-instance 'integer-field
                                               :input-size 2
                                               :validators (list (make-instance 'number-range-validator
                                                                                :min-value 0
                                                                                :max-value 31)))))
  (:default-initargs :dom-id (unique-dom-id :prefix "_dfld")))

(defmethod date-ymd ((field date-field))
  (values (value (year field))
          (value (month field))
          (value (day field))))

(defmethod value ((field date-field))
  (multiple-value-bind (year month day)
      (date-ymd field)
    (if (and year month day)
        (encode-universal-time 0 0 0 day month year)
        nil)))

(defmethod (setf value) ((utime integer) (field date-field))
  (multiple-value-bind (second minute hour date month year day-of-week daylight-p zone)
      (decode-universal-time utime 0)
    (declare (ignore second minute hour day-of-week daylight-p zone))
    (setf (value (year field)) year)
    (setf (value (month field)) month)
    (setf (value (day field)) date)))

(defmethod validp ((form-field date-field))
  (default-validp form-field))

(defmethod form-fields-of ((field date-field))
  (list (year field) (month field) (day field)))

(defclass dmy-date-field (date-field)
  ()
  (:documentation "Date fields which orders the inputs day/month/year"))

(defmethod render ((field dmy-date-field))
  (render (day field))
  (<:as-html "/")
  (render (month field))
  (<:as-html "/")
  (render (year field)))

(defclass mdy-date-field (date-field)
  ()
  (:documentation "Date field which orders the inputs month/day/year"))

(defmethod render ((field mdy-date-field))
  (render (month field))
  (<:as-html "/")
  (render (day field))
  (<:as-html "/")
  (render (year field)))

(defclass is-a-date-validator (value-validator)
  ())

(defmethod validate ((field universal-time-based-date-field) (validator is-a-date-validator))
  (integerp (value field)))

;; (defmethod validate ((field local-time-based-date-field) (validator is-a-date-validator))
;;   (typep (value field) 'local-time))

(defclass is-a-date-time-validator (is-a-date-validator)
  ())

(defclass time-range-validator (is-a-date-time-validator value-range-validator)
  ())

(defmethod validate ((field universal-time-based-date-field) (validator time-range-validator))
  (let ((min-value (min-value validator))
        (max-value (max-value validator)))
    (and (call-next-method)
         (<= (or min-value (1- (value field)))
             (value field)
             (or max-value (1+ (value field)))))))

;; (defmethod validate ((field local-time-based-date-field) (validator time-range-validator))
;;   (let ((min-value (min-value validator))
;;         (max-value (max-value validator))
;;         (value (value field)))
;;     (and (call-next-method)
;;          (or (not min-value) (local-time<= min-value value))
;;          (or (not max-value) (local-time<= value max-value)))))

;;;; *** Select input fields

;;;; We generate lots of strings which are used as the values in
;;;; option tags, this variable, and the integer-to-string function,
;;;; prevent generating large amounts of throw away strings.

#+allegro ;; TODO: Fixes a bug in allegro, remove later when Franz has sorted this out
(excl:without-package-locks 
  (defun common-lisp:map-into (result-sequence function &rest sequences)
   (loop for index below (apply #'min 
                                (length result-sequence)
                                (mapcar #'length sequences))
         do (setf (elt result-sequence index)
                  (apply function
                         (mapcar #'(lambda (seq) (elt seq index))
                                 sequences))))
   result-sequence))

(defvar +string-index-cache+
  (map-into (make-array 50
                        :element-type 'string
                        :adjustable t)
            (let ((i -1))
              (lambda ()
                (princ-to-string (incf i))))))

(defun integer-to-string (i)
  (cond
    ((<= (length +string-index-cache+) i)
     (adjust-array +string-index-cache+ (1+ i))
     (setf (aref +string-index-cache+ i) (princ-to-string i)))
    ((null (aref +string-index-cache+ i))
     (setf (aref +string-index-cache+ i) (princ-to-string i)))
    (t
     (aref +string-index-cache+ i))))

(defclass select-field (html-input)
  ((data-set :accessor data-set :initarg :data-set
             :documentation "The values this select chooses
             from.")
   (test-fn :accessor test-fn :initarg :test-fn)
   (data-map :accessor data-map :initform '()
             :documentation "An alist mapping strings, used in
   the <:select's options, to field specific values in the data-set.
   This is an internal field which should only be accessed by render
   and value methods."))
  (:default-initargs :test-fn #'string=)
  (:documentation "Form field used for selecting one value from a
  list of available options."))

(defmethod value ((field select-field))
  (cdr (assoc (client-value field) (data-map field) :test #'string=)))

(defmethod (setf value) (new-value (field select-field))
  (unless (data-map field)
    (setf (data-map field) (build-data-map field)))
  (dolist* ((client-key . value) (data-map field))
    (when (test-select-field-value field new-value value)
      (setf (client-value field) client-key)
      (return-from value new-value)))
  new-value)

(defgeneric test-select-field-value (field new-value value)
  (:method ((field select-field) new-value value)
           (funcall (test-fn field) new-value value)))

(defgeneric build-data-map (field)
  (:documentation "Given FIELD's data-set returns an alist
  mapping strings to the values in FIELD's data-set. Each key in
  the returned alist must be unique."))

(defmethod build-data-map ((field select-field))
  (loop
     for value in (data-set field)
     for index upfrom 0
     collect (cons (integer-to-string index) value)))

(defmethod render ((field select-field))
  (<ucw:select
   :accessor (client-value field)
   :title (tooltip field)
   :id (html-element.dom-id field)
   :accesskey (accesskey field)
   :tabindex (tabindex field)
   :class (html-element.css-class field)
   :style (html-element.css-style field)
   (setf (data-map field) (build-data-map field))
   (dolist* ((key-string . value) (data-map field))
     (<ucw:option :value key-string
		  :selected  (string= (client-value field) key-string)
		  (render-value field value)))))

(defgeneric render-value (select-field value)
  (:documentation "This function will be passed each value in the field's
   data-set and must produce the body of the corresponding
   <:option tag."))

(defmethod render-value ((field select-field) (value null))
  ;; often you need a select-field that has a "nothing selected" element.
  ;; for convenience nil values are rendered as an empty element
  )

(defmethod render-value ((field select-field) (value t))
  "This default method just wraps princ-to-string in a <:as-html."
  (<:as-html value))

;;;; **** selecting from mappings

;;;; It often happens that you want to select a value based on the
;;;; corresponding key.

(defclass mapping-select-field (select-field)
  ()
  (:documentation "Class used when we want to chose the values of
  a certain mapping based on the keys. We render the keys in the
  select and return the corresponding value from the VALUE
  method."))

(defmethod render ((field mapping-select-field))
  (<ucw:select
   :accessor (client-value field)
   :title (tooltip field)
   :id (html-element.dom-id field)
   :accesskey (accesskey field)
   :tabindex (tabindex field)
   :class (html-element.css-class field)
   :style (html-element.css-style field)
   (setf (data-map field) (build-data-map field))
   (dolist* ((key-string . key) (data-map field))
    (<ucw:option :value key-string
		 :selected  (string= (client-value field) key-string)
		 (render-key field key)))))

(defclass hash-table-select-field (mapping-select-field)
  ())

(defmethod build-data-map ((field hash-table-select-field))
  (loop
     for key being the hash-keys of (data-set field)
     for index upfrom 0
     collect (cons (integer-to-string index) key)))

(defmethod value ((field hash-table-select-field))
  (gethash (call-next-method) (data-set field)))

(defclass alist-select-field (mapping-select-field)
  ()
  (:default-initargs :test-fn #'eql)
  (:documentation "Renders an alist of (key . value)'s so that
VALUE's are displayed <:as-html and KEY's are returned by the VALUE accessor."))

(defmethod build-data-map ((field alist-select-field))
  (iter (for entry in (data-set field))
        (for index upfrom 0)
        (collect (cons (integer-to-string index) entry))))

(defmethod test-select-field-value ((field alist-select-field) new-value value)
  (funcall (test-fn field) new-value (car value)))

(defmethod render-key ((field alist-select-field) entry)
  (<:as-html (cdr entry)))

(defmethod value ((field alist-select-field))
  (car (call-next-method)))

(defclass plist-select-field (mapping-select-field)
  ()
  (:default-initargs :test-fn #'eql)
  (:documentation "Renders a plist of (indicator1 value1 ...) so that
VALUE's are displayed <:as-html and INDICATOR's are returned by the value accessor."))

(defmethod build-data-map ((field plist-select-field))
  (loop
     for (key value) on (data-set field) by #'cddr
     for index upfrom 0
     collect (cons (integer-to-string index) (cons key value))))

(defmethod test-select-field-value ((field plist-select-field) new-value value)
  (funcall (test-fn field) new-value (car value)))

(defmethod render-key ((field plist-select-field) entry)
  (<:as-html (cdr entry)))

(defmethod value ((field plist-select-field))
  (car (call-next-method)))

;;;; *** Radio Buttons 

(defclass radio-group (html-input)
  ((value-widgets :accessor value-widgets :initform '()))
  (:default-initargs  
   ;; XXX: this is really really bad. there's no guarntee that we
   ;; don't already have a callback with this name :(
   :name (strcat "_r_" (random-string 10))))

(defmethod value ((group radio-group))
  (let ((index (parse-integer (client-value group) :junk-allowed t)))    
    (when index
      (value (nth index (value-widgets group))))))

(defmethod (setf value) (value (group radio-group))
  (setf (client-value group)
        (format nil "~D" (position value (value-widgets group) :key #'value :test #'eq))))

(defmethod shared-initialize :after ((group radio-group)
                                     slot-names
                                     &key (values nil values-p)
                                          (value nil value-p)
                                     &allow-other-keys)
  (declare (ignore slot-names))
  (when values-p
    (setf (value-widgets group) '())
    (map nil (curry #'add-value group) values)
    (when value-p
      (setf (value group) value))))

(defmethod add-value ((group radio-group) value)
  (push (make-instance 'radio-button
                       :value value
                       :group group)
        (value-widgets group))
  value)

(defmethod value-widget ((group radio-group) value)
  "Returns the widget associated with the value VALUE in GROUP."
  (find value (value-widgets group) :test #'eq :key #'value))

(defclass radio-button (html-input)
  ((value :accessor value :initarg :value)
   (group :accessor group :initarg :group
          :documentation "The RADIO-GROUP this button is a part
          of."))
  (:documentation "A widget representing a single radio
  button. Should be used in conjunction with a RADIO-GROUP."))

(defmethod render ((button radio-button))
  (register-callback (lambda (value)
                       (setf (client-value (group button)) value))
                     :id (name (group button)))
  (<:input :id (html-element.dom-id button)
           :accesskey (accesskey button)
           :title (tooltip button)
           :tabindex (tabindex button)
           :type "radio"
           :name (name (group button))
           :value (format nil "~D" (position button (value-widgets (group button))))
           :checked (eq (value (group button)) (value button))
           :class (html-element.css-class button)
           :style (html-element.css-style button)))

(defprint-object (button radio-button)
  (format *standard-output* "VALUE: ~S GROUP: ~S" (value button) (group button)))

;;;; *** Check box

(defclass checkbox-field (html-input)
  (
   (enabled-tooltip :initform nil :accessor enabled-tooltip-of :initarg :enabled-tooltip)
   (disabled-tooltip :initform nil :accessor disabled-tooltip-of :initarg :disabled-tooltip))
  (:default-initargs :client-value nil))

(defmethod initialize-instance :after ((self checkbox-field) &key)
  (setf (html-element.css-class self) (strcat (html-element.css-class self) " ucw-checkbox")))

(defgeneric hidden-id (checkbox-field)
  (:method ((self checkbox-field))
           (strcat (html-element.dom-id self) "-hidden")))

(defmethod rendered-form-fields ((self checkbox-field))
  (list (hidden-id self)))

(defmethod render ((field checkbox-field))
  (let* ((value (value field))
	 (dom-id (html-element.dom-id field))
         (hidden-id (hidden-id field)))
    (<ucw:input
     :id hidden-id
     :reader (when value
               "on")
     :writer (lambda (v)
               (setf (value field) (and (not (null v))
                                        (not (string= "" v)))))
     :type "hidden")
    (<:input
     :id dom-id
     :checked (if value t nil)
     :name (name field)
     :accesskey (accesskey field)
     :title (or (tooltip field) (if value
				    (enabled-tooltip-of field)
				    (disabled-tooltip-of field)))
     :tabindex (tabindex field)
     :class (html-element.css-class field)
     :style (html-element.css-style field)
     :type "checkbox")))

(defmethod value ((field checkbox-field))
  (if (and (client-value field)
           (not (string= "" (client-value field))))
      t
      nil))

(defmethod (setf value) (new-value (field checkbox-field))
  (setf (client-value field) (if new-value
                                 t
                                 nil)))

;;;; *** Upload

(defclass file-upload-field (html-input)
  ())

(defmethod render ((field file-upload-field))
  (<ucw:input :id (html-element.dom-id field)
	      :accesskey (accesskey field)
              :type "file"
              :title (tooltip field)
              :tabindex (tabindex field)
              :accessor (client-value field)
              :class (html-element.css-class field)
              :style (html-element.css-style field)))

(defmethod value ((field file-upload-field))
  (let ((client-value (client-value field)))
    (if (not (rfc2388-binary:mime-part-p client-value))
        nil
        client-value)))

;;;; *** Submit Button

(defclass submit-button (html-input)
  ((label :accessor label :initform nil :initarg :label)))

(defmethod render ((field submit-button))
  (<:submit :id (html-element.dom-id field)
	    :accesskey (accesskey field)
	    :title (tooltip field)
	    :tabindex (tabindex field)
	    :value (label field)
	    :class (html-element.css-class field)
	    :style (html-element.css-style field)))

(defcomponent form-component-mixin (html-element-mixin)
  ((submit-method :initform "post"
                  :accessor submit-method-of
                  :initarg :submit-method)
   (encoding-type :initform nil
                  :accessor encoding-type-of
                  :initarg :encoding-type))
  (:default-initargs :dom-id (unique-dom-id :prefix "form"))
  (:documentation "A component mixin that makes sure its body is
  rendered inside a HTML form tag."))

(defmethod render :wrap-around ((self form-component-mixin))
  (<ucw:form
   :class (html-element.css-class self)
   :style (html-element.css-style self)
   :method (submit-method-of self)
   :enctype (encoding-type-of self)
   :action (refresh-component self)
   (call-next-method)))

;; Copyright (c) 2003-2005 Edward Marco Baringer
;; Copyright (c) 2008 Clinton Ebadi
;; All rights reserved. 
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 
;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;;    of its contributors may be used to endorse or promote products
;;    derived from this software without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.