Author: achiumenti Date: Fri Feb 15 07:53:10 2008 New Revision: 7 Modified: trunk/main/claw-core/src/lisplet.lisp trunk/main/claw-core/src/misc.lisp trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/tags.lisp Log: added some comments, corrected some methods for authentication, corrected some naming conventions Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Fri Feb 15 07:53:10 2008 @@ -179,15 +179,16 @@ (login-config (current-config)) (login-page (lisplet-login-page lisplet)) (server (current-server request)) - (auth-basicp (eq (lisplet-authentication-type lisplet) :basic))) - (when (and auth-basicp (null princp)) - (configuration-login login-config)) - (setf (return-code) +http-ok+ - princp (current-principal)) - (when (and login-page - (cl-ppcre:all-matches login-page uri)) - (redirect-to-https server request)) - (loop for protected-resource in protected-resources + (auth-basicp (eq (lisplet-authentication-type lisplet) :basic))) + (setf (return-code) +http-ok+) + (when login-config + (when (and auth-basicp (null princp)) + (configuration-login login-config)) + (setf princp (current-principal)) + (when (and login-page + (cl-ppcre:all-matches login-page uri)) + (redirect-to-https server request)) + (loop for protected-resource in protected-resources for match = (format nil "^~a" (car protected-resource)) for allowed-roles = (cdr protected-resource) do (when (cl-ppcre:all-matches match uri) @@ -200,9 +201,9 @@ (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm))))) (setf (return-code) +http-authorization-required+) (throw 'handler-done nil)) - (unless (loop for role in (principal-roles princp) thereis (member role allowed-roles :test #'equal)) + (unless (user-in-role-p) (setf (return-code) +http-forbidden+) - (throw 'handler-done nil))))))) + (throw 'handler-done nil)))))))) (defun lisplet-start-session () (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet))))) \ No newline at end of file Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Fri Feb 15 07:53:10 2008 @@ -86,7 +86,7 @@ (when session (session-value 'principal session))) -(defun user-in-rolep (roles &optional (session *session*)) +(defun user-in-role-p (roles &optional (session *session*)) "Detects if current principal belongs to any of the expressed roles" (let ((principal (current-principal session))) (when principal Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Fri Feb 15 07:53:10 2008 @@ -48,7 +48,7 @@ ;:request-realm :request-id-table-map ;:dyna-id - :tag-empty-p + :tag-emptyp :tag-symbol-class :strings-to-jsarray :empty-string-p @@ -265,5 +265,5 @@ :current-lisplet :current-server :current-realm - :user-in-rolep + :user-in-role-p :login)) Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Fri Feb 15 07:53:10 2008 @@ -31,206 +31,216 @@ -(defgeneric page-req-parameter (obj name &optional as-list) +(defgeneric page-req-parameter (page name &optional as-list) (:documentation "This method returns a request parameter given by NAME searching first into post parameters and, if no parameter found, into get prarmeters. The optional function parameter AS-LIST if true returns the result as list. When AS-LIST is true, if the searched parameter is found more then once, a list with all valuse given to param NAME is returned. - - OBJ is the page instance that must be given. + - PAGE is the page instance that must be given. - NAME The parameter to search - AS-LIST If true the result is returned as list, if false as string. Default: false")) -(defgeneric page-json-id-list (obj) +(defgeneric page-json-id-list (page) (:documentation "This internal method is called to get a list of all the components by their id, that must be updated when an xhr request is sent from the browser. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-content (obj) +(defgeneric page-content (page) (:documentation "This method returns the page content to be redered. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-init (obj) +(defgeneric page-init (page) (:documentation "Internal method for page initialization. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-render (obj) +(defgeneric page-render (page) (:documentation "This method is the main method fired from the framework to render the desired page and to handle all the request cycle. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-init-injections (pobj) +(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). - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-render-headings (obj) +(defgeneric page-render-headings (page) (:documentation "This internal method renders the html first lines that determine if the page is a html or a xhtml, along with the schema definition. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-request-parameters (obj) +(defgeneric page-request-parameters (page) (:documentation "This internal method builds the get and post parameters into an hash table. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-print-tabulation (obj) +(defgeneric page-print-tabulation (page) (:documentation "This internal method is called during the rendering phase if tabulation is enabled. It writes the right amount of tabs chars to indent the page. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-newline (obj) +(defgeneric page-newline (page) (:documentation "This internal method simply writes the rest of page content on a new line when needed. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-format (obj str &rest rest) +(defgeneric page-format (page str &rest rest) (:documentation "This internal method is the replacement of the FORMAT function. It is aware of an xhr request when the reply must be given as a json object. It also uses the default page output stream to render the output. - - OBJ is the page instance that must be given + - PAGE is the page instance that must be given - STR The format control - REST The format arguments See http://www.lisp.org/HyperSpec/Body/fun_format.html#format for more info.")) -(defgeneric page-format-raw (obj str &rest rest) +(defgeneric page-format-raw (page str &rest rest) (:documentation "This internal method is the replacement of the FORMAT. The difference with PAGE-FORMAT is that it prints out the result ignoring the json directive. It also uses the default page output stream as PAGE-FORMAT does to render the output. - - OBJ is the page instance that must be given + - PAGE is the page instance that must be given - STR The format control - REST The format arguments See http://www.lisp.org/HyperSpec/Body/fun_format.html#format for more info.")) -(defgeneric page-body-init-scripts (page-obj) +(defgeneric page-body-init-scripts (page) (:documentation "During the render phase wcomponent instances inject their initialization scripts (javascript) that will be evaluated when the page has been loaded. This internal method is called to render these scripts. - - PAGE-OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric htbody-init-scripts-tag (page-obj) +(defgeneric htbody-init-scripts-tag (page) (:documentation "Encloses the init inscance scripts injected into the page into a <script> tag component See PAGE-BODY-INIT-SCRIPTS form more info. - - PAGE-OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric htcomponent-rewind (obj page-obj) +(defgeneric htcomponent-rewind (htcomponent page) (:documentation "This internal method is the first called during the request cycle phase. It is evaluated when a form action or an action-link action is fired. It is used to update all visit objects slots. - - OBJ is the htcomponent instance that must be rewound - - PAGE-OBJ is the page instance that must be given")) + - HTCOMPONENT is the htcomponent instance that must be rewound + - PAGE is the page instance that must be given")) -(defgeneric htcomponent-prerender (obj page-obj) +(defgeneric htcomponent-prerender (htcomponent page) (:documentation "This internal method is the second sub phase during the request cycle phase. It is used to inject all wcomponent class scripts and stylesheets into the owner page. - - OBJ is the htcomponent instance that must be prerendered - - PAGE-OBJ is the page instance that must be given")) + - HTCOMPONENT is the htcomponent instance that must be prerendered + - PAGE is the page instance that must be given")) -(defgeneric htcomponent-render (obj page-obj) +(defgeneric htcomponent-render (htcomponent page) (:documentation "This internal method is the last called during the request cycle phase. It is used to effectively render the component into the page. - - OBJ is the htcomponent instance that must be rendered - - PAGE-OBJ is the page instance that must be given")) + - HTCOMPONENT is the htcomponent instance that must be rendered + - PAGE is the page instance that must be given")) -(defgeneric htcomponent-can-print (obj) +(defgeneric htcomponent-can-print (htcomponent) (:documentation "This internal method is used in an xhr call to determine if a component may be rendered into the reply - - OBJ is the htcomponent instance")) + - HTCOMPONENT is the htcomponent instance")) -(defgeneric htcomponent-json-print-start-component (obj) +(defgeneric htcomponent-json-print-start-component (htcomponent) (:documentation "Internal method called to render the json reply during the render cycle phase on component start. - - OBJ is the htcomponent instance")) + - HTCOMPONENT is the htcomponent instance")) -(defgeneric htcomponent-json-print-end-component (obj) +(defgeneric htcomponent-json-print-end-component (htcomponent) (:documentation "Internal method called to render the json reply during the render cycle phase on component end. - - OBJ is the htcomponent instance")) + - HTCOMPONENT is the htcomponent instance")) -(defgeneric tag-render-starttag (obj page-obj) +(defgeneric tag-render-starttag (tag page) (:documentation "Internal method to print out the opening html tag during the render phase - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - TAG is the tag instance + - PAGE the page instance")) -(defgeneric tag-render-endtag (obj page-obj) +(defgeneric tag-render-endtag (tag page) (:documentation "Internal method to print out the closing html tag during the render phase - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - TAG is the tag instance + - PAGE the page instance")) -(defgeneric tag-render-attributes (obj page-obj) +(defgeneric tag-render-attributes (tag page) (:documentation "Internal method to print out the attributes of an html tag during the render phase - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - TAG is the tag instance + - PAGE the page instance")) -(defgeneric (setf htcomponent-page) (page-obj obj) +(defgeneric (setf htcomponent-page) (page htcomponent) (:documentation "Internal method to set the component owner page and to assign an unique id attribute when provided. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - HTCOMPONENT is the tag instance + - PAGE the page instance")) -(defgeneric wcomponent-parameter-value (obj key) +(defgeneric wcomponent-parameter-value (wcomponent key) (:documentation "Returns the value of a parameter passed to the wcomponent initialization function (the one generated with DEFCOMPONENT) or :UNDEFINED if not passed. - - OBJ is the wcomponent instance + - WCOMPONENT is the wcomponent instance - KEY the parameter key to query")) -(defgeneric wcomponent-check-parameters(obj) +(defgeneric wcomponent-check-parameters(wcomponent) (:documentation "This internal method check if all :REQUIRED parameters are provided - - OBJ is the wcomponent instance")) + - WCOMPONENT is the wcomponent instance")) -(defgeneric wcomponent-parameters(obj) +(defgeneric wcomponent-parameters(wcomponent) (:documentation "This method returns class formal parameters as an alist (formal parameters are the ones expected by the component) - - OBJ is the wcomponent instance")) -(defgeneric wcomponent-informal-parameters(obj) + - WCOMPONENT is the wcomponent instance")) + +(defgeneric wcomponent-informal-parameters(wcomponent) (:documentation "This method returns class informal parameters as an alist (informal parameters are the ones not expected by the component, usually rendered as tag attributes withot any kind of evaluation) - - OBJ is the wcomponent instance")) + - WCOMPONENT is the wcomponent instance")) -(defgeneric wcomponent-before-rewind (obj page-obj) +(defgeneric wcomponent-before-rewind (wcomponent page) (:documentation "Method called by the framework before the rewinding phase. It is intended to be eventually overridden in descendant classes. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - WCOMPONENT is the tag instance + - PAGE the page instance")) -(defgeneric wcomponent-after-rewind (obj page-obj) +(defgeneric wcomponent-after-rewind (wcomponent page) (:documentation "Method called by the framework after the rewinding phase. It is intended to be eventually overridden in descendant classes. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) -(defgeneric wcomponent-before-prerender (obj page-obj) + - WCOMPONENT is the tag instance + - PAGE the page instance")) +(defgeneric wcomponent-before-prerender (wcomponent page) (:documentation "Method called by the framework before the pre-rendering phase. It is intended to be eventually overridden in descendant classes. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - WCOMPONENT is the tag instance + - PAGE the page instance")) -(defgeneric wcomponent-after-prerender (obj page-obj) +(defgeneric wcomponent-after-prerender (wcomponent page) (:documentation "Method called by the framework after the pre-rendering phase. It is intended to be eventually overridden in descendant classes. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) -(defgeneric wcomponent-before-render (obj page-obj) + - WCOMPONENT is the tag instance + - PAGE the page instance")) +(defgeneric wcomponent-before-render (wcomponent page) (:documentation "Method called by the framework before the rendering phase. It is intended to be eventually overridden in descendant classes. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - WCOMPONENT is the tag instance + - PAGE the page instance")) -(defgeneric wcomponent-after-render (obj page-obj) +(defgeneric wcomponent-after-render (wcomponent page) (:documentation "Method called by the framework after the rendering phase. It is intended to be eventually overridden in descendant classes. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - WCOMPONENT is the tag instance + - PAGE the page instance")) (defvar *clawserver-base-path* nil) -(defvar *html-4.01-strict* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">" "Page doctype as HTML 4.01 STRICT") +(defvar *html-4.01-strict* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">" + "Page doctype as HTML 4.01 STRICT") -(defvar *html-4.01-transitional* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">" "Page doctype as HTML 4.01 TRANSITIONAL") +(defvar *html-4.01-transitional* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">" + "Page doctype as HTML 4.01 TRANSITIONAL") -(defvar *html-4.01-frameset* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">" "Page doctype as HTML 4.01 FRAMESET") +(defvar *html-4.01-frameset* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">" + "Page doctype as HTML 4.01 FRAMESET") -(defvar *xhtml-1.0-strict* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" "Page doctype as HTML 4.01 XHTML") +(defvar *xhtml-1.0-strict* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" + "Page doctype as HTML 4.01 XHTML") -(defvar *xhtml-1.0-transitional* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" "Page doctype as XHTML 4.01 TRANSITIONAL") +(defvar *xhtml-1.0-transitional* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" + "Page doctype as XHTML 4.01 TRANSITIONAL") -(defvar *xhtml-1.0-frameset* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">" "Page doctype as XHTML 4.01 FRAMESET") +(defvar *xhtml-1.0-frameset* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">" + "Page doctype as XHTML 4.01 FRAMESET") -(defvar *default-encoding* "UTF-8" "Page default encoding (if no changes 'UTF-8')") +(defvar *default-encoding* "UTF-8" + "Page default encoding (if no changes 'UTF-8')") -(defvar *rewind-parameter* "rewindobject" "The request parameter for the object asking for a rewind action") +(defvar *rewind-parameter* "rewindobject" + "The request parameter for the object asking for a rewind action") (defvar *empty-tags* (list "area" "base" "basefont" "br" "col" "frame" "hr" "img" "input" "isindex" "meta" - "param" "link")) + "param" "link") + "List of html empty tags") (defun request-id-table-map () "Holds an hash table of used components/tags id as keys and the number of their occurrences as values. @@ -277,11 +287,11 @@ (setf (gethash id id-ht) (1+ client-id-index)) result)) -(defun build-tagf (tag-name parent empty-p &rest rest) +(defun build-tagf (tag-name parent emptyp &rest rest) "This function is used to create a tag object instance - TAG-NAME the a string tag name to create, for example \"span\" - PARENT the parent class. usually 'TAG -- EMPTY-P determines if the tag must be rendered as an empty tag during the request cycle phase. +- EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase. - REST a list of attribute/value pairs and the component body" (let* ((fbody (parse-htcomponent-function (flatten rest))) (id-table-map (request-id-table-map)) @@ -292,7 +302,7 @@ (remf (first fbody) :id) (setf id nil)) (setf instance (make-instance parent - :empty empty-p + :empty emptyp :name (string-downcase tag-name) :attributes (first fbody) :body (second fbody))) @@ -303,18 +313,16 @@ (setf (htcomponent-client-id instance) static-id)) instance)) -(defun generate-tagf (tag-name empty-p) +(defun generate-tagf (tag-name emptyp) "Internal function that generates an htcomponent creation function from the component class name - TAG-NAME the symbol class name of the component -- EMPTY-P determines if the tag must be rendered as an empty tag during the request cycle phase." +- EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase." (setf (fdefinition (intern (format nil "~a>" (string-upcase tag-name)))) - #'(lambda (&rest rest) (build-tagf tag-name 'tag empty-p rest)))) + #'(lambda (&rest rest) (build-tagf tag-name 'tag emptyp rest)))) ;;;---------------------------------------------------------------- - - (defclass page() ((writer :initarg :writer :accessor page-writer :documentation "The output stream for this page instance") @@ -362,7 +370,6 @@ (:documentation "A page object holds claw components to be rendered") ) (defclass htcomponent () - ;class for html tags ((page :initarg :page :reader htcomponent-page :documentation "The owner page") (body :initarg :body @@ -405,9 +412,9 @@ (:documentation "Component needed to render strings")) (defmethod initialize-instance :after ((inst tag) &rest keys) - (let ((empty-p (getf keys :empty)) + (let ((emptyp (getf keys :empty)) (body (getf keys :body))) - (when (and (not (null empty-p)) + (when (and (not (null emptyp)) (not (null body))) (error (format nil "This tag cannot have a body <~a> body: '~a'" (tag-name inst) body))))) @@ -445,9 +452,7 @@ (mapcar #'(lambda (tag-name) (generate-tagf tag-name t)) ;;Creates empty tag initialization functions. But the ones directly defined - '("area" "base" "basefont" "br" "col" "frame" - "hr" "img" "input" "isindex" "meta" - "param")) + *empty-tags*) (mapcar #'(lambda (tag-name) (generate-tagf tag-name nil)) ;;Creates non empty tag initialization functions. But the ones directly defined @@ -470,7 +475,7 @@ "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt" "u" "ul" "var")) -(defun tag-empty-p (tag-name) +(defun tag-emptyp (tag-name) "Returns if a tag defined by the string TAG-NAME is empty" (member tag-name *empty-tags* :test #'string-equal)) @@ -484,29 +489,29 @@ (t 'tag)))) ;;;--------------------METHODS implementation---------------------------------------------- -(defmethod (setf htcomponent-page) ((pobj page) (obj htcomponent)) - (let ((id (getf (htcomponent-attributes obj) :id)) - (static-id (getf (htcomponent-attributes obj) :static-id)) - (client-id (htcomponent-client-id obj))) - (setf (slot-value obj 'page) pobj) +(defmethod (setf htcomponent-page) ((page page) (htcomponent htcomponent)) + (let ((id (getf (htcomponent-attributes htcomponent) :id)) + (static-id (getf (htcomponent-attributes htcomponent) :static-id)) + (client-id (htcomponent-client-id htcomponent))) + (setf (slot-value htcomponent 'page) page) (unless client-id (if static-id - (setf (htcomponent-client-id obj) static-id) - (setf (htcomponent-client-id obj) (generate-id id)))))) + (setf (htcomponent-client-id htcomponent) static-id) + (setf (htcomponent-client-id htcomponent) (generate-id id)))))) -(defmethod page-request-parameters ((pobj page)) - (if (and (boundp '*request*) (null (slot-value pobj 'request-parameters))) +(defmethod page-request-parameters ((page page)) + (if (and (boundp '*request*) (null (slot-value page 'request-parameters))) (let ((parameters (append (post-parameters) (get-parameters))) (pparameters (make-hash-table :test 'equal))) (loop for kv in parameters do (setf (gethash (string-upcase (car kv)) pparameters) (append (gethash (string-upcase (car kv)) pparameters) (list (cdr kv))))) - (setf (slot-value pobj 'request-parameters) pparameters)) - (slot-value pobj 'request-parameters))) + (setf (slot-value page 'request-parameters) pparameters)) + (slot-value page 'request-parameters))) -(defmethod page-req-parameter ((pobj page) name &optional as-list) - (let ((parameters (page-request-parameters pobj)) +(defmethod page-req-parameter ((page page) name &optional as-list) + (let ((parameters (page-request-parameters page)) (retval)) (when parameters (setf retval (gethash (string-upcase name) parameters)) @@ -514,10 +519,10 @@ retval (first retval))))) -(defmethod page-format ((obj page) str &rest rest) - (let ((json-p (page-json-id-list obj)) - (writer (page-writer obj))) - (if (null json-p) +(defmethod page-format ((page page) str &rest rest) + (let ((jsonp (page-json-id-list page)) + (writer (page-writer page))) + (if (null jsonp) (apply #'format writer str rest) (apply #'format writer (list (regex-replace-all "\"" @@ -528,101 +533,98 @@ "\\\\\\\"") "\\\"")))))) -(defmethod page-format-raw ((obj page) str &rest rest) - (let ((writer (page-writer obj))) +(defmethod page-format-raw ((page page) str &rest rest) + (let ((writer (page-writer page))) (apply #'format writer str rest))) -(defmethod page-json-id-list ((obj page)) - (page-req-parameter obj "json" t)) +(defmethod page-json-id-list ((page page)) + (page-req-parameter page "json" t)) -(defmethod page-init ((obj page)) +(defmethod page-init ((page page)) (progn (reset-request-id-table-map) - (setf (page-can-print obj) (null (page-json-id-list obj))) + (setf (page-can-print page) (null (page-json-id-list page))) (reset-request-id-table-map) - (setf (page-tabulator obj) 0))) + (setf (page-tabulator page) 0))) -(defmethod page-render-headings ((obj page)) - (let* ((writer (page-writer obj)) - (json-p (page-json-id-list obj)) +(defmethod page-render-headings ((page page)) + (let* ((writer (page-writer page)) + (jsonp (page-json-id-list page)) (encoding (handler-case (format nil "~a" (stream-external-format writer)) (error () (format nil "~a" *default-encoding*)))) - (xml-p (page-xmloutput obj)) - (content-type (page-doc-type obj))) - (when (null json-p) + (xml-p (page-xmloutput page)) + (content-type (page-doc-type page))) + (when (null jsonp) (when xml-p - (page-format-raw obj "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) + (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) (when content-type - (page-format-raw obj "~a~%" content-type))))) + (page-format-raw page "~a~%" content-type))))) -(defmethod page-render ((obj page)) - (let ((body (page-content obj)) - (json-p (page-json-id-list obj))) +(defmethod page-render ((page page)) + (let ((body (page-content page)) + (jsonp (page-json-id-list page))) (if (null body) - (format nil "null body for page ~a~%" (type-of obj)) + (format nil "null body for page ~a~%" (type-of page)) (progn - (page-init obj) - (when (page-req-parameter obj *rewind-parameter*) - (htcomponent-rewind body obj)) - (page-init obj) - (htcomponent-prerender (page-content obj) obj) ;Here we need a fresh new body!!! - (page-render-headings obj) - (page-init obj) - (when json-p - (page-format-raw obj "{components:{")) - - (setf (page-can-print obj) t) - (htcomponent-render (page-content obj) obj) ;Here we need a fresh new body!!! - (when json-p - (page-format-raw obj "},classInjections:\"") - (setf (page-can-print obj) t) - (dolist (injection (page-init-injections obj)) - (htcomponent-render injection obj)) - (page-format-raw obj "\",instanceInjections:\"") - (htcomponent-render (htbody-init-scripts-tag obj) obj) - (page-format-raw obj "\"}")))))) + (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 "{components:{")) + (setf (page-can-print page) t) + (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) + (dolist (injection (page-init-injections page)) + (htcomponent-render injection page)) + (page-format-raw page "\",instanceInjections:\"") + (htcomponent-render (htbody-init-scripts-tag page) page) + (page-format-raw page "\"}")))))) -(defmethod page-body-init-scripts ((pobj page)) +(defmethod page-body-init-scripts ((page page)) (let ((js-body "")) - (dolist (current-js (reverse (page-instance-initscripts pobj))) + (dolist (current-js (reverse (page-instance-initscripts page))) (setf js-body (format nil "~a~%~a~%" js-body current-js))) (if (string= "" js-body) js-body (format nil "~a" js-body)))) -(defmethod page-print-tabulation ((obj page)) - (let ((json-p (page-json-id-list obj)) - (tabulator (page-tabulator obj)) - (indent-p (page-indent obj))) - (when (and (<= 0 tabulator) indent-p (null json-p)) - (page-format-raw obj "~a" +(defmethod page-print-tabulation ((page page)) + (let ((jsonp (page-json-id-list page)) + (tabulator (page-tabulator page)) + (indent-p (page-indent page))) + (when (and (<= 0 tabulator) indent-p (null jsonp)) + (page-format-raw page "~a" (make-string tabulator :initial-element #\tab))))) -(defmethod page-newline ((obj page)) - (let ((json-p (page-json-id-list obj)) - (indent-p (page-indent obj))) - (when (and indent-p (null json-p)) - (page-format-raw obj "~%")))) +(defmethod page-newline ((page page)) + (let ((jsonp (page-json-id-list page)) + (indent-p (page-indent page))) + (when (and indent-p (null jsonp)) + (page-format-raw page "~%")))) -(defmethod page-init-injections ((pobj page)) +(defmethod page-init-injections ((page page)) (let ((tag-list) (class-init-scripts "")) - - (dolist (script (reverse (page-class-initscripts pobj))) + (dolist (script (reverse (page-class-initscripts page))) (setf class-init-scripts (format nil "~a~%~a" class-init-scripts script))) (unless (string= "" class-init-scripts) (let ((current-js (script> :type "text/javascript"))) (setf (htcomponent-body current-js) class-init-scripts) - (push current-js tag-list))) - - (dolist (js-file (page-script-files pobj)) + (push current-js tag-list))) + (dolist (js-file (page-script-files page)) (let ((current-js (script> :type "text/javascript" :src ""))) (setf (getf (htcomponent-attributes current-js) :src) js-file) (push current-js tag-list))) - (dolist (css-file (page-stylesheet-files pobj)) + (dolist (css-file (page-stylesheet-files page)) (let ((current-css (link> :rel "stylesheet" :type "text/css" :href ""))) (setf (getf (htcomponent-attributes current-css) :href) css-file) (push current-css tag-list))) @@ -630,161 +632,162 @@ tag-list)) ;;;========= HTCOMPONENT ============================ -(defmethod htcomponent-can-print ((obj htcomponent)) - (let* ((id (htcomponent-client-id obj)) - (pobj (htcomponent-page obj)) - (print-status (page-can-print pobj)) - (render-p (member id (page-json-id-list pobj) :test #'string=))) +(defmethod htcomponent-can-print ((htcomponent htcomponent)) + (let* ((id (htcomponent-client-id htcomponent)) + (page (htcomponent-page htcomponent)) + (print-status (page-can-print page)) + (render-p (member id (page-json-id-list page) :test #'string=))) (or print-status render-p))) -(defmethod htcomponent-json-print-start-component ((obj htcomponent)) - (let* ((pobj (htcomponent-page obj)) - (json-p (page-json-id-list pobj)) - (id (htcomponent-client-id obj))) - (when (or json-p - (member id json-p :test #'string-equal)) - (when (> (page-json-component-count pobj) 0) - (page-format pobj ",")) - (page-format-raw pobj "~a:\"" id) - (incf (page-json-component-count pobj))))) - -(defmethod htcomponent-json-print-end-component ((obj htcomponent)) - (let* ((pobj (htcomponent-page obj)) - (json-p (page-json-id-list pobj)) - (id (htcomponent-client-id obj))) - (when (or json-p - (member id json-p :test #'string-equal)) - (page-format-raw pobj "\"")))) - -(defmethod htcomponent-rewind :before ((obj htcomponent) (pobj page)) - (setf (htcomponent-page obj) pobj)) -(defmethod htcomponent-prerender :before ((obj htcomponent) (pobj page)) - (setf (htcomponent-page obj) pobj)) -(defmethod htcomponent-render :before ((obj htcomponent) (pobj page)) - (setf (htcomponent-page obj) pobj)) +(defmethod htcomponent-json-print-start-component ((htcomponent htcomponent)) + (let* ((page (htcomponent-page htcomponent)) + (jsonp (page-json-id-list page)) + (id (htcomponent-client-id htcomponent))) + (when (or jsonp + (member id jsonp :test #'string-equal)) + (when (> (page-json-component-count page) 0) + (page-format page ",")) + (page-format-raw page "~a:\"" id) + (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 (htcomponent-client-id htcomponent))) + (when (or jsonp + (member id jsonp :test #'string-equal)) + (page-format-raw page "\"")))) + +(defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page)) + (setf (htcomponent-page htcomponent) page)) + +(defmethod htcomponent-prerender :before ((htcomponent htcomponent) (page page)) + (setf (htcomponent-page htcomponent) page)) + +(defmethod htcomponent-render :before ((htcomponent htcomponent) (page page)) + (setf (htcomponent-page htcomponent) page)) -(defmethod htcomponent-rewind ((obj htcomponent) (pobj page)) - (dolist (tag (htcomponent-body obj)) +(defmethod htcomponent-rewind ((htcomponent htcomponent) (page page)) + (dolist (tag (htcomponent-body htcomponent)) (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-rewind tag pobj)))) + (htcomponent-rewind tag page)))) -(defmethod htcomponent-prerender ((obj htcomponent) (pobj page)) - (let ((previous-print-status (page-can-print pobj))) -; (log-message :info "------------------- ~a" previous-print-status) +(defmethod htcomponent-prerender ((htcomponent htcomponent) (page page)) + (let ((previous-print-status (page-can-print page))) (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj))) - (dolist (tag (htcomponent-body obj)) + (setf (page-can-print page) (htcomponent-can-print htcomponent))) + (dolist (tag (htcomponent-body htcomponent)) (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-prerender tag pobj))) + (htcomponent-prerender tag page))) (when (null previous-print-status) - (setf (page-can-print pobj) nil)))) + (setf (page-can-print page) nil)))) -(defmethod htcomponent-render ((obj htcomponent) (pobj page)) - (let ((body-list (htcomponent-body obj)) - (previous-print-status (page-can-print pobj))) +(defmethod htcomponent-render ((htcomponent htcomponent) (page page)) + (let ((body-list (htcomponent-body htcomponent)) + (previous-print-status (page-can-print page))) (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj)) - (htcomponent-json-print-start-component obj)) + (setf (page-can-print page) (htcomponent-can-print htcomponent)) + (htcomponent-json-print-start-component htcomponent)) (dolist (tag body-list) (if (stringp tag) - (htcomponent-render ($> tag) pobj) - (htcomponent-render tag pobj))) + (htcomponent-render ($> tag) page) + (htcomponent-render tag page))) (when (null previous-print-status) - (setf (page-can-print pobj) nil) - (htcomponent-json-print-end-component obj)))) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htcomponent)))) ;;;========= TAG ===================================== -(defmethod tag-render-attributes ((obj tag) (pobj page)) - (when (htcomponent-attributes obj) - (loop for (k v) on (htcomponent-attributes obj) by #'cddr +(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 v - (page-format pobj " ~a=\"~a\"" + (page-format page " ~a=\"~a\"" (string-downcase (if (eq k :static-id) "id" (symbol-name k))) (let ((s (if (eq k :id) - (prin1-to-string (htcomponent-client-id obj)) + (prin1-to-string (htcomponent-client-id tag)) (prin1-to-string v)))) ;escapes double quotes (subseq s 1 (1- (length s)))))))))) -(defmethod tag-render-starttag ((obj tag) (pobj page)) - (let ((tagname (tag-name obj)) - (empty-p (htcomponent-empty obj)) - (xml-p (page-xmloutput pobj))) - (setf (page-lasttag pobj) tagname) - (page-newline pobj) - (page-print-tabulation pobj) - (page-format pobj "<~a" tagname) - (tag-render-attributes obj pobj) - (if (null empty-p) +(defmethod tag-render-starttag ((tag tag) (page page)) + (let ((tagname (tag-name tag)) + (emptyp (htcomponent-empty tag)) + (xml-p (page-xmloutput page))) + (setf (page-lasttag page) tagname) + (page-newline page) + (page-print-tabulation page) + (page-format page "<~a" tagname) + (tag-render-attributes tag page) + (if (null emptyp) (progn - (page-format pobj ">") - (incf (page-tabulator pobj))) + (page-format page ">") + (incf (page-tabulator page))) (if (null xml-p) - (page-format pobj ">") - (page-format pobj "/>"))))) + (page-format page ">") + (page-format page "/>"))))) -(defmethod tag-render-endtag ((obj tag) (pobj page)) - (let ((tagname (tag-name obj)) - (previous-tagname (page-lasttag pobj)) - (empty-p (htcomponent-empty obj))) - (when (null empty-p) +(defmethod tag-render-endtag ((tag tag) (page page)) + (let ((tagname (tag-name tag)) + (previous-tagname (page-lasttag page)) + (emptyp (htcomponent-empty tag))) + (when (null emptyp) (progn - (decf (page-tabulator pobj)) + (decf (page-tabulator page)) (if (string= tagname previous-tagname) (progn - (page-format pobj "</~a>" tagname)) + (page-format page "</~a>" tagname)) (progn - (page-newline pobj) - (page-print-tabulation pobj) - (page-format pobj "</~a>" tagname))))) - (setf (page-lasttag pobj) nil))) - -(defmethod htcomponent-render ((obj tag) (pobj page)) - (let ((body-list (htcomponent-body obj)) - (previous-print-status (page-can-print pobj))) - (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj)) - (htcomponent-json-print-start-component obj)) - (when (or (page-can-print pobj) previous-print-status) - (tag-render-starttag obj pobj)) + (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))) + (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 (tag body-list) (if (stringp tag) - (htcomponent-render ($> tag) pobj) - (htcomponent-render tag pobj))) - (when (or (page-can-print pobj) previous-print-status) - (tag-render-endtag obj pobj)) + (htcomponent-render ($> tag) page) + (htcomponent-render tag page))) + (when (or (page-can-print page) previous-print-status) + (tag-render-endtag tag page)) (unless previous-print-status - (setf (page-can-print pobj) nil) - (htcomponent-json-print-end-component obj)))) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component tag)))) ;;;========= HTHEAD ====================================== -(defmethod htcomponent-render ((obj hthead) (pobj page)) - (when (null (page-json-id-list pobj)) - (let ((body-list (htcomponent-body obj)) - (injections (page-init-injections pobj))) - (tag-render-starttag obj pobj) +(defmethod htcomponent-render ((hthead hthead) (page page)) + (when (null (page-json-id-list page)) + (let ((body-list (htcomponent-body hthead)) + (injections (page-init-injections page))) + (tag-render-starttag hthead page) (dolist (tag body-list) (if (stringp tag) - (htcomponent-render ($> tag) pobj) - (htcomponent-render tag pobj))) + (htcomponent-render ($> tag) page) + (htcomponent-render tag page))) (dolist (injection injections) - (htcomponent-render injection pobj)) - (tag-render-endtag obj pobj)))) + (htcomponent-render injection page)) + (tag-render-endtag hthead page)))) ;;;========= HTSTRING =================================== -(defmethod htcomponent-rewind((obj htstring) (pobj page))) -(defmethod htcomponent-prerender((obj htstring) (pobj page))) +(defmethod htcomponent-rewind((htstring htstring) (page page))) +(defmethod htcomponent-prerender((htstring htstring) (page page))) -(defmethod htcomponent-render ((obj htstring) (pobj page)) - (let ((body (htcomponent-body obj)) - (json-p (not (null (page-json-id-list pobj)))) - (print-p (page-can-print pobj))) +(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))) (when (or print-p body) - (when json-p + (when jsonp (setf body (regex-replace-all "\"" (regex-replace-all "\\\\\"" (regex-replace-all "\\n" @@ -792,91 +795,91 @@ "\\n") "\\\\\\\"") "\\\""))) - (if (htstring-raw obj) - (page-format-raw pobj body) + (if (htstring-raw htstring) + (page-format-raw page body) (loop for ch across body do (case ch - ((#\<) (page-format-raw pobj "<")) - ((#\>) (page-format-raw pobj ">")) - ((#\&) (page-format-raw pobj "&")) - (t (page-format-raw pobj "~a" ch)))))))) + ((#\<) (page-format-raw page "<")) + ((#\>) (page-format-raw page ">")) + ((#\&) (page-format-raw page "&")) + (t (page-format-raw page "~a" ch)))))))) ;;;========= HTSCRIPT =================================== -(defmethod htcomponent-prerender((obj htscript) (pobj page))) +(defmethod htcomponent-prerender((htscript htscript) (page page))) -(defmethod htcomponent-render ((obj htscript) (pobj page)) - (let ((xml-p (page-xmloutput pobj)) - (body (htcomponent-body obj)) - (previous-print-status (page-can-print pobj))) - (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj)) - (htcomponent-json-print-start-component obj)) - (unless (getf (htcomponent-attributes obj) :type) - (append '(:type "text/javascript") (htcomponent-attributes obj))) - (when (page-can-print pobj) - (tag-render-starttag obj pobj) - (when (and (null (getf (htcomponent-attributes obj) :src)) - (not (null (htcomponent-body obj)))) +(defmethod htcomponent-render ((htscript htscript) (page page)) + (let ((xml-p (page-xmloutput page)) + (body (htcomponent-body htscript)) + (previous-print-status (page-can-print page))) + (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 pobj "~%//<!--~%") - (page-format pobj "~%//<[CDATA[~%")) + (page-format page "~%//<!--~%") + (page-format page "~%//<[CDATA[~%")) (unless (listp body) (setf body (list body))) (dolist (element body) (if (stringp element) - (htcomponent-render ($raw> element) pobj) - (htcomponent-render element pobj))) + (htcomponent-render ($raw> element) page) + (htcomponent-render element page))) (if (null xml-p) - (page-format pobj "~%//-->") - (page-format pobj "~%//]]>"))) - (setf (page-lasttag pobj) nil) - (tag-render-endtag obj pobj)) + (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 pobj) nil) - (htcomponent-json-print-end-component obj)))) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htscript)))) ;;;========= HTLINK ==================================== -(defmethod htcomponent-render ((obj htlink) (pobj page)) - (let ((previous-print-status (page-can-print pobj))) +(defmethod htcomponent-render ((htlink htlink) (page page)) + (let ((previous-print-status (page-can-print page))) (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj)) - (htcomponent-json-print-start-component obj)) - (when (page-can-print pobj) - (unless (getf (htcomponent-attributes obj) :type) - (append '(:type "text/css") (htcomponent-attributes obj))) - (unless (getf (htcomponent-attributes obj) :rel) - (append '(:rel "styleshhet") (htcomponent-attributes obj))) - (tag-render-starttag obj pobj) - (tag-render-endtag obj pobj)) + (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 pobj) nil) - (htcomponent-json-print-end-component obj)))) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htlink)))) ;;;========= HTBODY =================================== -(defmethod htcomponent-render ((obj htbody) (pobj page)) - (let ((body-list (htcomponent-body obj)) - (previous-print-status (page-can-print pobj))) - (when (or (page-can-print pobj) previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj)) - (htcomponent-json-print-start-component obj)) - (when (page-can-print pobj) - (tag-render-starttag obj pobj)) +(defmethod htcomponent-render ((htbody htbody) (page page)) + (let ((body-list (htcomponent-body htbody)) + (previous-print-status (page-can-print page))) + (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 (tag body-list) (if (stringp tag) - (htcomponent-render ($> tag) pobj) - (htcomponent-render tag pobj))) - (when (page-can-print pobj) - (htcomponent-render (htbody-init-scripts-tag pobj) pobj) - (tag-render-endtag obj pobj)) - (when (or (page-can-print pobj) previous-print-status) - (setf (page-can-print pobj) nil) - (htcomponent-json-print-end-component obj)))) + (htcomponent-render ($> tag) page) + (htcomponent-render tag page))) + (when (page-can-print page) + (htcomponent-render (htbody-init-scripts-tag page) 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 ((pobj page)) +(defmethod htbody-init-scripts-tag ((page page)) (let ((js (script> :type "text/javascript"))) - (setf (htcomponent-page js) pobj) - (setf (htcomponent-body js) (page-body-init-scripts pobj)) + (setf (htcomponent-page js) page) + (setf (htcomponent-body js) (page-body-init-scripts page)) js)) ;;;========= WCOMPONENT =================================== @@ -985,62 +988,62 @@ (setf (fdefinition `,',symbolf) #'(lambda(&rest rest) (build-component ',name rest)))))) -(defmethod htcomponent-rewind ((obj wcomponent) (pobj page)) - (let ((template (wcomponent-template obj))) - (wcomponent-before-rewind obj pobj) +(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 pobj)) - (htcomponent-rewind template pobj)) - (wcomponent-after-rewind obj pobj))) - -(defmethod wcomponent-before-rewind ((obj wcomponent) (pobj page))) -(defmethod wcomponent-after-rewind ((obj wcomponent) (pobj page))) - -(defmethod htcomponent-prerender ((obj wcomponent) (pobj page)) - (wcomponent-before-prerender obj pobj) - (let ((previous-print-status (page-can-print pobj)) - (template (wcomponent-template obj))) - (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj))) - (when (page-can-print pobj) - (dolist (script (htcomponent-script-files obj)) - (pushnew script (page-script-files pobj) :test #'equal)) - (dolist (css (htcomponent-stylesheet-files obj)) - (pushnew css (page-stylesheet-files pobj) :test #'equal)) - (dolist (js (htcomponent-class-initscripts obj)) - (pushnew js (page-class-initscripts pobj) :test #'equal)) - (when (htcomponent-instance-initscript obj) - (pushnew (htcomponent-instance-initscript obj) (page-instance-initscripts pobj) :test #'equal))) + (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)) + (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) + (dolist (script (htcomponent-script-files wcomponent)) + (pushnew script (page-script-files page) :test #'equal)) + (dolist (css (htcomponent-stylesheet-files wcomponent)) + (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 pobj))) - (htcomponent-prerender template pobj)) + (htcomponent-prerender tag page))) + (htcomponent-prerender template page)) (when (null previous-print-status) - (setf (page-can-print pobj) nil))) - (wcomponent-after-prerender obj pobj)) + (setf (page-can-print page) nil))) + (wcomponent-after-prerender wcomponent page)) -(defmethod wcomponent-before-prerender ((obj wcomponent) (pobj page))) -(defmethod wcomponent-after-prerender ((obj wcomponent) (pobj page))) +(defmethod wcomponent-before-prerender ((wcomponent wcomponent) (page page))) +(defmethod wcomponent-after-prerender ((wcomponent wcomponent) (page page))) -(defmethod htcomponent-render ((obj wcomponent) (pobj page)) - (let ((template (wcomponent-template obj)) - (previous-print-status (page-can-print pobj))) - (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj)) - (htcomponent-json-print-start-component obj)) - (wcomponent-before-render obj pobj) +(defmethod htcomponent-render ((wcomponent wcomponent) (page page)) + (let ((template (wcomponent-template wcomponent)) + (previous-print-status (page-can-print page))) + (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 (tag template) (if (stringp tag) - (htcomponent-render ($> tag) pobj) - (htcomponent-render tag pobj))) - (wcomponent-after-render obj pobj) + (htcomponent-render ($> tag) page) + (htcomponent-render tag page))) + (wcomponent-after-render wcomponent page) (when (null previous-print-status) - (setf (page-can-print pobj) nil) - (htcomponent-json-print-end-component obj)))) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component wcomponent)))) -(defmethod wcomponent-before-render ((obj wcomponent) (pobj page))) -(defmethod wcomponent-after-render ((obj wcomponent) (pobj page))) +(defmethod wcomponent-before-render ((wcomponent wcomponent) (page page))) +(defmethod wcomponent-after-render ((wcomponent wcomponent) (page page)))