;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: src/components.lisp $

;;; Copyright (c) 2008, Andrea Chiumenti.  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.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; 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 AUTHOR 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.

(in-package :claw-html)

(defvar *id-and-static-id-description* "- :ID The htcomponent-client-id value. CLAW can transform its value to make it univocal
- :STATIC-ID Renders the id tag attribute, but the value is not managed as for the :ID keyword." 
"Description used for describing :ID and :STATIC-ID used in claw component init functions documentation
")

(defgeneric cform-rewinding-p (obj page-obj)
  (:documentation "Internal method to determine, during the rewinding phase, if the COMP has been fired for calling its action.
- OBJ the wcomponent instance
- PAGE-OBJ the wcomponent owner page"))

(defgeneric component-id-and-value (cinput)
  (:documentation "Returns the form component \(such as <input> and <select>) client-id and the associated value.
The value may be retrived from the http request by its name, from the associated reader or accessor when nil if no relative request parameter is set"))

(defgeneric label (cinput)
  (:documentation "Returns the label that describes the component. It's also be used when component validation fails. If it's a function it is funcalled"))

(defgeneric name-attr (cinput)
  (:documentation "Returns the name of the input component"))

(defun component-validation-errors (component)
  "Resurns possible validation errors occurred during form rewinding bound to a specific component"
  (let ((client-id (htcomponent-client-id component)))
    (getf *validation-errors* (intern client-id))))

;--------------------------------------------------------------------------------

(defgeneric action (_cform)
  (:documentation "Returns the action function for _CFORM subclasses
"))

(defgeneric action-object (_cform)
  (:documentation "Returns the object that will be applied to the ACTION function for a _CFORM subclass.
"))

(defgeneric form-method (_cform)
  (:documentation "Returns the method used to submit a <form> tag. 
This should be \"get\" or \"post\"."))

(defclass _cform (wcomponent)
    ((action :initarg :action
	     :accessor action
	     :documentation "Function performed after user submission")
     (action-object :initarg :action-object
                    :accessor action-object
                    :documentation "The object that will be applied to the ACTION accessor")
     (css-class :initarg :class
		:reader css-class
		:documentation "The html CLASS attribute")
     (method :initarg :method
             :reader form-method
             :documentation "Form post method (may be \"get\" or \"post\")")
     (execut-p :initform T
             :accessor cform-execute-p
             :documentation "When nil the form will never rewind an the CFORM-REWINDING-P will always be nil"))
  (:default-initargs :action nil :class nil :method "post" :action-object *claw-current-page*)
  (:documentation "Internal use component"))

(defclass _cform-mixin (_cform)
  ((validator :initarg :validator
	      :reader validator
	      :documentation "A function that accept the passed component value during submission and performs the validation logic."))
  (:default-initargs :validator nil)
  (:documentation "Internal use component"))


(defmethod htcomponent-rewind :before ((obj _cform) (pobj page))
  (let ((render-condition (htcomponent-render-condition obj)))
    (when (not (and render-condition (null (funcall render-condition))))
      (setf (cform-execute-p obj) t))))

(defmethod wcomponent-after-rewind ((obj _cform-mixin) (pobj page))
  (let ((validation-errors *validation-errors*)
	(action (action obj))
        (validator (validator obj)))
    (when (and (null validation-errors)
               action
               (cform-rewinding-p obj pobj))
      (when validator
	  (funcall validator obj))
      (unless *validation-errors*
        (funcall action (action-object obj))))))

(defmethod cform-rewinding-p ((cform _cform) (page page))
  (string= (htcomponent-client-id cform)
	   (page-req-parameter page *rewind-parameter*)))

(defclass cform (_cform-mixin)
  ()
  (:metaclass metacomponent)
  (:documentation "This component render as a FORM tag class, but it is aware of
the request cycle and is able to fire an action on rewind"))

(let ((class (find-class 'cform)))
  (closer-mop:ensure-finalized class)
  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
	(format nil "Description: ~a~%Parameters:~%~a~a~%~%~a"
		"Function that instantiates a CFORM component and renders a html <form> tag."
		*id-and-static-id-description*
		(describe-html-attributes-from-class-slot-initargs class)
		(describe-component-behaviour class))))


(defmethod wcomponent-template((cform cform))
  (let ((client-id (htcomponent-client-id cform))
	(class (css-class cform))
        (method (form-method cform))
	(validation-errors *validation-errors*))
    (when validation-errors
      (if (or (null class) (string= class ""))
	  (setf class "error")
	  (setf class (format nil "~a error" class))))
    (form> :static-id client-id
	   :class class
           :method method
	   (wcomponent-informal-parameters cform)
           (input> :name *rewind-form-parameter*
		   :type "hidden"
		   :value client-id)
	   (input> :name *rewind-parameter*
		   :type "hidden"
		   :value client-id)
	   (htcomponent-body cform))))

(defmethod cform-rewinding-p ((cform _cform-mixin) (page page))
  (and (cform-execute-p cform)
       (string= (htcomponent-client-id cform)
                (page-req-parameter page *rewind-parameter*))))

(defmethod htcomponent-rewind :before ((obj _cform-mixin) (pobj page))
  (let ((render-condition (htcomponent-render-condition obj))
        (id (htcomponent-client-id obj)))
    (when (and (not (and render-condition (null (funcall render-condition))))
               (string= id (page-req-parameter pobj *rewind-form-parameter*)))
      (setf (page-current-form pobj) obj))))

(defmethod wcomponent-after-rewind :after ((obj _cform-mixin) (pobj page))
  (setf (page-current-form pobj) nil))

(defmethod wcomponent-before-prerender ((obj _cform-mixin) (pobj page))
  (setf (page-current-form pobj) obj))

(defmethod wcomponent-after-prerender ((obj _cform-mixin) (pobj page))
  (setf (page-current-form pobj) nil))

(defmethod wcomponent-before-render ((obj _cform-mixin) (pobj page))
  (setf (page-current-form pobj) obj))

(defmethod wcomponent-after-render ((obj _cform-mixin) (pobj page))
  (setf (page-current-form pobj) nil))
;--------------------------------------------------------------------------------

(defgeneric action-link-parameters (action-link)
  (:documentation "A function that returns an ALIST of strings for optional request get parameters.
"))

(defclass action-link (_cform-mixin) 
  ((parameters :initarg :parameters
               :reader action-link-parameters
               :documentation "An alist of strings for optional request get parameters."))
  (:metaclass metacomponent)
  (:default-initargs :reserved-parameters (list :href) :parameters nil)
  (:documentation "This component behaves like a CFORM, firing it's associated action once clicked.
It renders as a normal link."))

(let ((class (find-class 'action-link)))
  (closer-mop:ensure-finalized class)
  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
	(format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a"
		"Instantiates an ACTION-LINK that renders an <a> link that cals a page method."
		*id-and-static-id-description*
		(describe-html-attributes-from-class-slot-initargs (find-class 'cform))
		(describe-html-attributes-from-class-slot-initargs class)
		(describe-component-behaviour class))))

(defmethod wcomponent-template((o action-link))
  (let* ((client-id (htcomponent-client-id o))
         (href (format nil "?~a=~a&~a=~a" *rewind-form-parameter* client-id *rewind-parameter* client-id))
         (params (action-link-parameters o)))
    (when (null client-id)
      (setf client-id ""))
    (a> :static-id client-id
	:href (if params
                  (format nil "~a~{&~a=~a~}" href params)
                  href)
	(wcomponent-informal-parameters o)
	(htcomponent-body o))))


;---------------------------------------------------------------------------------------
(defgeneric translated-value (base-cinput)
  (:documentation "Returns the component value using its translator"))

(defgeneric cinput-result-as-list-p (base-cinput)
  (:documentation "When not nil the associated request parameter will ba a list for the passed component
"))

(defgeneric css-class (base-cinput)
  (:documentation "Returns the html component class attribute for the given BASE-CINPUT
"))

(defclass base-cinput (wcomponent)
  ((result-as-list-p :initarg :multiple
		   :accessor cinput-result-as-list-p
		   :documentation "When not nil the associated request parameter will ba a list")
   (writer :initarg :writer
	   :reader cinput-writer
	  :documentation "Visit object slot writer symbol, used to write the input value to the visit object")
   (reader :initarg :reader
	     :reader cinput-reader
	     :documentation "Visit object slot reader symbol, used to get the corresponding value from the visit object")
   (accessor :initarg :accessor
	     :reader cinput-accessor
	     :documentation "Visit object slot accessor symbol. It can be used in place of the :READER and :WRITER parameters")
   (label :initarg :label
	  :documentation "The label is the description of the component. It's also be used when component validation fails.")
   (translator :initarg :translator
	       :reader translator
	       :documentation "A validator instance that encodes and decodes input values to and from the visit object mapped property")
   (validator :initarg :validator
	      :reader validator
	      :documentation "A function that accept the passed component value during submission and performs the validation logic.")
   (visit-object :initarg :visit-object
		 :reader cinput-visit-object
		 :documentation "The object hoding the property mapped to the current input html component. When nil the owner page is used.")
   (css-class :initarg :class
	      :reader css-class
	      :documentation "the html component class attribute")
   (name :initarg :name
         :reader base-cinput-name
         :documentation "When specified the name tag attribute, otherwise the given component id is used")
   (empty-to-null-p :initarg :empty-to-null-p
                    :reader base-cinput-empty-to-null-p
                    :documentation "When not NIL and empty string is threated as a NIL value"))
  (:default-initargs :name nil :multiple nil :writer nil :reader nil :accessor nil :class nil :empty-to-null-p t
		     :label nil :translator *simple-translator* :validator nil :visit-object *claw-current-page*)
  (:documentation "Class inherited from both CINPUT and CSELECT"))

(defmethod label ((cinput base-cinput))
  (let ((label (slot-value cinput 'label)))
    (if (functionp label)
        (funcall label)
        label)))

(defmethod name-attr ((cinput base-cinput))
  (or (base-cinput-name cinput)
      (htcomponent-client-id cinput)))

(defclass cinput (base-cinput)
    ((input-type :initarg :type
                 :reader input-type
                 :documentation "The html <input> TYPE attribute. For submit type, use the CSUBMIT> function."))
    (:metaclass metacomponent)
    (:default-initargs :reserved-parameters (list :value) :empty t :type "text")
    (:documentation "Request cycle aware component the renders as an INPUT tag class"))

(let ((class (find-class 'cinput)))
  (closer-mop:ensure-finalized class)
  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
	(format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a"
		"Function that instantiates a CINPUT component and renders a html <input> tag."
		*id-and-static-id-description*
		(describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
		(describe-html-attributes-from-class-slot-initargs class)
		(describe-component-behaviour class))))

(defmethod wcomponent-template ((cinput cinput))
  (let ((client-id (htcomponent-client-id cinput))
	(type (input-type cinput))
	(translator (translator cinput))
	(value "")
	(class (css-class cinput)))
    (when (component-validation-errors cinput)
      (if (or (null class) (string= class ""))
	  (setf class "error")
	  (setf class (format nil "~a error" class))))
    (setf value (translator-encode translator cinput))
    (input> :static-id client-id
	    :type type
	    :name (name-attr cinput)
	    :class class
	    :value value
	    (wcomponent-informal-parameters cinput))))

(defmethod translated-value ((cinput base-cinput))
  (translator-decode (translator cinput) cinput))

(defmethod wcomponent-after-rewind ((cinput base-cinput) (page page))
  (when (cform-rewinding-p (page-current-form page) page)
    (let ((visit-object (cinput-visit-object cinput))
          (accessor (cinput-accessor cinput))
          (writer (cinput-writer cinput))
          (validator (validator cinput))
          (value (translated-value cinput)))
      (unless (or (null value) (null visit-object) (component-validation-errors cinput))
	(when validator
	  (funcall validator value))
	(unless (component-validation-errors cinput)
	  (if (and (null writer) accessor)
	      (funcall (fdefinition `(setf ,accessor)) (if (and (stringp value) (string= value "") (base-cinput-empty-to-null-p cinput))
                                                           nil
                                                           value) visit-object)
	      (funcall (fdefinition writer) (if (and (stringp value) (string= value "") (base-cinput-empty-to-null-p cinput))
                                                           nil
                                                           value) visit-object)))))))

(defclass ctextarea (base-cinput)
    ()
    (:metaclass metacomponent)
    (:default-initargs :empty nil)
    (:documentation "Request cycle aware component the renders as an INPUT tag class"))

(let ((class (find-class 'ctextarea)))
  (closer-mop:ensure-finalized class)
  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
	(format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a"
		"Function that instantiates a CTEXTAREA component and renders a html <textarea> tag."
		*id-and-static-id-description*
		(describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
		(describe-html-attributes-from-class-slot-initargs class)
		(describe-component-behaviour class))))

(defmethod wcomponent-template ((ctextarea ctextarea))
  (let ((client-id (htcomponent-client-id ctextarea))
	(translator (translator ctextarea))
	(value "")
	(class (css-class ctextarea)))
    (when (component-validation-errors ctextarea)
      (if (or (null class) (string= class ""))
	  (setf class "error")
	  (setf class (format nil "~a error" class))))
    (setf value (translator-encode translator ctextarea))
    (textarea> :static-id client-id
               :name (name-attr ctextarea)
               :class class
               (wcomponent-informal-parameters ctextarea)
               (or value ""))))

(defmethod component-id-and-value ((cinput base-cinput))
  (let ((client-id (htcomponent-client-id cinput))
        (from-request-p (nth-value 1 (gethash (string-upcase (name-attr cinput)) (page-request-parameters *claw-current-page*))))
	(visit-object (cinput-visit-object cinput))
	(accessor (cinput-accessor cinput))
	(reader (cinput-reader cinput))
	(result-as-list-p (cinput-result-as-list-p cinput))
	(value ""))
    (when visit-object
      (setf value
            (cond
              (from-request-p (page-req-parameter (htcomponent-page cinput)
                                                  (name-attr cinput)
                                                  result-as-list-p))
              ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
              (reader (funcall (fdefinition reader) visit-object))))
      (values client-id value))))

;---------------------------------------------------------------------------------------
(defclass cinput-file (cinput)
    ()
    (:metaclass metacomponent)
    (:default-initargs :reserved-parameters (list :value :type) :empty t :type "file" :translator *file-translator*)
    (:documentation "Request cycle aware component the renders as an INPUT tag class of type file"))

(let ((class (find-class 'cinput-file)))
  (closer-mop:ensure-finalized class)
  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
	(format nil "Description: ~a~%Parameters:~%~{~a~}~%~%~a"
		"Function that instantiates a CINPUT component and renders a html <input> tag of type \"file\"."
                (list
                 *id-and-static-id-description*
                 (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
                 (describe-html-attributes-from-class-slot-initargs class))
		(describe-component-behaviour class))))

;---------------------------------------------------------------------------------------
(defgeneric csubmit-value (csubmit)
  (:documentation "Returns the value used by the CSUBMIT component."))

(defclass csubmit (_cform)
    ((value :initarg :value
	    :reader csubmit-value
	    :documentation "The html VALUE attribute"))
  (:metaclass metacomponent)
  (:default-initargs :reserved-parameters (list :type ) :empty t :action nil)
  (:documentation "This component render as an INPUT tag class ot type submit, but
can override the default CFORM action, using its own associated action"))

(let ((class (find-class 'csubmit)))
  (closer-mop:ensure-finalized class)
  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
	(format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a"
		"Function that instantiates a CSUBMIT component and renders a html <input> tag of submit type."
		*id-and-static-id-description*
		(describe-html-attributes-from-class-slot-initargs (find-class 'cform))
		(describe-html-attributes-from-class-slot-initargs class)
		(describe-component-behaviour class))))

(defmethod name-attr ((csubmit csubmit))
  (htcomponent-client-id csubmit))

(defmethod wcomponent-template ((obj csubmit))
  (let ((client-id (htcomponent-client-id obj))
	(value (csubmit-value obj)))
    (input> :static-id client-id
	    :type "submit"
	    :name (name-attr obj)
	    :value value
	    (wcomponent-informal-parameters obj))))

(defmethod wcomponent-after-rewind ((obj csubmit) (pobj page))
  (when (cform-rewinding-p (page-current-form pobj) pobj)
    (let ((action (action obj))
          (current-form (page-current-form pobj))
          (submitted-p (page-req-parameter pobj (htcomponent-client-id obj))))
      (unless (or (null current-form) (null submitted-p) (null action))
        (setf (action (page-current-form pobj)) action
              (action-object (page-current-form pobj)) (or (action-object obj) (action-object current-form)))))))

;-----------------------------------------------------------------------------
(defclass submit-link (csubmit)
    ()
  (:metaclass metacomponent)
  (:default-initargs :reserved-parameters (list :href) :empty nil)
  (:documentation "This component renders as a normal link, but behaves like a CSUBMIT,
so it can be used instead of CSUBMIT when needed"))

(let ((class (find-class 'submit-link)))
  (closer-mop:ensure-finalized class)
  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
	(format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a"
		"Function that instantiates a SUBMIT-LINK component and renders a html <a> tag that can submit the form where it is contained."
		*id-and-static-id-description*
		(describe-html-attributes-from-class-slot-initargs (find-class 'cform))
		(describe-html-attributes-from-class-slot-initargs class)
		(describe-component-behaviour class))))

(defmethod wcomponent-template ((obj submit-link))
  (let* ((id (htcomponent-client-id obj))
	 (submit-id (generate-id id)))
    (list
     (input> :static-id submit-id
	     :style "display:none;"
	     :type "submit"
	     :name (name-attr obj)
	     :value "-")
     (a> :static-id id
	:href (format nil "javascript:document.getElementById('~a').click();" submit-id)
	(wcomponent-informal-parameters obj)
	(htcomponent-body obj)))))

;--------------------------------------------------------------------------
(defclass cselect (base-cinput) ()
  (:default-initargs :reserved-parameters (list :type) :empty nil)
  (:metaclass metacomponent)
  (:documentation "This component renders as a normal SELECT tag class,
but it is request cycle aware."))

(let ((class (find-class 'cselect)))
  (closer-mop:ensure-finalized class)
  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
	(format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a"
		"Function that instantiates a CSELECT component and renders a html <select> tag."
		*id-and-static-id-description*
		(describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
		(describe-html-attributes-from-class-slot-initargs class)
		(describe-component-behaviour class))))

(defmethod wcomponent-template ((obj cselect))
  (let ((client-id (htcomponent-client-id obj))
	(class (css-class obj)))
    (when (component-validation-errors obj)
      (if (or (null class) (string= class ""))
	  (setf class "error")
	  (setf class (format nil "~a error" class))))
    (select> :static-id client-id
	     :name (name-attr obj)
	     :class class
	     :multiple (cinput-result-as-list-p obj)
	     (wcomponent-informal-parameters obj)
	     (htcomponent-body obj))))

;--------------------------------------------------------------------------------------------

(defgeneric ccheckbox-value (ccheckbox)
  (:documentation "A function that returns the value when the checkbox is selected.
"))

(defclass ccheckbox (cinput)
    ((test :initarg :test
             :accessor ccheckbox-test)
     (value :initarg :value
            :accessor ccheckbox-value))
    (:metaclass metacomponent)
    (:default-initargs :reserved-parameters () :empty t :type "checkbox" :test #'equal :multiple t)
    (:documentation "Request cycle aware component the renders as an INPUT tag class. IMPORTANT its assigned id mus be unique
since its NAME tag attribute will be extracted from the assigned id and not from the generate one as for other cinput components
"))


(defmethod name-attr ((cinput ccheckbox))
  (or (base-cinput-name cinput)
      (htcomponent-real-id cinput)))

(let ((class (find-class 'ccheckbox)))
  (closer-mop:ensure-finalized class)
  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
	(format nil "Description: ~a~%Parameters:~%~a~a~a~a~%~%~a"
		"Function that instantiates a CCHECKBOX component and renders a html <input> tag of type \"checkbox\"."
		*id-and-static-id-description*
		(describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
                (describe-html-attributes-from-class-slot-initargs (find-class 'cinput))
		(describe-html-attributes-from-class-slot-initargs class)
		(describe-component-behaviour class))))

(defmethod wcomponent-template ((cinput ccheckbox))
  (let* ((client-id (htcomponent-client-id cinput))
         (translator (translator cinput))
         (type (input-type cinput))
         (value (ccheckbox-value cinput))
         (accessor-value (translator-string-to-type translator cinput))
         (class (css-class cinput))
         (test (ccheckbox-test cinput)))
    (when (component-validation-errors cinput)
      (if (or (null class) (string= class ""))
	  (setf class "error")
	  (setf class (format nil "~a error" class))))
    (input> :static-id client-id
	    :type type
	    :name (name-attr cinput)
	    :class class
	    :value value
            :checked (when (and (or (cinput-accessor cinput)
                                    (cinput-reader cinput)) accessor-value 
                                (if (listp accessor-value)
                                    (member value accessor-value :test test) 
                                    (funcall test value accessor-value))) "checked")
	    (wcomponent-informal-parameters cinput))))

(defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page))
  (when (cform-rewinding-p (page-current-form page) page)
    (let* ((visit-object (cinput-visit-object cinput))
           (name (name-attr cinput))
           (translator (translator cinput))
           (accessor (cinput-accessor cinput))
           (writer (cinput-writer cinput))
           (validator (validator cinput))
           (result-as-list-p (cinput-result-as-list-p cinput))
           (new-value (page-req-parameter page
                                          name
                                          result-as-list-p)))
      (when new-value
        (setf new-value (if result-as-list-p 
                            (loop for item in new-value
                                 collect (translator-value-string-to-type translator item))
                            (translator-string-to-type translator cinput))))
      (unless (or (null visit-object) (component-validation-errors cinput))
        (when validator
          (funcall validator (or new-value "")))
        (unless (component-validation-errors cinput)
          (if (and (null writer) accessor)
              (funcall (fdefinition `(setf ,accessor)) new-value visit-object)
              (when writer
                (funcall (fdefinition writer) new-value visit-object))))))))

;-------------------------------------------------------------------------------------
(defclass cradio (ccheckbox)
    ()
    (:metaclass metacomponent)
    (:default-initargs :type "radio" :multiple t :reserved-parameters '(:multiple))
    (:documentation "Request cycle aware component the renders as an INPUT tag class"))

(let ((class (find-class 'cradio)))
  (closer-mop:ensure-finalized class)
  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
	(format nil "Description: ~a~%Parameters:~%~a~a~a~a~a~%~%~a"
		"Function that instantiates a CRADIO component and renders a html <input> tag of type \"radio\"."
		*id-and-static-id-description*
		(describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
                (describe-html-attributes-from-class-slot-initargs (find-class 'cinput))
                (describe-html-attributes-from-class-slot-initargs (find-class 'ccheckbox))
		(describe-html-attributes-from-class-slot-initargs class)
		(describe-component-behaviour class))))

(defmethod wcomponent-template ((cinput cradio))
  (let* ((client-id (htcomponent-client-id cinput))
         (translator (translator cinput))
         (type (input-type cinput))
         (value (translator-value-type-to-string translator (ccheckbox-value cinput)))
         (accessor-value (first (translator-string-to-type translator cinput)))
         (class (css-class cinput))
         (test (ccheckbox-test cinput)))
    (when (component-validation-errors cinput)
      (if (or (null class) (string= class ""))
	  (setf class "error")
	  (setf class (format nil "~a error" class))))
    (input> :static-id client-id
	    :type type
	    :name (name-attr cinput)
	    :class class
	    :value value
            :checked (when (and (or (cinput-accessor cinput)
                                    (cinput-reader cinput)) accessor-value 
                                (funcall test value accessor-value)) "checked")
	    (wcomponent-informal-parameters cinput))))

(defmethod wcomponent-after-rewind ((cinput cradio) (page page))
  (when (cform-rewinding-p (page-current-form page) page)
    (let* ((visit-object (cinput-visit-object cinput))
           (name (name-attr cinput))
           (translator (translator cinput))
           (accessor (cinput-accessor cinput))
           (writer (cinput-writer cinput))
           (validator (validator cinput))
           (result-as-list-p (cinput-result-as-list-p cinput))
           (new-value (page-req-parameter page
                                          name
                                          result-as-list-p)))
      (when new-value
        (setf new-value 
              (first (remove-if #'(lambda (x) (or (null x) (and (stringp x) (string-equal x "")))) 
                           (loop for item in new-value
                              collect (translator-value-string-to-type translator item))))))
      (unless (or (null visit-object) (component-validation-errors cinput))
        (when validator
          (funcall validator (or new-value "")))
        (unless (component-validation-errors cinput)
          (if (and (null writer) accessor)
              (funcall (fdefinition `(setf ,accessor)) new-value visit-object)
              (when writer
                (funcall (fdefinition writer) new-value visit-object))))))))

#|
(defmethod wcomponent-after-rewind ((cinput cradio) (page page))
  (when (cform-rewinding-p (page-current-form page) page)
    (let* ((visit-object (cinput-visit-object cinput))
           (translator (translator cinput))
           (accessor (cinput-accessor cinput))
           (writer (cinput-writer cinput))
           (validator (validator cinput))
           (ccheckbox-test (ccheckbox-test cinput))
           (result-as-list-p (cinput-result-as-list-p cinput))
           (value (translator-value-string-to-type translator (ccheckbox-value cinput)))
           (new-value (page-req-parameter page
                                          (name-attr cinput)
                                          result-as-list-p))
           (checked))
      (when new-value
        (setf new-value (translator-string-to-type translator cinput)
              checked (funcall ccheckbox-test value new-value)))
      (when (and checked visit-object (null (component-validation-errors cinput)))
        (when validator
          (funcall validator (or new-value "")))
        (when (null (component-validation-errors cinput))
          (if (and (null writer) accessor)
              (funcall (fdefinition `(setf ,accessor)) new-value visit-object)
              (funcall (fdefinition writer) new-value visit-object)))))))

(defmethod wcomponent-template ((cinput cradio))
  (let* ((client-id (htcomponent-client-id cinput))
         (translator (translator cinput))
         (type (input-type cinput))
         (value (translator-value-type-to-string translator (ccheckbox-value cinput)))
         (current-value (translator-type-to-string translator cinput))
         (class (css-class cinput)))
    (when (component-validation-errors cinput)
      (if (or (null class) (string= class ""))
	  (setf class "error")
	  (setf class (format nil "~a error" class))))
    (input> :static-id client-id
	    :type type
	    :name (name-attr cinput)
	    :class class
	    :value value
            :checked (when (and current-value (equal value current-value)) "checked")
	    (wcomponent-informal-parameters cinput))))
|#