From achiumenti at common-lisp.net Sat Jun 14 05:16:02 2008
From: achiumenti at common-lisp.net (achiumenti at common-lisp.net)
Date: Sat, 14 Jun 2008 01:16:02 -0400 (EDT)
Subject: [claw-cvs] r50 - in trunk/main/claw-core: src tests
Message-ID: <20080614051602.2C6286D23C@common-lisp.net>
Author: achiumenti
Date: Sat Jun 14 01:16:01 2008
New Revision: 50
Modified:
trunk/main/claw-core/src/components.lisp
trunk/main/claw-core/src/lisplet.lisp
trunk/main/claw-core/src/misc.lisp
trunk/main/claw-core/src/packages.lisp
trunk/main/claw-core/src/server.lisp
trunk/main/claw-core/src/tags.lisp
trunk/main/claw-core/src/translators.lisp
trunk/main/claw-core/tests/test1.lisp
Log:
a lot of bug fixes.
Modified: trunk/main/claw-core/src/components.lisp
==============================================================================
--- trunk/main/claw-core/src/components.lisp (original)
+++ trunk/main/claw-core/src/components.lisp Sat Jun 14 01:16:01 2008
@@ -33,9 +33,9 @@
(: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 &key from-request-p)
- (:documentation "Returns the form component \(such as and ) client-id and the associated value.
+ (:documentation "Returns the form component \(such as and ) 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"))
(defgeneric translator-encode (translator wcomponent)
@@ -68,15 +68,18 @@
(defgeneric name-attr (cinput)
(:documentation "Returns the name of the input component"))
-(defclass translator ()
+(defclass translator ()
()
(:documentation "a translator object encodes and decodes values passed to a html input component"))
(defvar *simple-translator* nil
- "*SIMPLE-TRANSLATOR* is the default translator for any CINPUT component.
+ "*SIMPLE-TRANSLATOR* is the default translator for any CINPUT component.
Its encoder and decoder methods pass values unchanged")
-(defun component-validation-errors (component &optional (request *request*))
+(defvar *file-translator* nil
+ "*FILE-TRANSLATOR* is the default translator for any CINPUT component of type \"file\".")
+
+(defun component-validation-errors (component &optional (request *request*))
"Resurns possible validation errors occurred during form rewinding bound to a specific component"
(let ((client-id (htcomponent-client-id component)))
(getf (validation-errors request) (intern client-id))))
@@ -85,14 +88,35 @@
-(defclass cform (wcomponent)
+(defclass _cform (wcomponent)
((action :initarg :action
:accessor action
:documentation "Function performed after user submission")
(css-class :initarg :class
:reader css-class
- :documentation "The html CLASS attribute"))
- (:default-initargs :action nil :class nil)
+ :documentation "The html CLASS attribute")
+ (method :initarg :method
+ :reader form-method
+ :documentation "Form post method (may be \"get\" or \"post\")"))
+ (:default-initargs :action nil :class nil :method "post")
+ (:documentation "Internal use component"))
+
+(defmethod wcomponent-after-rewind ((obj _cform) (pobj page))
+ (let ((validation-errors (validation-errors))
+ (action (action obj)))
+ (when (and (null validation-errors)
+ action
+ (cform-rewinding-p obj pobj))
+ (funcall action pobj))))
+
+(defmethod cform-rewinding-p ((cform _cform) (page page))
+ (string= (htcomponent-client-id cform)
+ (page-req-parameter page *rewind-parameter*)))
+
+(defclass cform (_cform)
+ ((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"))
(: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"))
@@ -107,13 +131,10 @@
(describe-component-behaviour class))))
-(defmethod cform-rewinding-p ((cform cform) (page page))
- (string= (htcomponent-client-id cform)
- (page-req-parameter page *rewind-parameter*)))
-
(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 ""))
@@ -121,26 +142,40 @@
(setf class (format nil "~a error" class))))
(form> :static-id client-id
:class class
+ :method method
(wcomponent-informal-parameters cform)
(input> :name *rewind-parameter*
- :type "hidden"
+ :type "hidden"
:value client-id)
(htcomponent-body cform))))
+(defmethod cform-rewinding-p ((cform cform) (page page))
+ (and (cform-execute-p cform)
+ (string= (htcomponent-client-id cform)
+ (page-req-parameter page *rewind-parameter*))))
+
(defmethod wcomponent-before-rewind ((obj cform) (pobj page))
+ (let ((render-condition (htcomponent-render-condition obj)))
+ (setf (cform-execute-p obj) (not (and render-condition (null (funcall render-condition))))
+ (page-current-form pobj) obj)))
+
+(defmethod wcomponent-after-rewind :after ((obj cform) (pobj page))
+ (setf (page-current-form pobj) nil))
+
+(defmethod wcomponent-before-prerender ((obj cform) (pobj page))
(setf (page-current-form pobj) obj))
-(defmethod wcomponent-after-rewind ((obj cform) (pobj page))
- (let ((validation-errors (validation-errors))
- (action (action obj)))
- (unless validation-errors
- (when (or action (cform-rewinding-p obj pobj))
- (funcall action pobj))
- (setf (page-current-form pobj) nil))))
+(defmethod wcomponent-after-prerender ((obj cform) (pobj page))
+ (setf (page-current-form pobj) nil))
+(defmethod wcomponent-before-render ((obj cform) (pobj page))
+ (setf (page-current-form pobj) obj))
+
+(defmethod wcomponent-after-render ((obj cform) (pobj page))
+ (setf (page-current-form pobj) nil))
;--------------------------------------------------------------------------------
-(defclass action-link (cform) ()
+(defclass action-link (_cform) ()
(:metaclass metacomponent)
(:default-initargs :reserved-parameters (list :href))
(:documentation "This component behaves like a CFORM, firing it's associated action once clicked.
@@ -165,11 +200,12 @@
(wcomponent-informal-parameters o)
(htcomponent-body o))))
+
;---------------------------------------------------------------------------------------
(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")
+ :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")
@@ -179,7 +215,7 @@
(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
+ (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
@@ -209,7 +245,7 @@
(defclass cinput (base-cinput)
((input-type :initarg :type
:reader input-type
- :documentation "The html TYPE attribute. For submit type, use the CSUBMIT> function."))
+ :documentation "The html TYPE attribute. For submit type, use the CSUBMIT> function."))
(:metaclass metacomponent)
(:default-initargs :reserved-parameters (list :value :name) :empty t :type "text")
(:documentation "Request cycle aware component the renders as an INPUT tag class"))
@@ -218,13 +254,13 @@
(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 tag."
+ "Function that instantiates a CINPUT component and renders a html 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))
+(defmethod wcomponent-template ((cinput cinput))
(let ((client-id (htcomponent-client-id cinput))
(type (input-type cinput))
(translator (translator cinput))
@@ -243,20 +279,53 @@
(wcomponent-informal-parameters cinput))))
(defmethod wcomponent-after-rewind ((cinput base-cinput) (page page))
- (let ((visit-object (or (cinput-visit-object cinput) page))
- (accessor (cinput-accessor cinput))
- (writer (cinput-writer cinput))
- (validator (validator cinput))
- (value (translator-decode (translator cinput) cinput)))
+ (when (cform-rewinding-p (page-current-form page) page)
+ (let ((visit-object (or (cinput-visit-object cinput) page))
+ (accessor (cinput-accessor cinput))
+ (writer (cinput-writer cinput))
+ (validator (validator cinput))
+ (value (translator-decode (translator cinput) cinput)))
(unless (or (null value) (component-validation-errors cinput))
(when validator
(funcall validator value))
(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 writer) value visit-object)))))))
-(defmethod component-id-and-value ((cinput base-cinput) &key (from-request-p t))
+(defclass ctextarea (base-cinput)
+ ()
+ (:metaclass metacomponent)
+ (:default-initargs :reserved-parameters (list :name) :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