Author: achiumenti Date: Mon Sep 1 11:33:48 2008 New Revision: 78
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: bufix on rewind
Modified: trunk/main/claw-html/src/components.lisp ============================================================================== --- trunk/main/claw-html/src/components.lisp (original) +++ trunk/main/claw-html/src/components.lisp Mon Sep 1 11:33:48 2008 @@ -69,26 +69,37 @@ :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" :action-object nil) + :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) + () (: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) (pobj page)) (let ((validation-errors *validation-errors*) (action (action obj))) (when (and (null validation-errors) action - (cform-rewinding-p obj pobj)) - (funcall action (or (action-object obj) pobj))))) + (cform-rewinding-p obj pobj)) + (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) - ((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")) +(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")) @@ -116,40 +127,48 @@ :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) (page page)) +(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 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 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) (pobj page)) +(defmethod wcomponent-after-rewind :after ((obj _cform-mixin) (pobj page)) (setf (page-current-form pobj) nil))
-(defmethod wcomponent-before-prerender ((obj cform) (pobj page)) +(defmethod wcomponent-before-prerender ((obj _cform-mixin) (pobj page)) (setf (page-current-form pobj) obj))
-(defmethod wcomponent-after-prerender ((obj cform) (pobj page)) +(defmethod wcomponent-after-prerender ((obj _cform-mixin) (pobj page)) (setf (page-current-form pobj) nil))
-(defmethod wcomponent-before-render ((obj cform) (pobj page)) +(defmethod wcomponent-before-render ((obj _cform-mixin) (pobj page)) (setf (page-current-form pobj) obj))
-(defmethod wcomponent-after-render ((obj cform) (pobj page)) +(defmethod wcomponent-after-render ((obj _cform-mixin) (pobj page)) (setf (page-current-form pobj) nil)) ;--------------------------------------------------------------------------------
-(defclass action-link (_cform) () +(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)) + (: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."))
@@ -164,11 +183,15 @@ (describe-component-behaviour class))))
(defmethod wcomponent-template((o action-link)) - (let ((client-id (htcomponent-client-id o))) + (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 (format nil "?~a=~a" *rewind-parameter* client-id) + :href (if params + (format nil "~a~{&~a=~a~}" href params) + href) (wcomponent-informal-parameters o) (htcomponent-body o))))
@@ -202,7 +225,7 @@ :reader css-class :documentation "the html component class attribute")) (:default-initargs :multiple nil :writer nil :reader nil :accessor nil :class nil - :label nil :translator *simple-translator* :validator nil :visit-object nil) + :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)) @@ -252,12 +275,12 @@
(defmethod wcomponent-after-rewind ((cinput base-cinput) (page page)) (when (cform-rewinding-p (page-current-form page) page) - (let ((visit-object (or (cinput-visit-object cinput) page)) + (let ((visit-object (cinput-visit-object cinput)) (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)) + (unless (or (null value) (null visit-object) (component-validation-errors cinput)) (when validator (funcall validator value)) (unless (component-validation-errors cinput) @@ -299,19 +322,20 @@
(defmethod component-id-and-value ((cinput base-cinput) &key (from-request-p t)) (let ((client-id (htcomponent-client-id cinput)) - (visit-object (or (cinput-visit-object cinput) (htcomponent-page cinput))) + (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 "")) - (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)) - (t (funcall (fdefinition reader) visit-object)))) - (values client-id 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)) + (t (funcall (fdefinition reader) visit-object)))) + (values client-id value))))
;--------------------------------------------------------------------------------------- (defclass cinput-file (cinput) @@ -478,7 +502,7 @@
(defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page)) (when (cform-rewinding-p (page-current-form page) page) - (let* ((visit-object (or (cinput-visit-object cinput) page)) + (let* ((visit-object (cinput-visit-object cinput)) (client-id (htcomponent-client-id cinput)) (translator (translator cinput)) (accessor (cinput-accessor cinput)) @@ -490,7 +514,7 @@ result-as-list-p))) (when new-value (setf new-value (translator-string-to-type translator cinput))) - (unless (component-validation-errors cinput) + (unless (or (null visit-object) (component-validation-errors cinput)) (when validator (funcall validator (or new-value ""))) (unless (component-validation-errors cinput) @@ -522,7 +546,7 @@
(defmethod wcomponent-after-rewind ((cinput cradio) (page page)) (when (cform-rewinding-p (page-current-form page) page) - (let* ((visit-object (or (cinput-visit-object cinput) page)) + (let* ((visit-object (cinput-visit-object cinput)) (translator (translator cinput)) (accessor (cinput-accessor cinput)) (writer (cinput-writer cinput)) @@ -537,7 +561,7 @@ (when new-value (setf new-value (translator-string-to-type translator cinput) checked (funcall ccheckbox-test value new-value))) - (when (and checked (null (component-validation-errors cinput))) + (when (and checked visit-object (null (component-validation-errors cinput))) (when validator (funcall validator (or new-value ""))) (when (null (component-validation-errors cinput))
Modified: trunk/main/claw-html/src/packages.lisp ============================================================================== --- trunk/main/claw-html/src/packages.lisp (original) +++ trunk/main/claw-html/src/packages.lisp Mon Sep 1 11:33:48 2008 @@ -42,7 +42,7 @@ #:*xhtml-1.0-frameset* #:*rewind-parameter* #:*validation-errors* - + #:*claw-current-page* #:error-page #:render-error-page
@@ -195,6 +195,7 @@ #:action #:action-link #:action-link> + #:action-link-parameters #:cinput #:cinput> #:ctextarea
Modified: trunk/main/claw-html/src/tags.lisp ============================================================================== --- trunk/main/claw-html/src/tags.lisp (original) +++ trunk/main/claw-html/src/tags.lisp Mon Sep 1 11:33:48 2008 @@ -238,6 +238,9 @@ (defvar *rewind-parameter* "rewindobject" "The request parameter name for the object asking for a rewind action")
+(defvar *rewind-form-parameter* "rewindformobject" + "The request parameter name for the form curently rewinding") + (defvar *empty-tags* (list "area" "base" "basefont" "br" "col" "frame" "hr" "img" "input" "isindex" "meta" @@ -449,7 +452,8 @@ :reader htcomponent-page :documentation "The owner page") (json-render-on-validation-errors-p :initarg :json-render-on-validation-errors-p :reader htcomponent-json-render-on-validation-errors-p - :documentation "If from submission contains exceptions and the value is not nil, the component is rendered into the xhr json reply.") + :documentation "If from submission contains exceptions and the value is not nil, the component is rendered into the xhr json reply. +If the value is T then component will be rendered on any error, if it's a tag id string it will be rendere only when the rewind parameter will match") (body :initarg :body :accessor htcomponent-body :documentation "The tag body") (client-id :initarg :client-id @@ -756,227 +760,241 @@ (car (page-components-stack *claw-current-page*)))) ;;;========= HTCOMPONENT ============================ (defmethod htcomponent-can-print ((htcomponent htcomponent)) -(let* ((id (when (slot-boundp htcomponent 'client-id) - (htcomponent-client-id htcomponent))) - (page (htcomponent-page htcomponent)) - (print-status (page-can-print page)) - (validation-errors *validation-errors*) - (json-render-on-validation-errors-p (htcomponent-json-render-on-validation-errors-p htcomponent)) - (render-p (or (and (member id (page-json-id-list page) :test #'string=) - (null validation-errors)) - print-status))) - (or json-render-on-validation-errors-p print-status render-p))) + (let* ((id (when (slot-boundp htcomponent 'client-id) + (htcomponent-client-id htcomponent))) + (page (htcomponent-page htcomponent)) + (print-status (page-can-print page)) + (validation-errors *validation-errors*) + (json-render-on-validation-errors-value (htcomponent-json-render-on-validation-errors-p htcomponent)) + (json-render-on-validation-errors-p (if (typep json-render-on-validation-errors-value 'boolean) + json-render-on-validation-errors-value + (string= json-render-on-validation-errors-value + (page-req-parameter *claw-current-page* *rewind-parameter*)))) + (render-p (or (and (member id (page-json-id-list page) :test #'string=) + (null validation-errors)) + print-status))) + (or json-render-on-validation-errors-p print-status render-p)))
(defmethod htcomponent-json-print-start-component ((htcomponent htcomponent)) -(let* ((page (htcomponent-page htcomponent)) - (jsonp (page-json-id-list page)) - (id (when (slot-boundp htcomponent 'client-id) - (htcomponent-client-id htcomponent))) - (validation-errors *validation-errors*)) - (when (and jsonp - (or (and (null validation-errors) - (member id jsonp :test #'string-equal)) - (htcomponent-json-render-on-validation-errors-p htcomponent))) - (when (> (page-json-component-count page) 0) - (page-format page ",")) - (page-format-raw page "~a:"" id) - (push id (page-json-component-id-list page)) - (incf (page-json-component-count page))))) + (let* ((page (htcomponent-page htcomponent)) + (jsonp (page-json-id-list page)) + (id (when (slot-boundp htcomponent 'client-id) + (htcomponent-client-id htcomponent))) + (validation-errors *validation-errors*) + (json-render-on-validation-errors-value (htcomponent-json-render-on-validation-errors-p htcomponent)) + (json-render-on-validation-errors-p (if (typep json-render-on-validation-errors-value 'boolean) + json-render-on-validation-errors-value + (string= json-render-on-validation-errors-value + (page-req-parameter *claw-current-page* *rewind-parameter*))))) + (when (and jsonp + (or (and (null validation-errors) + (member id jsonp :test #'string-equal)) + json-render-on-validation-errors-p)) + (when (> (page-json-component-count page) 0) + (page-format page ",")) + (page-format-raw page "~a:"" id) + (push id (page-json-component-id-list page)) + (incf (page-json-component-count page)))))
(defmethod htcomponent-json-print-end-component ((htcomponent htcomponent)) -(let* ((page (htcomponent-page htcomponent)) - (jsonp (page-json-id-list page)) - (id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent))) - (validation-errors *validation-errors*)) - (when (and jsonp - (or (and (null validation-errors) - (member id jsonp :test #'string-equal)) - (htcomponent-json-render-on-validation-errors-p htcomponent))) - (pop (page-json-component-id-list page)) - (page-format-raw page """)))) + (let* ((page (htcomponent-page htcomponent)) + (jsonp (page-json-id-list page)) + (id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent))) + (validation-errors *validation-errors*) + (json-render-on-validation-errors-value (htcomponent-json-render-on-validation-errors-p htcomponent)) + (json-render-on-validation-errors-p (if (typep json-render-on-validation-errors-value 'boolean) + json-render-on-validation-errors-value + (string= json-render-on-validation-errors-value + (page-req-parameter *claw-current-page* *rewind-parameter*))))) + (when (and jsonp + (or (and (null validation-errors) + (member id jsonp :test #'string-equal)) + json-render-on-validation-errors-p)) + (pop (page-json-component-id-list page)) + (page-format-raw page """))))
(defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page)) -(setf (htcomponent-page htcomponent) page) -(push htcomponent (page-components-stack page))) + (setf (htcomponent-page htcomponent) page) + (push htcomponent (page-components-stack page)))
(defmethod htcomponent-prerender :before ((htcomponent htcomponent) (page page)) -(let ((render-condition (htcomponent-render-condition htcomponent))) - (unless (and render-condition (null (funcall render-condition))) - (setf (htcomponent-page htcomponent) page) - (push htcomponent (page-components-stack page))))) + (let ((render-condition (htcomponent-render-condition htcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (setf (htcomponent-page htcomponent) page) + (push htcomponent (page-components-stack page)))))
(defmethod htcomponent-render :before ((htcomponent htcomponent) (page page)) -(let ((render-condition (htcomponent-render-condition htcomponent))) - (unless (and render-condition (null (funcall render-condition))) - (setf (htcomponent-page htcomponent) page) - (push htcomponent (page-components-stack page))))) + (let ((render-condition (htcomponent-render-condition htcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (setf (htcomponent-page htcomponent) page) + (push htcomponent (page-components-stack page)))))
(defmethod htcomponent-rewind :after ((htcomponent htcomponent) (page page)) -(pop (page-components-stack page))) + (pop (page-components-stack page)))
(defmethod htcomponent-prerender :after ((htcomponent htcomponent) (page page)) -(let ((render-condition (htcomponent-render-condition htcomponent))) - (unless (and render-condition (null (funcall render-condition))) - (pop (page-components-stack page))))) + (let ((render-condition (htcomponent-render-condition htcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (pop (page-components-stack page)))))
(defmethod htcomponent-render :after ((htcomponent htcomponent) (page page)) -(let ((render-condition (htcomponent-render-condition htcomponent))) - (unless (and render-condition (null (funcall render-condition))) - (pop (page-components-stack page))))) + (let ((render-condition (htcomponent-render-condition htcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (pop (page-components-stack page)))))
(defmethod htcomponent-rewind ((htcomponent htcomponent) (page page)) -(dolist (tag (htcomponent-body htcomponent)) - (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-rewind tag page)))) + (dolist (tag (htcomponent-body htcomponent)) + (when (subtypep (type-of tag) 'htcomponent) + (htcomponent-rewind tag page))))
(defmethod htcomponent-prerender ((htcomponent htcomponent) (page page)) -(let ((previous-print-status (page-can-print page)) - (render-condition (htcomponent-render-condition htcomponent))) - (unless (and render-condition (null (funcall render-condition))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print htcomponent))) - (dolist (tag (htcomponent-body htcomponent)) - (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-prerender tag page))) - (when (null previous-print-status) - (setf (page-can-print page) nil))))) + (let ((previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition htcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print htcomponent))) + (dolist (tag (htcomponent-body htcomponent)) + (when (subtypep (type-of tag) 'htcomponent) + (htcomponent-prerender tag page))) + (when (null previous-print-status) + (setf (page-can-print page) nil)))))
(defmethod htcomponent-render ((htcomponent htcomponent) (page page)) -(let ((body-list (htcomponent-body htcomponent)) - (previous-print-status (page-can-print page)) - (render-condition (htcomponent-render-condition htcomponent))) - (unless (and render-condition (null (funcall render-condition))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print htcomponent)) - (htcomponent-json-print-start-component htcomponent)) - (dolist (child-tag body-list) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) - (when (null previous-print-status) - (setf (page-can-print page) nil) - (htcomponent-json-print-end-component htcomponent))))) + (let ((body-list (htcomponent-body htcomponent)) + (previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition htcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print htcomponent)) + (htcomponent-json-print-start-component htcomponent)) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) + (when (null previous-print-status) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htcomponent)))))
;;;========= TAG ===================================== (defmethod tag-attributes ((tag tag)) -(htcomponent-attributes tag)) + (htcomponent-attributes tag))
(defmethod tag-render-attributes ((tag tag) (page page)) -(when (htcomponent-attributes tag) - (loop for (k v) on (htcomponent-attributes tag) by #'cddr - do (progn - (assert (keywordp k)) - (when (and (functionp v) (not (eq k :render-condition))) - (setf v (funcall v))) - (when (numberp v) - (setf v (princ-to-string v))) - (when (and (not (eq k :render-condition)) v (string-not-equal v "")) - (page-format page " ~a="~a"" - (if (eq k :static-id) - "id" - (parenscript::symbol-to-js k)) - (let ((s (if (eq k :id) - (prin1-to-string (htcomponent-client-id tag)) - (if (eq t v) - ""true"" - (prin1-to-string v))))) ;escapes double quotes - (subseq s 1 (1- (length s)))))))))) + (when (htcomponent-attributes tag) + (loop for (k v) on (htcomponent-attributes tag) by #'cddr + do (progn + (assert (keywordp k)) + (when (and (functionp v) (not (eq k :render-condition))) + (setf v (funcall v))) + (when (numberp v) + (setf v (princ-to-string v))) + (when (and (not (eq k :render-condition)) v (string-not-equal v "")) + (page-format page " ~a="~a"" + (if (eq k :static-id) + "id" + (parenscript::symbol-to-js k)) + (let ((s (if (eq k :id) + (prin1-to-string (htcomponent-client-id tag)) + (if (eq t v) + ""true"" + (prin1-to-string v))))) ;escapes double quotes + (subseq s 1 (1- (length s))))))))))
(defmethod tag-render-starttag ((tag tag) (page page)) -(let ((tagname (tag-name tag)) - (id (when (slot-boundp tag 'client-id) (htcomponent-client-id tag))) - (jsonp (page-json-id-list page)) - (emptyp (htcomponent-empty tag)) - (xml-p (page-xmloutput page)) - (injection-writing-p (page-injection-writing-p page))) - (setf (page-lasttag page) tagname) - (when (or injection-writing-p - (null jsonp) - (null (and jsonp - (string= id (first (page-json-component-id-list page)))))) - (page-newline page) - (page-print-tabulation page) - (page-format page "<~a" tagname) - (tag-render-attributes tag page) - (if (null emptyp) - (progn - (page-format page ">") - (incf (page-tabulator page))) - (if (null xml-p) + (let ((tagname (tag-name tag)) + (id (when (slot-boundp tag 'client-id) (htcomponent-client-id tag))) + (jsonp (page-json-id-list page)) + (emptyp (htcomponent-empty tag)) + (xml-p (page-xmloutput page)) + (injection-writing-p (page-injection-writing-p page))) + (setf (page-lasttag page) tagname) + (when (or injection-writing-p + (null jsonp) + (null (and jsonp + (string= id (first (page-json-component-id-list page)))))) + (page-newline page) + (page-print-tabulation page) + (page-format page "<~a" tagname) + (tag-render-attributes tag page) + (if (null emptyp) + (progn (page-format page ">") - (page-format page "/>")))))) + (incf (page-tabulator page))) + (if (null xml-p) + (page-format page ">") + (page-format page "/>"))))))
(defmethod tag-render-endtag ((tag tag) (page page)) -(let ((tagname (tag-name tag)) - (id (when (slot-boundp tag 'client-id) (htcomponent-client-id tag))) - (jsonp (page-json-id-list page)) - (previous-tagname (page-lasttag page)) - (emptyp (htcomponent-empty tag)) - (injection-writing-p (page-injection-writing-p page))) - (when (and (null emptyp) - (or injection-writing-p - (null jsonp) - (null (and jsonp - (string= id (first (page-json-component-id-list page))))))) - (progn - (decf (page-tabulator page)) - (if (string= tagname previous-tagname) - (progn - (page-format page "</~a>" tagname)) - (progn - (page-newline page) - (page-print-tabulation page) - (page-format page "</~a>" tagname))))) - (setf (page-lasttag page) nil))) + (let ((tagname (tag-name tag)) + (id (when (slot-boundp tag 'client-id) (htcomponent-client-id tag))) + (jsonp (page-json-id-list page)) + (previous-tagname (page-lasttag page)) + (emptyp (htcomponent-empty tag)) + (injection-writing-p (page-injection-writing-p page))) + (when (and (null emptyp) + (or injection-writing-p + (null jsonp) + (null (and jsonp + (string= id (first (page-json-component-id-list page))))))) + (progn + (decf (page-tabulator page)) + (if (string= tagname previous-tagname) + (progn + (page-format page "</~a>" tagname)) + (progn + (page-newline page) + (page-print-tabulation page) + (page-format page "</~a>" tagname))))) + (setf (page-lasttag page) nil)))
(defmethod htcomponent-render ((tag tag) (page page)) -(let ((body-list (htcomponent-body tag)) - (previous-print-status (page-can-print page)) - (render-condition (htcomponent-render-condition tag))) - (unless (and render-condition (null (funcall render-condition))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print tag)) - (htcomponent-json-print-start-component tag)) - (when (or (page-can-print page) previous-print-status) - (tag-render-starttag tag page)) - (dolist (child-tag body-list) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) - (when (or (page-can-print page) previous-print-status) - (tag-render-endtag tag page)) - (unless previous-print-status - (setf (page-can-print page) nil) - (htcomponent-json-print-end-component tag))))) + (let ((body-list (htcomponent-body tag)) + (previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition tag))) + (unless (and render-condition (null (funcall render-condition))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print tag)) + (htcomponent-json-print-start-component tag)) + (when (or (page-can-print page) previous-print-status) + (tag-render-starttag tag page)) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) + (when (or (page-can-print page) previous-print-status) + (tag-render-endtag tag page)) + (unless previous-print-status + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component tag)))))
;;;========= HTHEAD ====================================== (defmethod htcomponent-render ((hthead hthead) (page page)) -(let ((render-condition (htcomponent-render-condition hthead))) - (unless (and render-condition (null (funcall render-condition))) - (when (null (page-json-id-list page)) - (let ((body-list (htcomponent-body hthead)) - (injections (page-init-injections page)) - (encoding (page-external-format-encoding page))) - (tag-render-starttag hthead page) - (htcomponent-render (meta> :http-equiv "Content-Type" - :content (format nil "~a;charset=~a" - (page-mime-type page) - encoding)) - page) - (dolist (child-tag body-list) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) - (dolist (injection injections) - (when injection - (htcomponent-render injection page))) - (tag-render-endtag hthead page)))))) + (let ((render-condition (htcomponent-render-condition hthead))) + (unless (and render-condition (null (funcall render-condition))) + (when (null (page-json-id-list page)) + (let ((body-list (htcomponent-body hthead)) + (injections (page-init-injections page)) + (encoding (page-external-format-encoding page))) + (tag-render-starttag hthead page) + (htcomponent-render (meta> :http-equiv "Content-Type" + :content (format nil "~a;charset=~a" + (page-mime-type page) + encoding)) + page) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) + (dolist (injection injections) + (when injection + (htcomponent-render injection page))) + (tag-render-endtag hthead page))))))
;;;========= HTSTRING ===================================
@@ -984,283 +1002,289 @@ (defmethod htcomponent-prerender((htstring htstring) (page page)))
(defmethod htcomponent-render ((htstring htstring) (page page)) -(let ((body (htcomponent-body htstring)) - (jsonp (not (null (page-json-id-list page)))) - (print-p (page-can-print page)) - (render-condition (htcomponent-render-condition htstring))) - (unless (and render-condition (null (funcall render-condition))) - (when (and print-p body) - (when (functionp body) - (setf body (funcall body))) - (when jsonp - (setf body (regex-replace-all """ - (regex-replace-all "\\"" - (regex-replace-all "\n" - body - "\n") - "\\\"") - "\""))) - (if (htstring-raw htstring) - (page-format-raw page body) - (loop for ch across body - do (case ch - ((#<) (page-format-raw page "<")) - ((#>) (page-format-raw page ">")) - ((#&) (page-format-raw page "&")) - (t (page-format-raw page "~a" ch))))))))) + (let ((body (htcomponent-body htstring)) + (jsonp (not (null (page-json-id-list page)))) + (print-p (page-can-print page)) + (render-condition (htcomponent-render-condition htstring))) + (unless (and render-condition (null (funcall render-condition))) + (when (and print-p body) + (when (functionp body) + (setf body (funcall body))) + (when jsonp + (setf body (regex-replace-all """ + (regex-replace-all "\\"" + (regex-replace-all "\n" + body + "\n") + "\\\"") + "\""))) + (if (htstring-raw htstring) + (page-format-raw page body) + (loop for ch across body + do (case ch + ((#<) (page-format-raw page "<")) + ((#>) (page-format-raw page ">")) + ((#&) (page-format-raw page "&")) + (t (page-format-raw page "~a" ch)))))))))
;;;========= HTSCRIPT =================================== (defmethod htcomponent-prerender((htscript htscript) (page page)))
(defmethod htcomponent-render ((htscript htscript) (page page)) -(let ((xml-p (page-xmloutput page)) - (body (htcomponent-body htscript)) - (previous-print-status (page-can-print page)) - (render-condition (htcomponent-render-condition htscript))) - (unless (and render-condition (null (funcall render-condition))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print htscript)) - (htcomponent-json-print-start-component htscript)) - (unless (getf (htcomponent-attributes htscript) :type) - (append '(:type "text/javascript") (htcomponent-attributes htscript))) - (when (page-can-print page) - (tag-render-starttag htscript page) - (when (and (null (getf (htcomponent-attributes htscript) :src)) - (not (null (htcomponent-body htscript)))) - (if (null xml-p) - (page-format page "~%//<!--~%") - (page-format page "~%//<[CDATA[~%")) - (unless (listp body) - (setf body (list body))) - (dolist (element body) - (when element - (cond - ((stringp element) (htcomponent-render ($raw> element) page)) - ((functionp element) (htcomponent-render ($raw> (funcall element)) page)) - (t (htcomponent-render element page))))) - (if (null xml-p) - (page-format page "~%//-->") - (page-format page "~%//]]>"))) - (setf (page-lasttag page) nil) - (tag-render-endtag htscript page)) - (when (null previous-print-status) - (setf (page-can-print page) nil) - (htcomponent-json-print-end-component htscript))))) + (let ((xml-p (page-xmloutput page)) + (body (htcomponent-body htscript)) + (previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition htscript))) + (unless (and render-condition (null (funcall render-condition))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print htscript)) + (htcomponent-json-print-start-component htscript)) + (unless (getf (htcomponent-attributes htscript) :type) + (append '(:type "text/javascript") (htcomponent-attributes htscript))) + (when (page-can-print page) + (tag-render-starttag htscript page) + (when (and (null (getf (htcomponent-attributes htscript) :src)) + (not (null (htcomponent-body htscript)))) + (if (null xml-p) + (page-format page "~%//<!--~%") + (page-format page "~%//<[CDATA[~%")) + (unless (listp body) + (setf body (list body))) + (dolist (element body) + (when element + (cond + ((stringp element) (htcomponent-render ($raw> element) page)) + ((functionp element) (htcomponent-render ($raw> (funcall element)) page)) + (t (htcomponent-render element page))))) + (if (null xml-p) + (page-format page "~%//-->") + (page-format page "~%//]]>"))) + (setf (page-lasttag page) nil) + (tag-render-endtag htscript page)) + (when (null previous-print-status) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htscript)))))
;;;========= HTLINK ====================================
(defmethod htcomponent-render ((htlink htlink) (page page)) -(let ((previous-print-status (page-can-print page)) - (render-condition (htcomponent-render-condition htlink))) - (unless (and render-condition (null (funcall render-condition))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print htlink)) - (htcomponent-json-print-start-component htlink)) - (when (page-can-print page) - (unless (getf (htcomponent-attributes htlink) :type) - (append '(:type "text/css") (htcomponent-attributes htlink))) - (unless (getf (htcomponent-attributes htlink) :rel) - (append '(:rel "styleshhet") (htcomponent-attributes htlink))) - (tag-render-starttag htlink page) - (tag-render-endtag htlink page)) - (when (null previous-print-status) - (setf (page-can-print page) nil) - (htcomponent-json-print-end-component htlink))))) + (let ((previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition htlink))) + (unless (and render-condition (null (funcall render-condition))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print htlink)) + (htcomponent-json-print-start-component htlink)) + (when (page-can-print page) + (unless (getf (htcomponent-attributes htlink) :type) + (append '(:type "text/css") (htcomponent-attributes htlink))) + (unless (getf (htcomponent-attributes htlink) :rel) + (append '(:rel "styleshhet") (htcomponent-attributes htlink))) + (tag-render-starttag htlink page) + (tag-render-endtag htlink page)) + (when (null previous-print-status) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htlink)))))
;;;========= HTBODY =================================== (defmethod htcomponent-render ((htbody htbody) (page page)) -(let ((body-list (htcomponent-body htbody)) - (previous-print-status (page-can-print page)) - (render-condition (htcomponent-render-condition htbody))) - (unless (and render-condition (null (funcall render-condition))) - (when (or (page-can-print page) previous-print-status) - (setf (page-can-print page) (htcomponent-can-print htbody)) - (htcomponent-json-print-start-component htbody)) - (when (page-can-print page) - (tag-render-starttag htbody page)) - (dolist (child-tag body-list) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) - (when (page-can-print page) - (htcomponent-render (htbody-init-scripts-tag page t) page) - (tag-render-endtag htbody page)) - (when (or (page-can-print page) previous-print-status) - (setf (page-can-print page) nil) - (htcomponent-json-print-end-component htbody))))) + (let ((body-list (htcomponent-body htbody)) + (previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition htbody))) + (unless (and render-condition (null (funcall render-condition))) + (when (or (page-can-print page) previous-print-status) + (setf (page-can-print page) (htcomponent-can-print htbody)) + (htcomponent-json-print-start-component htbody)) + (when (page-can-print page) + (tag-render-starttag htbody page)) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) + (when (page-can-print page) + (htcomponent-render (htbody-init-scripts-tag page t) page) + (tag-render-endtag htbody page)) + (when (or (page-can-print page) previous-print-status) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htbody)))))
(defmethod htbody-init-scripts-tag ((page page) &optional on-load) -(let ((js (script> :type "text/javascript")) - (js-control-string-directive (if on-load - " + (let ((js (script> :type "text/javascript")) + (js-control-string-directive (if on-load + " var bodyInitFunction = function(e){~{~a~}};~% if (/MSIE (\d+\.\d+);/.test(navigator.userAgent)) {~% window.attachEvent('onload', bodyInitFunction);~% } else {~% document.addEventListener('DOMContentLoaded', bodyInitFunction, false);~% }" - "~{~a~}~%")) - (page-body-init-scripts (page-body-init-scripts page))) - (setf (htcomponent-page js) page - (htcomponent-body js) (when page-body-init-scripts - (format nil js-control-string-directive (if (listp page-body-init-scripts) - page-body-init-scripts - (list page-body-init-scripts))))) - js)) + "~{~a~}~%")) + (page-body-init-scripts (page-body-init-scripts page))) + (setf (htcomponent-page js) page + (htcomponent-body js) (when page-body-init-scripts + (format nil js-control-string-directive (if (listp page-body-init-scripts) + page-body-init-scripts + (list page-body-init-scripts))))) + js))
;;;========= WCOMPONENT =================================== (defclass wcomponent (htcomponent) -((reserved-parameters :initarg :reserved-parameters - :accessor wcomponent-reserved-parameters - :type cons - :documentation "Parameters that may not be used in the constructor function") - (json-error-monitor-p :initarg :json-error-monitor-p - :accessor htcomponent-json-error-monitor-p - :documentation "When not nil, if the client has sent a XHR call, let the page to fill the errorComponents property of the json reply.") - (informal-parameters :initform () - :accessor wcomponent-informal-parameters - :type cons - :documentation "Informal parameters are parameters optional for the component") - (allow-informal-parameters :initarg :allow-informal-parameters - :reader wcomponent-allow-informal-parametersp - :allocation :class - :documentation "Determines if the component accepts informal parameters")) -(:default-initargs :reserved-parameters nil - :allow-informal-parameters t) -(:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own.")) + ((reserved-parameters :initarg :reserved-parameters + :accessor wcomponent-reserved-parameters + :type cons + :documentation "Parameters that may not be used in the constructor function") + (json-error-monitor-p :initarg :json-error-monitor-p + :accessor htcomponent-json-error-monitor-p + :documentation "When not nil, if the client has sent a XHR call, let the page to fill the errorComponents property of the json reply.") + (informal-parameters :initform () + :accessor wcomponent-informal-parameters + :type cons + :documentation "Informal parameters are parameters optional for the component") + (allow-informal-parameters :initarg :allow-informal-parameters + :reader wcomponent-allow-informal-parametersp + :allocation :class + :documentation "Determines if the component accepts informal parameters")) + (:default-initargs :reserved-parameters nil + :allow-informal-parameters t) + (:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own."))
(defun slot-initarg-p (initarg class-precedence-list) -"Returns nil if a slot with that initarg isn't found into the list of classes passed" -(loop for class in class-precedence-list - do (let* ((direct-slots (closer-mop:class-direct-slots class)) - (result (loop for slot in direct-slots - do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg) - (return initarg))))) - (when result - (return result))))) + "Returns nil if a slot with that initarg isn't found into the list of classes passed" + (loop for class in class-precedence-list + do (let* ((direct-slots (closer-mop:class-direct-slots class)) + (result (loop for slot in direct-slots + do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg) + (return initarg))))) + (when result + (return result)))))
(defmethod initialize-instance :after ((instance wcomponent) &rest rest) -(let* ((class-precedence-list (closer-mop:compute-class-precedence-list (class-of instance))) - (informal-parameters (loop for (k v) on rest by #'cddr - for result = () - do (unless (slot-initarg-p k class-precedence-list) - (push v result) - (push k result)) - finally (return result)))) - (setf (slot-value instance 'informal-parameters) informal-parameters))) + (let* ((class-precedence-list (closer-mop:compute-class-precedence-list (class-of instance))) + (informal-parameters (loop for (k v) on rest by #'cddr + for result = () + do (unless (slot-initarg-p k class-precedence-list) + (push v result) + (push k result)) + finally (return result)))) + (setf (slot-value instance 'informal-parameters) informal-parameters)))
(defmethod (setf slot-initialization) (value (wcomponent wcomponent) slot-initarg) -(let* ((initarg (if (or (eq slot-initarg :static-id) (eq slot-initarg :id)) :client-id slot-initarg)) - (new-value (if (eq slot-initarg :id) (generate-id value) value)) - (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent)) - 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)) - (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)) - (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value)))))) + (let* ((initarg (if (or (eq slot-initarg :static-id) (eq slot-initarg :id)) :client-id slot-initarg)) + (new-value (if (eq slot-initarg :id) (generate-id value) value)) + (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent)) + 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)) + (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)) + (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value))))))
(defun make-component (name parameters content) -"This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the + "This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the initarg of a slot, and informal parameters, that have their own slot in common. The CONTENT is the body content." -(unless (or (getf parameters :id) - (getf parameters :static-id)) - (setf (getf parameters :id) "claw")) -(let* ((instance (make-instance name)) - (id (getf parameters :id)) - (static-id (getf parameters :static-id)) - (real-id (or static-id id))) - (setf (htcomponent-real-id instance) real-id) - (when static-id - (remf parameters :id)) - (loop for (initarg value) on parameters by #'cddr - do (setf (slot-initialization instance initarg) value)) - (setf (htcomponent-body instance) content) - instance)) + (unless (or (getf parameters :id) + (getf parameters :static-id)) + (setf (getf parameters :id) "claw")) + (let* ((instance (make-instance name)) + (id (getf parameters :id)) + (static-id (getf parameters :static-id)) + (real-id (or static-id id))) + (setf (htcomponent-real-id instance) real-id) + (when static-id + (remf parameters :id)) + (loop for (initarg value) on parameters by #'cddr + do (setf (slot-initialization instance initarg) value)) + (setf (htcomponent-body instance) content) + instance))
(defun build-component (component-name &rest rest) -"This function is the one that WCOMPONENT init functions call to intantiate their relative components. + "This function is the one that WCOMPONENT init functions call to intantiate their relative components. The REST parameter is flattened and divided into a pair, where the first element is the alist of the component parameters, while the second is the component body." -(let ((fbody (parse-htcomponent-function (flatten rest)))) - (make-component component-name (first fbody) (second fbody)))) + (let ((fbody (parse-htcomponent-function (flatten rest)))) + (make-component component-name (first fbody) (second fbody))))
(defmethod htcomponent-rewind ((wcomponent wcomponent) (page page)) -(let ((template (wcomponent-template wcomponent))) - (wcomponent-before-rewind wcomponent page) - (if (listp template) - (dolist (tag template) - (htcomponent-rewind tag page)) - (htcomponent-rewind template page)) - (wcomponent-after-rewind wcomponent page))) + (let* ((template (wcomponent-template wcomponent)) + (current-form (page-current-form page)) + (call-rewind-methods-p (and (null *validation-errors*) + current-form + (string= (htcomponent-client-id current-form) (page-req-parameter page *rewind-parameter*))))) + (when call-rewind-methods-p + (wcomponent-before-rewind wcomponent page)) + (if (listp template) + (dolist (tag template) + (htcomponent-rewind tag page)) + (htcomponent-rewind template page)) + (when call-rewind-methods-p + (wcomponent-after-rewind wcomponent page))))
(defmethod wcomponent-before-rewind ((wcomponent wcomponent) (page page))) (defmethod wcomponent-after-rewind ((wcomponent wcomponent) (page page)))
(defmethod htcomponent-prerender ((wcomponent wcomponent) (page page)) -(let ((render-condition (htcomponent-render-condition wcomponent))) - (unless (and render-condition (null (funcall render-condition))) - (wcomponent-before-prerender wcomponent page) - (let ((previous-print-status (page-can-print page)) - (template (wcomponent-template wcomponent))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print wcomponent))) - (when (page-can-print page) - (let ((script-files (htcomponent-script-files wcomponent))) - (dolist (script (if (listp script-files) - script-files - (list script-files))) - (pushnew script (page-script-files page) :test #'equal))) - (let ((css-files (htcomponent-stylesheet-files wcomponent))) - (dolist (css (if (listp css-files) - css-files - (list css-files))) - (pushnew css (page-stylesheet-files page) :test #'equal))) - (dolist (js (htcomponent-class-initscripts wcomponent)) - (pushnew js (page-class-initscripts page) :test #'equal)) - (when (htcomponent-instance-initscript wcomponent) - (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal))) - (if (listp template) - (dolist (tag template) - (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-prerender tag page))) - (htcomponent-prerender template page)) - (when (null previous-print-status) - (setf (page-can-print page) nil))) - (wcomponent-after-prerender wcomponent page)))) + (let ((render-condition (htcomponent-render-condition wcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (wcomponent-before-prerender wcomponent page) + (let ((previous-print-status (page-can-print page)) + (template (wcomponent-template wcomponent))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print wcomponent))) + (when (page-can-print page) + (let ((script-files (htcomponent-script-files wcomponent))) + (dolist (script (if (listp script-files) + script-files + (list script-files))) + (pushnew script (page-script-files page) :test #'equal))) + (let ((css-files (htcomponent-stylesheet-files wcomponent))) + (dolist (css (if (listp css-files) + css-files + (list css-files))) + (pushnew css (page-stylesheet-files page) :test #'equal))) + (dolist (js (htcomponent-class-initscripts wcomponent)) + (pushnew js (page-class-initscripts page) :test #'equal)) + (when (htcomponent-instance-initscript wcomponent) + (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal))) + (if (listp template) + (dolist (tag template) + (when (subtypep (type-of tag) 'htcomponent) + (htcomponent-prerender tag page))) + (htcomponent-prerender template page)) + (when (null previous-print-status) + (setf (page-can-print page) nil))) + (wcomponent-after-prerender wcomponent page))))
(defmethod wcomponent-before-prerender ((wcomponent wcomponent) (page page))) (defmethod wcomponent-after-prerender ((wcomponent wcomponent) (page page)))
(defmethod htcomponent-render ((wcomponent wcomponent) (page page)) -(let ((template (wcomponent-template wcomponent)) - (previous-print-status (page-can-print page)) - (render-condition (htcomponent-render-condition wcomponent))) - (unless (and render-condition (null (funcall render-condition))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print wcomponent)) - (htcomponent-json-print-start-component wcomponent)) - (wcomponent-before-render wcomponent page) - (unless (listp template) - (setf template (list template))) - (dolist (child-tag template) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) - (wcomponent-after-render wcomponent page) - (when (null previous-print-status) - (setf (page-can-print page) nil) - (htcomponent-json-print-end-component wcomponent))))) + (let ((template (wcomponent-template wcomponent)) + (previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition wcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print wcomponent)) + (htcomponent-json-print-start-component wcomponent)) + (wcomponent-before-render wcomponent page) + (unless (listp template) + (setf template (list template))) + (dolist (child-tag template) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) + (wcomponent-after-render wcomponent page) + (when (null previous-print-status) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component wcomponent)))))
(defmethod wcomponent-before-render ((wcomponent wcomponent) (page page))) (defmethod wcomponent-after-render ((wcomponent wcomponent) (page page)))
Modified: trunk/main/claw-html/src/translators.lisp ============================================================================== --- trunk/main/claw-html/src/translators.lisp (original) +++ trunk/main/claw-html/src/translators.lisp Mon Sep 1 11:33:48 2008 @@ -61,18 +61,20 @@ (:default-initargs :validation-error-control-string nil))
(defmethod translator-value-encode ((translator translator) value) - (format nil "~a" value)) + (if value + (format nil "~a" value) + ""))
(defmethod translator-value-type-to-string ((translator translator) value) (translator-value-encode translator value))
(defmethod translator-encode ((translator translator) (wcomponent base-cinput)) (let* ((page (htcomponent-page wcomponent)) - (visit-object (or (cinput-visit-object wcomponent) page)) + (visit-object (cinput-visit-object wcomponent)) (accessor (cinput-accessor wcomponent)) (reader (cinput-reader wcomponent)) (value (page-req-parameter page (name-attr wcomponent) nil))) - (if (component-validation-errors wcomponent) + (if (or (component-validation-errors wcomponent) (null visit-object)) value (progn (setf value (cond @@ -85,7 +87,9 @@
(defmethod translator-value-decode ((translator translator) value &optional client-id label) (declare (ignore client-id label)) - value) + (if (string= value "") + nil + value))
(defmethod translator-value-string-to-type ((translator translator) value &optional client-id label) (translator-value-decode translator value client-id label))