ovidiu 02/02/12 17:51:20
Modified: src/scratchpad/schecoon/scheme sitemap.scm
Log:
Add support for defining external flow script files to be included in
the sitemap.
Revision Changes Path
1.10 +121 -52 xml-cocoon2/src/scratchpad/schecoon/scheme/sitemap.scm
Index: sitemap.scm
===================================================================
RCS file: /home/cvs/xml-cocoon2/src/scratchpad/schecoon/scheme/sitemap.scm,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- sitemap.scm 9 Feb 2002 00:19:13 -0000 1.9
+++ sitemap.scm 13 Feb 2002 01:51:20 -0000 1.10
@@ -7,6 +7,7 @@
(load-module "sisc.modules.Regexp")
(load-module "sisc.modules.J2S")
(load-module "org.apache.cocoon.scheme.sitemap.SchemeSitemapFunctions")
+(load-module "org.apache.cocoon.scheme.sitemap.SchemeEnvironmentFunctions")
(load-module "org.apache.cocoon.scheme.sitemap.ContinuationsManager")
;; A Cocoon XML sitemap description is processed by the Scheme code in
@@ -125,6 +126,9 @@
((symbol? name) (name->resource (symbol->string name)))
(else #f)))
+;; The global scope.
+(define top-level (interaction-environment))
+
;; The main function to process an SXML representation of the sitemap,
;; and generate a function which is the executable version of the
;; sitemap.
@@ -137,7 +141,7 @@
;; The side effect of executing this returned function is the
;; processing of the input HTTP request as defined by the sitemap.
;;
-(define (process-sitemap sitemap)
+(define (process-sitemap sitemap xsxml)
(let ((exit #f)
;; Regular expressions for matching various types of arguments
(res-arg-regexp (regexp "/({[^0-9].*})/"))
@@ -516,8 +520,40 @@
(match-match pipeline #t)))
)))
- ;; This function is called by the `apply-templates' function below
- ;; to process SXML nodes corresponding to <map:resource>.
+ ;; This function is called to process <map:script> elements
+ ;; embedded inside <map:resource> elements that have a type="flow"
+ ;; attribute.
+ ;;
+ ;; As opposed to the rest of the process- functions, this function
+ ;; doesn't generate any code. Instead it has the side-effect of
+ ;; reading, and possibly translating the script file, into the
+ ;; running Scheme engine.
+ (define (process-script node)
+ (let ((resource (sxml:attr node 'src))
+ (lang (or (sxml:attr node 'language) "scheme")))
+ (if (not resource)
+ (xml-error node "required 'src' attribute for <script> is not present"))
+ (cond ((string-ci=? lang "scheme")
+ (call-with-failure-continuation
+ (lambda ()
+ (let* ((content (sitemap:read-resource sitemap resource))
+ (port (open-input-string content)))
+ (let loop ()
+ (let ((form (read port)))
+ (if (not (eof-object? form))
+ (begin
+ (eval form (interaction-environment))
+ (loop)))))))
+ (lambda (message error-continuation parent-fk)
+ (xml-error
+ node
+ (format "Error parsing ~s: ~s~%" resource message)))))
+
+ (else
+ (xml-error node "unknown script language '~s'~%" lang)))
+ ))
+
+ ;; Handle pipeline definitions defined using <map:resource name="...">
;;
;; For each named resource we create a function whose name is
;; r_<resource-name>, which contains the definition of the
@@ -543,52 +579,82 @@
;; `function' macro, instead of the normal Scheme `define'. This
;; allows for named parameters to be passed to the function at
;; runtime.
+ (define (define-pipeline node)
+ (let* ((resname (sxml:attr node 'name))
+ (funname (name->resource resname))
+ ;; Check to see if a similar resource has already
+ ;; been defined.
+ (_ (if (lookup-resource funname)
+ (xml-error node "A resource named ~s already defined"
+ funname)))
+ (attributes (map (lambda (x) (cadr x))
+ ((sxpath '(// @ (*))) node)))
+ (source-arguments
+ (filter (lambda (x)
+ (if (and (string? x)
+ (regexp-match res-arg-regexp-match x))
+ x
+ #f))
+ attributes))
+ ;; `source-arguments' contains all the attributes
+ ;; that contain named parameters. We need to
+ ;; extract the names from within curly braces
+ (arguments
+ (flatten
+ (map
+ (lambda (x)
+ (let* ((v (regexp-split/delimiter arg-regexp-split x))
+ (len (vector-length v)))
+ (let loop ((i 1) (acc '()))
+ (if (>= i len)
+ acc
+ (loop (+ i 2) (cons (vector-ref v i) acc))))
+ ))
+ source-arguments)))
+ (argument-symbols
+ (map (lambda (x) (string->symbol x)) arguments))
+ (funsig `(,funname ,@argument-symbols))
+ (funbody
+ `(function (,funname sitemap env ,@argument-symbols)
+ ,(generate-function-body
+ (reverse (sxml:child-elements node)) #f))))
+ (add-resource funsig funbody)
+ (pretty-print funbody) (newline)
+ (eval funbody (interaction-environment))
+ ))
+
+
+ ;; This function is called by the `apply-templates' function below
+ ;; to process SXML nodes corresponding to <map:resource>.
+ ;;
+ ;; Resources can be either pipeline definitions or flow scripts
+ ;; references. This function calls the appropriate function that
+ ;; does the work for each case.
(define (process-resource node)
- (let ((resname (sxml:attr node 'name)))
- (if (not resname)
- (xml-error node "Resource must be named, use a 'name' attribute")
- (let* ((funname (name->resource resname))
- ;; Check to see if a similar resource has already
- ;; been defined.
- (_ (if (lookup-resource funname)
- (xml-error node "A resource named ~s already defined"
- funname)))
- (attributes (map (lambda (x) (cadr x))
- ((sxpath '(// @ (*))) node)))
- (source-arguments
- (filter (lambda (x)
- (if (and (string? x)
- (regexp-match res-arg-regexp-match x))
- x
- #f))
- attributes))
- ;; `source-arguments' contains all the attributes
- ;; that contain named parameters. We need to
- ;; extract the names from within curly braces
- (arguments
- (flatten
- (map
- (lambda (x)
- (let* ((v (regexp-split/delimiter arg-regexp-split x))
- (len (vector-length v)))
- (let loop ((i 1) (acc '()))
- (if (>= i len)
- acc
- (loop (+ i 2) (cons (vector-ref v i) acc))))
- ))
- source-arguments)))
- (argument-symbols
- (map (lambda (x) (string->symbol x)) arguments))
- (funsig `(,funname ,@argument-symbols))
- (funbody
- `(function (,funname sitemap env ,@argument-symbols)
- ,(generate-function-body
- (reverse (sxml:child-elements node)) #f))))
- (add-resource funsig funbody)
- (pretty-print funbody) (newline)
- (eval funbody (interaction-environment))
- ))))
+ (cond ((sxml:attr node 'name)
+ ;;
+ ;; A named pipeline definition
+ ;;
+ (define-pipeline node))
+
+ ((equal? (sxml:attr node 'type) "flow")
+ ;;
+ ;; Flow script definitions. Include all the flow scripts
+ ;; defined using <map:script>.
+ ;;
+ (apply-templates
+ node
+ `((script . ,(lambda (node) (process-script node))))))
+
+ ;;
+ ;; Anything else is an error
+ ;;
+ (else
+ (xml-error node "Resource must define either a named pipeline, using the
'name' attribute, or flow scripts, using the 'type' attribute"))
+ ))
+ ;; This is the main of process-sitemap.
+ ;;
;; Process the SXML representation of the sitemap. This is done by
;; invoking the apply-templates function on the SXML representation
;; of the sitemap.
@@ -601,7 +667,7 @@
(set! pcount 0)
;; Compute the available resources first.
(apply-templates
- sitemap
+ xsxml
`((resources resource . ,(lambda (node) (process-resource node)))))
;; `matchers' will contain a list of (regexp . matcher-function)
@@ -609,7 +675,7 @@
;; represents the sitemap.
(let* ((matchers
(apply-templates
- sitemap
+ xsxml
`((pipelines pipeline match
. ,(lambda (node) (process-match node))))))
(sitemap-code
@@ -671,16 +737,19 @@
;; SchemeSitemap#process method will invoke the main function, usually
;; defined as `main'. This will simply call the function stored in
;; `the-sitemap'.
-(define (sitemap-parse! manager source)
+(define (sitemap-parse! sitemap manager source)
(let* ((sxml (sitemap:parse manager source))
- (xsxml (process-sitemap sxml)))
+ (xsxml (process-sitemap sitemap sxml)))
(if (not (eq? xsxml 'error))
(set! the-sitemap xsxml))))
;; This is the main entry point in the Scheme Cocoon sitemap. This
;; function is invoked from the SchemeSitemap#process method.
(define (main url sitemap environment)
- (the-sitemap url sitemap environment))
+ (call/cc
+ (lambda (k)
+ (environ:set-attr environment "suicide" k)
+ (the-sitemap url sitemap environment))))
(define test-sitemap
'(sitemap (@ (*line* 3))
----------------------------------------------------------------------
In case of troubles, e-mail: [EMAIL PROTECTED]
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
