[claw-cvs] r99 - trunk/main/claw-html/src
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Wed Oct 1 11:57:13 UTC 2008
Author: achiumenti
Date: Wed Oct 1 07:57:12 2008
New Revision: 99
Modified:
trunk/main/claw-html/src/components.lisp
trunk/main/claw-html/src/packages.lisp
trunk/main/claw-html/src/tags.lisp
trunk/main/claw-html/src/translators.lisp
Log:
several bugfixes and enhancements
Modified: trunk/main/claw-html/src/components.lisp
==============================================================================
--- trunk/main/claw-html/src/components.lisp (original)
+++ trunk/main/claw-html/src/components.lisp Wed Oct 1 07:57:12 2008
@@ -38,9 +38,9 @@
- OBJ the wcomponent instance
- PAGE-OBJ the wcomponent owner page"))
-(defgeneric component-id-and-value (cinput &key from-request-p)
+(defgeneric component-id-and-value (cinput)
(:documentation "Returns the form component \(such as <input> and <select>) client-id and the associated value.
-When FROM-REQUEST-P is not null, the value is retrived from the http request by its name, from the associated reader or accessor when nil"))
+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"))
@@ -233,8 +233,14 @@
: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"))
- (:default-initargs :multiple nil :writer nil :reader nil :accessor nil :class nil
+ :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"))
@@ -245,14 +251,15 @@
label)))
(defmethod name-attr ((cinput base-cinput))
- (htcomponent-client-id 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 :name) :empty t :type "text")
+ (: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)))
@@ -298,13 +305,17 @@
(funcall validator cinput))
(unless (component-validation-errors cinput)
(if (and (null writer) accessor)
- (funcall (fdefinition `(setf ,accessor)) value visit-object)
- (funcall (fdefinition writer) value visit-object)))))))
+ (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 :reserved-parameters (list :name) :empty nil)
+ (:default-initargs :empty nil)
(:documentation "Request cycle aware component the renders as an INPUT tag class"))
(let ((class (find-class 'ctextarea)))
@@ -333,8 +344,9 @@
(wcomponent-informal-parameters ctextarea)
(or value ""))))
-(defmethod component-id-and-value ((cinput base-cinput) &key (from-request-p t))
+(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))
@@ -347,14 +359,14 @@
(name-attr cinput)
result-as-list-p))
((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
- (t (funcall (fdefinition reader) visit-object))))
+ (reader (funcall (fdefinition reader) visit-object))))
(values client-id value))))
;---------------------------------------------------------------------------------------
(defclass cinput-file (cinput)
()
(:metaclass metacomponent)
- (:default-initargs :reserved-parameters (list :value :name :type) :empty t :type "file" :translator *file-translator*)
+ (: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)))
@@ -374,7 +386,7 @@
:reader csubmit-value
:documentation "The html VALUE attribute"))
(:metaclass metacomponent)
- (:default-initargs :reserved-parameters (list :type :name) :empty t :action nil)
+ (: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"))
@@ -443,7 +455,7 @@
;--------------------------------------------------------------------------
(defclass cselect (base-cinput) ()
- (:default-initargs :reserved-parameters (list :type :name) :empty nil)
+ (: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."))
@@ -480,13 +492,14 @@
(value :initarg :value
:accessor ccheckbox-value))
(:metaclass metacomponent)
- (:default-initargs :reserved-parameters (list :name) :empty t :type "checkbox" :test #'equal)
+ (: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))
- (htcomponent-real-id cinput))
+ (or (base-cinput-name cinput)
+ (htcomponent-real-id cinput)))
(let ((class (find-class 'ccheckbox)))
(closer-mop:ensure-finalized class)
@@ -504,7 +517,7 @@
(translator (translator cinput))
(type (input-type cinput))
(value (translator-value-type-to-string translator (ccheckbox-value cinput)))
- (current-value (translator-string-to-type translator cinput))
+ (accessor-value (translator-string-to-type translator cinput))
(class (css-class cinput))
(test (ccheckbox-test cinput)))
(when (component-validation-errors cinput)
@@ -516,10 +529,11 @@
:name (name-attr cinput)
:class class
:value value
- :checked (when (and current-value
- (if (listp current-value)
- (member (ccheckbox-value cinput) current-value :test test)
- (funcall test (ccheckbox-value cinput) current-value))) "checked")
+ :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))
@@ -545,13 +559,14 @@
(unless (component-validation-errors cinput)
(if (and (null writer) accessor)
(funcall (fdefinition `(setf ,accessor)) new-value visit-object)
- (funcall (fdefinition writer) new-value visit-object)))))))
+ (when writer
+ (funcall (fdefinition writer) new-value visit-object))))))))
;-------------------------------------------------------------------------------------
(defclass cradio (ccheckbox)
()
(:metaclass metacomponent)
- (:default-initargs :type "radio")
+ (: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)))
@@ -566,9 +581,55 @@
(describe-html-attributes-from-class-slot-initargs class)
(describe-component-behaviour class))))
-(defmethod name-attr ((ccheckbox ccheckbox))
- (htcomponent-real-id ccheckbox))
+(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))
@@ -612,3 +673,4 @@
:value value
:checked (when (and current-value (equal value current-value)) "checked")
(wcomponent-informal-parameters cinput))))
+|#
\ No newline at end of file
Modified: trunk/main/claw-html/src/packages.lisp
==============================================================================
--- trunk/main/claw-html/src/packages.lisp (original)
+++ trunk/main/claw-html/src/packages.lisp Wed Oct 1 07:57:12 2008
@@ -229,6 +229,7 @@
;;validation
#:translator
+ #:validation-error-control-string
#:translator-integer
#:translator-number
#:translator-boolean
Modified: trunk/main/claw-html/src/tags.lisp
==============================================================================
--- trunk/main/claw-html/src/tags.lisp (original)
+++ trunk/main/claw-html/src/tags.lisp Wed Oct 1 07:57:12 2008
@@ -1179,13 +1179,13 @@
do (when (eq (car (last (closer-mop:slot-definition-initargs slot-definition))) initarg)
(return (closer-mop:slot-definition-name slot-definition))))))
(if (find initarg (wcomponent-reserved-parameters wcomponent))
- (error (format nil "Parameter ~a is reserved" initarg))
+ (error (format nil "Parameter ~a for component ~a is reserved" initarg (type-of wcomponent)))
(if slot-name
(setf (slot-value wcomponent slot-name) new-value)
(if (null (wcomponent-allow-informal-parametersp wcomponent))
(error (format nil
"Component ~a doesn't accept informal parameters"
- slot-initarg))
+ (type-of wcomponent)))
(setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value))))))
Modified: trunk/main/claw-html/src/translators.lisp
==============================================================================
--- trunk/main/claw-html/src/translators.lisp (original)
+++ trunk/main/claw-html/src/translators.lisp Wed Oct 1 07:57:12 2008
@@ -79,7 +79,7 @@
(progn
(setf value (cond
((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
- (t (funcall (fdefinition reader) visit-object))))
+ (reader (funcall (fdefinition reader) visit-object))))
(if (listp value)
(loop for item in value
collect (translator-value-encode translator item))
More information about the Claw-cvs
mailing list