[claw-cvs] r78 - trunk/main/claw-html/src
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Mon Sep 1 15:33:48 UTC 2008
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))
More information about the Claw-cvs
mailing list