Author: achiumenti Date: Tue Aug 26 06:50:29 2008 New Revision: 71 Modified: trunk/main/claw-html/claw-html.asd trunk/main/claw-html/src/components.lisp trunk/main/claw-html/src/packages.lisp trunk/main/claw-html/src/tags.lisp Log: CLAW html framework Modified: trunk/main/claw-html/claw-html.asd ============================================================================== --- trunk/main/claw-html/claw-html.asd (original) +++ trunk/main/claw-html/claw-html.asd Tue Aug 26 06:50:29 2008 @@ -41,8 +41,8 @@ ;(:file "connector" :depends-on ("misc")) ;(:file "logger" :depends-on ("misc")) ;(:file "session-manager" :depends-on ("misc")) - (:file "tags" :depends-on ("packages")) - (:file "meta" :depends-on ("packages")) + (:file "meta" :depends-on ("packages")) + (:file "tags" :depends-on ("packages" "meta")) (:file "components" :depends-on ("tags" "meta")) (:file "validators" :depends-on ("components")) (:file "translators" :depends-on ("validators")))))) Modified: trunk/main/claw-html/src/components.lisp ============================================================================== --- trunk/main/claw-html/src/components.lisp (original) +++ trunk/main/claw-html/src/components.lisp Tue Aug 26 06:50:29 2008 @@ -61,13 +61,16 @@ ((action :initarg :action :accessor action :documentation "Function performed after user submission") + (action-object :initarg :action-object + :accessor action-object + :documentation "The object that will be applied to the ACTION property") (css-class :initarg :class :reader css-class :documentation "The html CLASS attribute") (method :initarg :method :reader form-method :documentation "Form post method (may be \"get\" or \"post\")")) - (:default-initargs :action nil :class nil :method "post") + (:default-initargs :action nil :class nil :method "post" :action-object nil) (:documentation "Internal use component")) (defmethod wcomponent-after-rewind ((obj _cform) (pobj page)) @@ -76,7 +79,7 @@ (when (and (null validation-errors) action (cform-rewinding-p obj pobj)) - (funcall action pobj)))) + (funcall action (or (action-object obj) pobj))))) (defmethod cform-rewinding-p ((cform _cform) (page page)) (string= (htcomponent-client-id cform) @@ -213,8 +216,8 @@ (defclass cinput (base-cinput) ((input-type :initarg :type - :reader input-type - :documentation "The html <input> TYPE attribute. For submit type, use the CSUBMIT> function.")) + :reader input-type + :documentation "The html <input> TYPE attribute. For submit type, use the CSUBMIT> function.")) (:metaclass metacomponent) (:default-initargs :reserved-parameters (list :value :name) :empty t :type "text") (:documentation "Request cycle aware component the renders as an INPUT tag class")) @@ -254,7 +257,6 @@ (writer (cinput-writer cinput)) (validator (validator cinput)) (value (translator-decode (translator cinput) cinput))) -; (log-message :info "********************* ~a : ~a" cinput value) (unless (or (null value) (component-validation-errors cinput)) (when validator (funcall validator value)) @@ -367,7 +369,8 @@ (current-form (page-current-form pobj)) (submitted-p (page-req-parameter pobj (htcomponent-client-id obj)))) (unless (or (null current-form) (null submitted-p) (null action)) - (setf (action current-form) action))))) + (setf (action current-form) action + (action-object current-form) (or (action-object obj) (action-object current-form))))))) ;----------------------------------------------------------------------------- (defclass submit-link (csubmit) Modified: trunk/main/claw-html/src/packages.lisp ============================================================================== --- trunk/main/claw-html/src/packages.lisp (original) +++ trunk/main/claw-html/src/packages.lisp Tue Aug 26 06:50:29 2008 @@ -47,8 +47,10 @@ #:render-error-page ;#:duplicate-back-slashes + #:attribute-value #:build-tagf #:page + #:page-before-render #:page-render #:make-page-renderer #:page-current-form @@ -80,6 +82,7 @@ #:$> #:$raw> ;empty tags definition + #:*empty-tags* #:area> #:base> #:basefont> Modified: trunk/main/claw-html/src/tags.lisp ============================================================================== --- trunk/main/claw-html/src/tags.lisp (original) +++ trunk/main/claw-html/src/tags.lisp Tue Aug 26 06:50:29 2008 @@ -64,6 +64,10 @@ (:documentation "This method is the main method fired from the framework to render the desired page and to handle all the request cycle. - PAGE is the page instance that must be given")) +(defgeneric page-before-render (page) + (:documentation "This method is called as first instruction of PAGE-RENDER. + - PAGE is the page instance that must be given")) + (defgeneric page-init-injections (page) (:documentation "This internal method is called during the request cycle phase to reset page slots that must be reinitialized during sub-phases (rewinding, pre-rendering, rendering). @@ -247,9 +251,9 @@ "List of component id that pass the validation") (defvar *claw-current-page* nil - "The CLAW page currently rendering") + "The CLAW page currently rendering") -(defvar *id-table-map* +(defvar *id-table-map* (make-hash-table :test 'equal) "Holds an hash table of used components/tags id as keys and the number of their occurrences as values. So if you have a :id \"compId\" given to a previous component, the second time this id will be used, it will be rendered as \"compId_1\", the third time will be \"compId_2\" and so on") @@ -261,7 +265,13 @@ (defvar *file-translator* nil "*FILE-TRANSLATOR* is the default translator for any CINPUT component of type \"file\".") - +(defstruct list-for-tag-attribute + "Since tag attributes values are flattened, it is impossible to pass lists as values. Use this struct to pass lists to values" + (value nil)) + +(defun attribute-value (value) + "Creates an unflattenable value for tag attributes. This is particularly useful when you need to pass a list as an attribute value" + (make-list-for-tag-attribute :value value)) (defun flatten (tree &optional result-list) "Traverses the tree in order, collecting even non-null leaves into a list." @@ -290,7 +300,7 @@ do (if (and (null body) (or (keywordp elem) (keywordp last-elem))) - (push elem attributes) + (push (or (when (list-for-tag-attribute-p elem) (list-for-tag-attribute-value elem)) elem) attributes) (when elem (push elem body)))) (list (reverse attributes) (reverse body)))) @@ -356,24 +366,6 @@ ;;;---------------------------------------------------------------- -#| -(defclass message-dispatcher () - () - (:documentation "This is and interface for message dispatchers")) - -(defclass simple-message-dispatcher (message-dispatcher) - ((locales :initform (make-hash-table :test #'equal) - :accessor simple-message-dispatcher-locales - :documentation "Hash table of locales strings and KEY/VALUE message pairs")) - (:documentation "A message disptcher that leave data unchanged during encoding and decoding phases.")) - -(defclass i18n-aware (message-dispatcher) - ((message-dispatcher :initarg :message-dispatcher - :accessor message-dispatcher - :documentation "Reference to a MESSAGE-DISPATCHER instance")) - (:default-initargs :message-dispatcher nil) - (:documentation "All classes that need to dispatch messages are subclasses of I18N-AWARE")) -|# (defclass page() ((writer :initarg :writer @@ -412,8 +404,8 @@ :reader page-post-parameters :documentation "http request post parameters") (get-parameters :initarg :get-parameters - :reader page-get-parameters - :documentation "http request get parameters") + :reader page-get-parameters + :documentation "http request get parameters") (components-stack :initform nil :accessor page-components-stack :documentation "A stack of components enetered into rendering process.") @@ -424,8 +416,8 @@ :accessor page-external-format-encoding :documentation "Symbol for page charset encoding \(Such as UTF-8)") (injection-writing-p :initform nil - :accessor page-injection-writing-p - :documentation "Flag that becomes true when rendering page injections")) + :accessor page-injection-writing-p + :documentation "Flag that becomes true when rendering page injections")) (:default-initargs :writer t :external-format-encoding :utf-8 :script-files nil @@ -444,7 +436,13 @@ (defun make-page-renderer (page-class http-post-parameters http-get-parameters) "Generates a lambda function from PAGE-RENDER method, that may be used into LISPLET-REGISTER-FUNCTION-LOCATION" #'(lambda () (with-output-to-string (*standard-output*) - (page-render (make-instance page-class :post-parameters http-post-parameters :get-parameters http-get-parameters))))) + (page-render (make-instance page-class + :post-parameters (if (functionp http-post-parameters) + (funcall http-post-parameters) + http-post-parameters) + :get-parameters (if (functionp http-get-parameters) + (funcall http-get-parameters) + http-get-parameters)))))) (defclass htcomponent () ((page :initarg :page @@ -661,44 +659,45 @@ (let ((js-array (ps:ps* `(array ,@*validation-compliances*)))) (subseq js-array 0 (1- (length js-array))))) +(defmethod page-before-render ((page page)) + nil) + (defmethod page-render ((page page)) (let ((*claw-current-page* page) - (*id-table-map* nil) + (*id-table-map* (make-hash-table :test 'equal)) (*validation-errors* nil) (*validation-compliances* nil) - (body (page-content page)) (jsonp (page-json-id-list page))) - (if (null body) - (format nil "null body for page ~a~%" (type-of page)) - (progn - (page-init page) - (when (page-req-parameter page *rewind-parameter*) - (htcomponent-rewind body page)) - (page-init page) - (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!! - (page-render-headings page) - (page-init page) - (when jsonp - (page-format-raw page (page-json-prefix page)) - (page-format-raw page "{components:{")) - (htcomponent-render (page-content page) page) ;Here we need a fresh new body!!! - (when jsonp - (page-format-raw page "},classInjections:\"") - (setf (page-can-print page) t - (page-injection-writing-p page) t) - (dolist (injection (page-init-injections page)) - (when injection - (htcomponent-render injection page))) - (page-format-raw page "\",instanceInjections:\"") - (let ((init-scripts (htbody-init-scripts-tag page))) - (when init-scripts - (htcomponent-render init-scripts page))) - (page-format-raw page "\",errors:") - (page-format-raw page (json-validation-errors)) - (page-format-raw page ",valid:") - (page-format-raw page (json-validation-compliances)) - (page-format-raw page "}") - (page-format-raw page (page-json-suffix page))))))) + (progn + (page-init page) + (page-before-render page) + (when (page-req-parameter page *rewind-parameter*) + (htcomponent-rewind (page-content page) page)) + (page-init page) + (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!! + (page-render-headings page) + (page-init page) + (when jsonp + (page-format-raw page (page-json-prefix page)) + (page-format-raw page "{components:{")) + (htcomponent-render (page-content page) page) ;Here we need a fresh new body!!! + (when jsonp + (page-format-raw page "},classInjections:\"") + (setf (page-can-print page) t + (page-injection-writing-p page) t) + (dolist (injection (page-init-injections page)) + (when injection + (htcomponent-render injection page))) + (page-format-raw page "\",instanceInjections:\"") + (let ((init-scripts (htbody-init-scripts-tag page))) + (when init-scripts + (htcomponent-render init-scripts page))) + (page-format-raw page "\",errors:") + (page-format-raw page (json-validation-errors)) + (page-format-raw page ",valid:") + (page-format-raw page (json-validation-compliances)) + (page-format-raw page "}") + (page-format-raw page (page-json-suffix page)))))) (defmethod page-body-init-scripts ((page page)) (let ((js-body "")) @@ -757,225 +756,227 @@ (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-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))) (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*)) + (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))))) (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*)) + (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 "\"")))) (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 +(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) (page-format page ">") - (incf (page-tabulator page))) - (if (null xml-p) - (page-format page ">") - (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 =================================== @@ -983,397 +984,284 @@ (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." - (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))) + (wcomponent-before-rewind wcomponent page) + (if (listp template) + (dolist (tag template) + (htcomponent-rewind tag page)) + (htcomponent-rewind template page)) + (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))) -(defclass error-page (page) - ((title :initarg :title - :reader page-title - :documentation "The page title") - (error-code :initarg :error-code - :reader page-error-code - :documentation "The error code to display")) - (:documentation "This is the page class used to render -the http error messages.")) - -(defclass error-page-template (wcomponent) - ((title :initarg :title - :reader title - :documentation "The page title") - (error-code :initarg :error-code - :reader error-code - :documentation "The http error code. For details consult http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html") - (style :initarg :style - :reader style - :documentation "The CSS <style> element, used to beautify the error page.")) - (:default-initargs :style " -body { - font-family: arial, elvetica; - font-size: 7pt; -} -span.blue { - background-color: #525D76; - color: white; - font-weight: bolder; - margin-right: .25em; -} -p.h1, p.h2 { - background-color: #525D76; - color: white; - font-weight: bolder; - font-size: 2em; - margin: 0; - margin-bottom: .5em; -} -p.h2 {font-size: 1.5em;}" :empty t :allow-informal-parameters nil) - (:metaclass metacomponent) - (:documentation "The template for the error-page")) - -(let ((class (find-class 'error-page-template))) - (closer-mop:ensure-finalized class) - (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) - (format nil "Description: ~a~%Parameters:~%~a~%~%~a" - "Function that instantiates an ERROR-PAGE-TEMPLATE component and renders a html tenplate for CLAW generic error pages." - (describe-html-attributes-from-class-slot-initargs class) - (describe-component-behaviour class)))) - -(defmethod wcomponent-template ((error-page-template error-page-template)) - (let ((error-code (error-code error-page-template)) - (title (title error-page-template)) - (style (style error-page-template)) - (request-uri (connector-request-uri (clawserver-connector *clawserver*)))) - (html> - (head> - (title> title) - (style> style)) - (body> - (p> - (p> :class "h1" - (format nil "HTTP Status ~a - ~a" error-code request-uri)) - (hr> :noshade "noshade") - (p> - (span> :class "blue" - ($> "type")) - "Status report") - (p> - (span> :class "blue" - "url") - request-uri) - (p> - (span> :class "blue" - "description") - (gethash error-code *http-reason-phrase-map*) - (hr> :noshade "noshade")) - (p> :class "h2" - "claw server")))))) - -(defmethod page-content ((error-page error-page)) - (let ((connector (clawserver-connector *clawserver*))) - (error-page-template> :title (page-title error-page) - :error-code (page-error-code error-page) - (format nil "The requested resource (~a) is not available." (connector-request-uri connector))))) - -(defun render-error-page (&optional (error-code 404)) - "This function renders a http error page." - (let ((connector (clawserver-connector clawserver))) - (page-render (make-instance 'error-page - :title (format nil "Server error: ~a" error-code) - :error-code error-code)))) -#| -(defmethod message-dispatch ((message-dispatcher message-dispatcher) key locale) nil) - -(defmethod message-dispatch ((i18n-aware i18n-aware) key locale) - (let ((dispatcher (message-dispatcher i18n-aware)) - (result)) - (when dispatcher - (progn - (setf result (message-dispatch dispatcher key locale)) - (when (and (null result) (> (length locale) 2)) - (setf result (message-dispatch dispatcher key (subseq locale 0 2)))))) - result)) - -(defmethod simple-message-dispatcher-add-message ((simple-message-dispatcher simple-message-dispatcher) locale key value) - (let ((current-locale (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher) (make-hash-table :test #'equal)))) - (setf (gethash key current-locale) value) - (setf (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher)) current-locale))) - -(defmethod message-dispatch ((simple-message-dispatcher simple-message-dispatcher) key locale) - (let ((current-locale (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher)))) - (when current-locale - (gethash key current-locale)))) -|#