[claw-cvs] r184 - in trunk/main/claw-html: . src
Andrea Chiumenti
achiumenti at common-lisp.net
Tue Jan 13 13:03:03 UTC 2009
Author: achiumenti
Date: Tue Jan 13 13:03:03 2009
New Revision: 184
Log:
Added html template capabilities for pages and components
Added:
trunk/main/claw-html/src/parser.lisp
Modified:
trunk/main/claw-html/claw-html.asd
trunk/main/claw-html/src/meta.lisp
trunk/main/claw-html/src/packages.lisp
trunk/main/claw-html/src/tags.lisp
Modified: trunk/main/claw-html/claw-html.asd
==============================================================================
--- trunk/main/claw-html/claw-html.asd (original)
+++ trunk/main/claw-html/claw-html.asd Tue Jan 13 13:03:03 2009
@@ -31,10 +31,11 @@
:name "claw-html"
:author "Andrea Chiumenti"
:description "Common Lisp Active Web HTML generator."
- :depends-on (:closer-mop :local-time :parenscript :cl-ppcre :split-sequence)
+ :depends-on (:closer-mop :local-time :parenscript :cl-ppcre :split-sequence :closure-html)
:components ((:module src
:components ((:file "packages")
(:file "meta" :depends-on ("packages"))
+ (:file "parser" :depends-on ("packages"))
(:file "tags" :depends-on ("packages" "meta"))
(:file "components" :depends-on ("tags" "meta"))
(:file "validators" :depends-on ("components"))
Modified: trunk/main/claw-html/src/meta.lisp
==============================================================================
--- trunk/main/claw-html/src/meta.lisp (original)
+++ trunk/main/claw-html/src/meta.lisp Tue Jan 13 13:03:03 2009
@@ -29,6 +29,9 @@
(in-package :claw-html)
+(defvar *components-templates* (make-hash-table)
+ "Hash table that stores the templates for CLAW components")
+
(defclass metacomponent (standard-class)
()
(:documentation "This is the meta class the must be set for every WCOMPONENT.
Modified: trunk/main/claw-html/src/packages.lisp
==============================================================================
--- trunk/main/claw-html/src/packages.lisp (original)
+++ trunk/main/claw-html/src/packages.lisp Tue Jan 13 13:03:03 2009
@@ -31,7 +31,7 @@
(defpackage :claw-html
- (:use :cl :closer-mop :local-time :parenscript :cl-ppcre :split-sequence)
+ (:use :cl :closer-mop :local-time :parenscript :cl-ppcre :split-sequence :closure-html)
(:shadow :flatten)
(:documentation "A comprehensive web application framework and server for the Common Lisp programming language")
(:export #:*html-4.01-strict*
@@ -43,6 +43,7 @@
#:*rewind-parameter*
#:*validation-errors*
#:*claw-current-page*
+ #:*claw-this-component*
#:error-page
#:render-error-page
@@ -51,6 +52,7 @@
#:build-tagf
#:page
#:page-before-render
+ #:template
#:page-render
#:make-page-renderer
#:page-current-form
@@ -60,7 +62,7 @@
#:page-global-initscripts
#:page-initscripts
#:page-initstyles
- #:page-current-component
+ #:current-component
#:page-body-initscripts
#:htcomponent
#:htcomponent-page
@@ -83,6 +85,8 @@
#:htstring
#:$>
#:$raw>
+ #:htignore
+ #:ignore>
;empty tags definition
#:*empty-tags*
#:area>
@@ -177,6 +181,7 @@
#:u>
#:ul>
#:var>
+ #:parse-claw-template
;; class modifiers
#:page-content
#:generate-id
Added: trunk/main/claw-html/src/parser.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-html/src/parser.lisp Tue Jan 13 13:03:03 2009
@@ -0,0 +1,125 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/components.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :claw-html)
+
+(defclass claw-html-builder (chtml::lhtml-builder)
+ ())
+
+(defun make-claw-html-builder ()
+ (make-instance 'claw-html-builder))
+
+(defmethod hax:start-element ((handler claw-html-builder) name attrs)
+ (let* ((parent (car (chtml::stack handler)))
+ (this (list (find-symbol (format nil "~a>" (string-upcase name)) :claw-html)
+ (flatten (chtml::pt-attributes-to-lhtml attrs)))))
+ (push this (chtml::stack handler))
+ (if parent
+ (push this (cddr parent))
+ (setf (chtml::root handler) this))))
+
+(defmethod hax:end-element ((handler claw-html-builder) name)
+ (let ((current (pop (chtml::stack handler))))
+ (setf (cdr current)
+ (append (cadr current) (reverse (cddr current))))))
+
+;; component parser
+
+(defvar *component-content-template* nil)
+
+(defclass claw-html-component-builder (claw-html-builder)
+ ((component-content-template :initform nil
+ :accessor component-content-template-p)
+ (component-content-ignore :initform nil
+ :accessor component-content-ignore-p)
+ (parsed-content :initform nil
+ :accessor parsed-content)))
+
+(defun make-claw-html-component-builder ()
+ (make-instance 'claw-html-component-builder))
+
+(defmethod hax:start-element :before ((handler claw-html-builder) name attrs)
+ (dolist (attr attrs)
+ (cond
+ ((and (string-equal (hax:attribute-name attr) "CLAWTYPE")
+ (string-equal (hax:attribute-value attr) "$ignore$"))
+ (setf (component-content-ignore-p handler) t))
+ ((and (string-equal (hax:attribute-name attr) "CLAWTYPE")
+ (string-equal (hax:attribute-value attr) "$content$")
+ (null (component-content-ignore-p handler)))
+ (if (component-content-template-p handler)
+ (error "$content$ found multiple times in template")
+ (setf (component-content-template-p handler) t))))))
+
+(defun parse-attributes (attrs)
+ (loop for (key value) on attrs by #'cddr
+ collect key
+ when value collect (parse-attribute-value value)))
+
+(defun parse-attribute-value (value)
+ (multiple-value-bind (result matchesp)
+ (cl-ppcre:regex-replace "(?i)(^\\$lisp>)+([.])*" value "\\2")
+ (if matchesp
+ (read-from-string result)
+ result)))
+
+
+(defmethod hax:end-element ((handler claw-html-component-builder) name)
+ (let ((current (pop (chtml::stack handler))))
+ (let ((attrs (parse-attributes (cadr current))))
+ (cond
+ ((string-equal (getf attrs :clawtype) "$ignore$")
+ (setf (cdr current) nil
+ attrs nil
+ (component-content-ignore-p handler) nil
+ (car current) (find-symbol "IGNORE>" "CLAW-HTML")))
+ ((string-equal (getf attrs :clawtype) "$body$")
+ (setf (cdr current) nil
+ attrs (list (find-symbol "*CLAW-THIS-COMPONENT*" "CLAW-HTML"))
+ (car current) (find-symbol "HTCOMPONENT-BODY" "CLAW-HTML")))
+ ((and (component-content-template-p handler)
+ (string-equal (getf attrs :clawtype) "$content$")
+ (null (parsed-content handler)))
+ (remf attrs :clawtype)
+ (setf (parsed-content handler) (append (list (first current))
+ attrs
+ (reverse (cddr current))))))
+ (unless (component-content-ignore-p handler)
+ (setf (cdr current)
+ (append attrs (reverse (cddr current))))))))
+
+
+(defun parse-claw-template (input)
+ "Parses the input and returns a claw form template (i.e. a CLAW-HTML:TAG instance) and returns a lambda function with no parameters.
+The inpus may be a string a file or a stream.
+"
+ (eval `(lambda () ,(let ((handler (make-claw-html-component-builder)))
+ (chtml:parse input handler)
+ (let ((result (parsed-content handler)))
+ (or (parsed-content handler) result))))))
\ No newline at end of file
Modified: trunk/main/claw-html/src/tags.lisp
==============================================================================
--- trunk/main/claw-html/src/tags.lisp (original)
+++ trunk/main/claw-html/src/tags.lisp Tue Jan 13 13:03:03 2009
@@ -301,6 +301,9 @@
"The CLAW page currently rendering
")
+(defvar *calw-this-component* nil
+ "Variable set when rendering a WCOMPONENT-TEMPLATE so it is accessible inside the template")
+
(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
@@ -396,6 +399,7 @@
(id (getf attributes :id))
(static-id (getf attributes :static-id))
(render-condition (getf attributes :render-condition))
+ (claw-type (getf attributes :clawtype))
(real-id (or static-id id))
(instance))
(when static-id
@@ -403,19 +407,27 @@
(setf id nil))
(when render-condition
(remf attributes :render-condition))
- (setf instance (make-instance parent
- :empty emptyp
- :real-id real-id
- :name (string-downcase tag-name)
- :render-condition render-condition
- :attributes attributes
- :body (second fbody)))
- (when real-id
- (if (null static-id)
- (when (and id-table-map id)
- (setf (htcomponent-client-id instance) (generate-id id)))
- (setf (htcomponent-client-id instance) static-id)))
- instance))
+ (if claw-type
+ (let (clawtype-sybol-list (split "([:]){1,2}" (string-upcase claw-type)))
+ (if (second clawtype-sybol-list)
+ (setf claw-type (find-symbol (second clawtype-sybol-list)
+ (first clawtype-sybol-list)))
+ (setf claw-type (find-symbol (first clawtype-sybol-list))))
+ (make-component claw-type attributes (second fbody)))
+ (progn
+ (setf instance (make-instance (or claw-type parent)
+ :empty emptyp
+ :real-id real-id
+ :name (string-downcase tag-name)
+ :render-condition render-condition
+ :attributes attributes
+ :body (second fbody)))
+ (when real-id
+ (if (null static-id)
+ (when (and id-table-map id)
+ (setf (htcomponent-client-id instance) (generate-id id)))
+ (setf (htcomponent-client-id instance) static-id)))
+ instance))))
(defun generate-tagf (tag-name emptyp)
"Internal function that generates an htcomponent creation function from the component class name
@@ -487,7 +499,10 @@
: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"))
+ :documentation "Flag that becomes true when rendering page injections")
+ (teamplate :initarg :template
+ :accessor template
+ :documentation "A lambda function with no parameters that, when not nil, is used as page-content."))
(:default-initargs :writer t
:external-format-encoding :utf-8
:script-files nil
@@ -501,9 +516,14 @@
:xmloutput nil
:doc-type *html-4.01-transitional*
:request-parameters nil
+ :template nil
:mime-type "text/html")
(:documentation "A page object holds claw components to be rendered") )
+(defmethod page-content ((page page))
+ (when-let (lambda-content (template page))
+ (funcall lambda-content)))
+
(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*)
@@ -572,6 +592,10 @@
(:default-initargs :raw nil)
(:documentation "Component needed to render strings"))
+(defclass htignore (htcomponent)
+ ()
+ (:documentation "Ignore all content"))
+
(defmethod initialize-instance :after ((inst tag) &rest keys)
@@ -589,6 +613,11 @@
"Creates a non escaping htstring component"
(make-instance 'htstring :body value :raw t))
+(defun ignore> (&rest ignore)
+ "Creates an ignore content"
+ (declare (ignore ignore))
+ (make-instance 'htignore))
+
(defclass htscript (tag) ()
(:documentation "Creates a component for rendering a <script> tag"))
@@ -1062,6 +1091,11 @@
(htcomponent-render injection page)))
(tag-render-endtag hthead page))))))
+;;;========= HTIGNORE ===================================
+(defmethod htcomponent-rewind((htignore htignore) (page page)))
+(defmethod htcomponent-prerender((htignore htignore) (page page)))
+(defmethod htcomponent-render ((htignore htignore) (page page)))
+
;;;========= HTSTRING ===================================
(defmethod htcomponent-rewind((htstring htstring) (page page)))
@@ -1222,11 +1256,19 @@
(allow-informal-parameters :initarg :allow-informal-parameters
:reader wcomponent-allow-informal-parametersp
:allocation :class
- :documentation "Determines if the component accepts informal parameters"))
+ :documentation "Determines if the component accepts informal parameters")
+ (teamplate :initarg :template
+ :accessor template
+ :documentation "A lambda function with no parameters that, when not nil, is used as page-content. *CLAW-THIS-COMPONENT* is set as a closure, so that may be directly used inside the template."))
(: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."))
+(defmethod wcomponent-template ((wcomponent wcomponent))
+ (let ((*claw-this-component* wcomponent))
+ (when-let (lambda-content (template page))
+ (funcall lambda-content))))
+
(defmethod wcomponent-created ((wcomponent wcomponent))
nil)
@@ -1270,6 +1312,7 @@
(defun make-component (name parameters content)
"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."
+ (remf :clawtype parameters)
(unless (or (getf parameters :id)
(getf parameters :static-id))
(setf (getf parameters :id) "claw"))
More information about the Claw-cvs
mailing list