[claw-cvs] r71 - in trunk/main/claw-html: . src
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Tue Aug 26 10:50:30 UTC 2008
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))))
-|#
More information about the Claw-cvs
mailing list