ovidiu 02/01/18 17:02:23
Modified: src/scratchpad/schecoon/scheme sitemap.scm
Log:
Define sitemap-parse! to parse the XML representation of the sitemap
into Scheme.
Revision Changes Path
1.4 +259 -226 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.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sitemap.scm 17 Jan 2002 18:06:16 -0000 1.3
+++ sitemap.scm 19 Jan 2002 01:02:22 -0000 1.4
@@ -6,7 +6,7 @@
(load-module "sisc.modules.Regexp")
(load-module "sisc.modules.J2S")
-(load-module "org.apache.cocoon.scheme.sitemap.SchemeSitemap")
+(load-module "org.apache.cocoon.scheme.sitemap.SchemeSitemapFunctions")
;; A Cocoon XML sitemap description is processed by the Scheme code in
;; this file. The processing happens in several steps:
@@ -46,15 +46,15 @@
;; (pipelines (@ (*line* 1))
;; (pipeline (@ (*line* 2))
;; (match (@ (pattern "documentation/(.*).html") (*line* 3))
-;; (generate (@ (src "docs/{1}.xml") (type "file") (*line* 4))
-;; (param (@ (name "test") (value "123") (*line* 5)))
-;; (transform (@ (src "stylesheets/document2html.xsl") (@ (*line* 6)))
-;; (param (@ (name "test2") (value "456") (@ (*line* 7))))
-;; (serialize (@ (*line* 8)))
-;; )
+;; (generate (@ (src "docs/{1}.xml") (type "file") (*line* 4))
+;; (param (@ (name "test") (value "123") (*line* 5)))
+;; (transform (@ (src "stylesheets/document2html.xsl") (@ (*line* 6)))
+;; (param (@ (name "test2") (value "456") (@ (*line* 7))))
+;; (serialize (@ (*line* 8)))
+;; )
;;
;; (match (@ (pattern "sites/images/(.*).gif") (*line* 10))
-;; (read (@ (src "{1}") (mime-type "image/gif") (@ (*line* 11)))))
+;; (read (@ (src "{1}") (mime-type "image/gif") (@ (*line* 11)))))
;; )))
;;
;; The line numbers where an element starts are added by the XML
@@ -65,46 +65,46 @@
;;
;;(define the-sitemap
;; (let ((rx1 (regexp "documentation/(.*).html"))
-;; (rx2 (regexp "sites/images/(.*).gif")))
+;; (rx2 (regexp "sites/images/(.*).gif")))
;; (define (p1 url sitemap env)
;; (let ((result (regexp-match rx1 url)))
-;; (if result
-;; (apply
-;; (lambda (arg1 . rest)
-;; (sitemap:process
-;; sitemap env '()
-;; (sitemap:serialize
-;; sitemap env '()
-;; (sitemap:transform
-;; sitemap env
-;; (list (cons 'params (list (cons "test" "123")
-;; (cons "test2" "456")))
-;; (cons 'src "stylesheets/document2html.xsl"))
-;; (sitemap:generate
-;; sitemap env
-;; (list (cons 'params (list (cons "test" "123")
-;; (cons "test2" "456")))
-;; (cons 'src (string-append "docs/" arg1 ".xml"))
-;; (cons 'type "file")))))))
-;; (cdr result))
-;; #f)))
+;; (if result
+;; (apply
+;; (lambda (arg1 . rest)
+;; (sitemap:process
+;; sitemap env '()
+;; (sitemap:serialize
+;; sitemap env '()
+;; (sitemap:transform
+;; sitemap env
+;; (list (cons 'params (list (cons "test" "123")
+;; (cons "test2" "456")))
+;; (cons 'src "stylesheets/document2html.xsl"))
+;; (sitemap:generate
+;; sitemap env
+;; (list (cons 'params (list (cons "test" "123")
+;; (cons "test2" "456")))
+;; (cons 'src (string-append "docs/" arg1 ".xml"))
+;; (cons 'type "file")))))))
+;; (cdr result))
+;; #f)))
;;
;; (define (p2 url sitemap env)
;; (let ((result (regexp-match rx2 url)))
-;; (if result
-;; (apply (lambda (arg1 . rest)
-;; (sitemap:process
-;; sitemap env '()
-;; (sitemap:read
-;; sitemap env
-;; '(("src" . (string-append "" arg1 ""))
-;; ("mime-type" . "image/gif")))))
-;; (cdr result))
-;; #f)))
+;; (if result
+;; (apply (lambda (arg1 . rest)
+;; (sitemap:process
+;; sitemap env '()
+;; (sitemap:read
+;; sitemap env
+;; '(("src" . (string-append "" arg1 ""))
+;; ("mime-type" . "image/gif")))))
+;; (cdr result))
+;; #f)))
;;
;; (lambda (url sitemap env)
;; (or (p1 url sitemap env)
-;; (p2 url sitemap env)))))
+;; (p2 url sitemap env)))))
;;
;;
;; Notice that all the {1}, {2}, ...{n} get expanded in the body of
@@ -130,20 +130,20 @@
;;
(define (process-sitemap sitemap)
(let ((exit #f)
- (arg-regexp (regexp "/({[0-9]+})/"))
- (number-arg-regexp (regexp "[{}]"))
- (match-pattern-regexp (regexp "/(\\([^)]+\\))/"))
- (pattern-regexps-no 0)
- (pcount 0))
+ (arg-regexp (regexp "/({[0-9]+})/"))
+ (number-arg-regexp (regexp "[{}]"))
+ (match-pattern-regexp (regexp "/(\\([^)]+\\))/"))
+ (pattern-regexps-no 0)
+ (pcount 0))
;; Print out an error message, showing the line in the XML document
;; where the error occured, if such information is present in the
;; SXML tree.
(define (xml-error node message)
(let ((line (sxml:attr node '*line*)))
- (if line
- (begin (display "In line ") (display line) (display ": ")))
- (display message) (newline) (exit 'error)))
+ (if line
+ (begin (display "In line ") (display line) (display ": ")))
+ (display message) (newline) (exit 'error)))
;; Returns the remaining pipeline after the first element has been
;; removed.
@@ -159,82 +159,82 @@
;; If no such occurrence is found, the value is simply returned.
(define (expand-value node value)
(let* ((exp (regexp-split arg-regexp value))
- (length (vector-length exp)))
- (if (eq? length 1)
- value
- `(string-append
- ,@(vector->list
- (let loop ((index 1))
- (if (>= index length)
- exp
- (let* ((arg (vector-ref exp index))
- (n (vector-ref (regexp-split/delimiter
- number-arg-regexp arg) 1)))
- ;; Check to see if `n' is greater than the
- ;; maximum number of paranthesised
- ;; expressions in the original pattern.
- (if (> (string->number n) pattern-regexps-no)
- (xml-error node (format "Reference to inexistent regexp
pattern ~a, maximum allowed is ~s" n pattern-regexps-no)))
- (if (< (string->number n) 1)
- (xml-error node (format "Regexp pattern argument should
be greater than 1, got ~a" n)))
- (vector-set! exp index
- (string->symbol (string-append "arg" n)))
- (loop (+ index 2)))))))
- )))
+ (length (vector-length exp)))
+ (if (eq? length 1)
+ value
+ `(string-append
+ ,@(vector->list
+ (let loop ((index 1))
+ (if (>= index length)
+ exp
+ (let* ((arg (vector-ref exp index))
+ (n (vector-ref (regexp-split/delimiter
+ number-arg-regexp arg) 1)))
+ ;; Check to see if `n' is greater than the
+ ;; maximum number of paranthesised
+ ;; expressions in the original pattern.
+ (if (> (string->number n) pattern-regexps-no)
+ (xml-error node (format "Reference to inexistent
regexp pattern ~a, maximum allowed is ~s" n pattern-regexps-no)))
+ (if (< (string->number n) 1)
+ (xml-error node (format "Regexp pattern argument
should be greater than 1, got ~a" n)))
+ (vector-set! exp index
+ (string->symbol (string-append "arg" n)))
+ (loop (+ index 2)))))))
+ )))
;; Collect embedded <param> elements into a list of name/value
;; pairs and return it.
(define (get-params elements)
(if (eq? elements '())
- '()
- (let* ((nodelist ((node-pos 1) elements))
- (node (if (null? nodelist) '() (car nodelist)))
- (name (sxml:attr node 'name))
- (value (sxml:attr node 'value)))
- (if (null? name)
- (xml-error node "Attribute 'name' is required in <param>"))
- (if (null? value)
- (xml-error node "Attribute 'value' is required in <param>"))
- (cons `(cons ,name ,(expand-value node value))
- (get-params (rest-of-nodes elements)))
- )))
+ '()
+ (let* ((nodelist ((node-pos 1) elements))
+ (node (if (null? nodelist) '() (car nodelist)))
+ (name (sxml:attr node 'name))
+ (value (sxml:attr node 'value)))
+ (if (null? name)
+ (xml-error node "Attribute 'name' is required in <param>"))
+ (if (null? value)
+ (xml-error node "Attribute 'value' is required in <param>"))
+ (cons `(cons ,name ,(expand-value node value))
+ (get-params (rest-of-nodes elements)))
+ )))
;; Obtain the list of required and optional arguments, as well as
;; the parameters, if they are needed.
(define (get-attributes node required optional allows-params)
(let* ((elem-name (sxml:element-name node))
- (args '())
- (params '())
- (required-attrs
- (map
- (lambda (attr-name)
- (let ((attr (sxml:attr node attr-name)))
- (if (not attr)
- (xml-error node
- (format "'~s' attribute required in <~s>"
- attr-name elem-name))
- `(cons ',attr-name ,(expand-value node attr)))))
- required))
- (optional-attrs '()))
- (for-each
- (lambda (attr-name)
- (let ((attr (sxml:attr node attr-name)))
- (if attr
- (set! optional-attrs
- (cons `(cons ',attr-name ,(expand-value node attr))
- optional-attrs)))))
- optional)
-
- (if (not (null? required-attrs))
- (set! args (append args required-attrs)))
- (if (not (null? optional-attrs))
- (set! args (append args optional-attrs)))
- (if allows-params
- (begin
- (set! params (get-params (sxml:content node)))
- (if (not (null? params))
- (set! args (cons `(cons 'params (list ,@params)) args)))))
- (if (null? args) `('()) `((list ,@args)))))
+ (args '())
+ (params '())
+ (required-attrs
+ (map
+ (lambda (attr-name)
+ (let ((attr (sxml:attr node attr-name)))
+ (if (not attr)
+ (xml-error node
+ (format "'~s' attribute required in <~s>"
+ attr-name elem-name))
+ `(cons ',attr-name ,(expand-value node attr)))))
+ required))
+ (optional-attrs '()))
+ (for-each
+ (lambda (attr-name)
+ (let ((attr (sxml:attr node attr-name)))
+ (if attr
+ (set! optional-attrs
+ (cons `(cons ',attr-name ,(expand-value node attr))
+ optional-attrs)))))
+ optional)
+
+ (if (not (null? required-attrs))
+ (set! args (append args required-attrs)))
+ (if (not (null? optional-attrs))
+ (set! args (append args optional-attrs)))
+ (if allows-params
+ (begin
+ (set! params (get-params (sxml:content node)))
+ (if (not (null? params))
+ (set! args (cons `(cons 'params (list ,@params)) args)))))
+ (if (null? args) `('()) `((list ,@args)))))
;; The following match- functions should probably be transformed
;; into a macro, and described at a much higher level than now. A
@@ -243,101 +243,101 @@
;; Translate a <generate> element.
(define (match-generate pipeline)
(let* ((nodelist ((node-pos 1) pipeline))
- (node (if (null? nodelist) '() (car nodelist))))
- (if (not (eq? (sxml:element-name node) 'generate))
- #f
- (begin
- (let ((args (get-attributes node '(src) '(type) #t)))
- (match-transform
- (rest-of-nodes pipeline)
- `(sitemap:generate sitemap env ,@args))
- )))))
+ (node (if (null? nodelist) '() (car nodelist))))
+ (if (not (eq? (sxml:element-name node) 'generate))
+ #f
+ (begin
+ (let ((args (get-attributes node '(src) '(type) #t)))
+ (match-transform
+ (rest-of-nodes pipeline)
+ `(sitemap:generate sitemap env ,@args))
+ )))))
;; Translate zero or more <transform> elements
(define (match-transform pipeline compfunc)
(let* ((nodelist ((node-pos 1) pipeline))
- (node (if (null? nodelist) '() (car nodelist))))
- (cond
- ((eq? (sxml:element-name node) 'transform)
- (let ((args (get-attributes node '(src) '(type) #t)))
- (match-transform
- (rest-of-nodes pipeline)
- `(sitemap:transform sitemap env ,@args ,compfunc))
- ))
- (else (match-serialize pipeline compfunc))
- )))
+ (node (if (null? nodelist) '() (car nodelist))))
+ (cond
+ ((eq? (sxml:element-name node) 'transform)
+ (let ((args (get-attributes node '(src) '(type) #t)))
+ (match-transform
+ (rest-of-nodes pipeline)
+ `(sitemap:transform sitemap env ,@args ,compfunc))
+ ))
+ (else (match-serialize pipeline compfunc))
+ )))
;; Transform zero or one <serializer> elements
(define (match-serialize pipeline compfunc)
(let* ((nodelist ((node-pos 1) pipeline))
- (node (if (null? nodelist) '() (car nodelist))))
- (cond
- ;; A serializer has been explicitly defined
- ((eq? (sxml:element-name node) 'serialize)
- (let ((args (get-attributes node '() '(type mime-type) #t)))
- (match-pipeline-end
- (rest-of-nodes pipeline)
- `(sitemap:serialize sitemap env ,@args ,compfunc))))
-
- ;; End of the pipeline with no serializer specified
- ((eq? node '())
- `(sitemap:serialize sitemap env ,compfunc))
-
- ;; Anything else is an error
- (else
- (xml-error node "Only <transformer> or <serialize> allowed here"))
- )))
+ (node (if (null? nodelist) '() (car nodelist))))
+ (cond
+ ;; A serializer has been explicitly defined
+ ((eq? (sxml:element-name node) 'serialize)
+ (let ((args (get-attributes node '() '(type mime-type) #t)))
+ (match-pipeline-end
+ (rest-of-nodes pipeline)
+ `(sitemap:serialize sitemap env ,@args ,compfunc))))
+
+ ;; End of the pipeline with no serializer specified
+ ((eq? node '())
+ `(sitemap:serialize sitemap env ,compfunc))
+
+ ;; Anything else is an error
+ (else
+ (xml-error node "Only <transformer> or <serialize> allowed here"))
+ )))
;; Translate a <read> element
(define (match-reader pipeline)
(let* ((nodelist ((node-pos 1) pipeline))
- (node (if (null? nodelist) '() (car nodelist))))
- (cond
- ((eq? (sxml:element-name node) 'read)
- (let ((args (get-attributes node '(src) '(type mime-type) #t)))
- (match-pipeline-end
- (rest-of-nodes pipeline)
- `(sitemap:read sitemap env ,@args))
- ))
- (else #f)
- )))
+ (node (if (null? nodelist) '() (car nodelist))))
+ (cond
+ ((eq? (sxml:element-name node) 'read)
+ (let ((args (get-attributes node '(src) '(type mime-type) #t)))
+ (match-pipeline-end
+ (rest-of-nodes pipeline)
+ `(sitemap:read sitemap env ,@args))
+ ))
+ (else #f)
+ )))
;; Make sure nothing follows the pipeline definition
(define (match-pipeline-end pipeline compfunc)
(let* ((nodelist ((node-pos 1) pipeline))
- (node (if (null? nodelist) '() (car nodelist))))
- (if (null? node)
- compfunc
- (xml-error node "No element allowed in this context"))))
+ (node (if (null? nodelist) '() (car nodelist))))
+ (if (null? node)
+ compfunc
+ (xml-error node "No element allowed in this context"))))
;; The entry point in matching a pipeline. Transforms a pipeline
;; definition into a Scheme function whose body executes the
;; described pipeline.
(define (match-pipeline pipeline)
(let ((procname (string->symbol (format "p~a" pcount)))
- (rxname (string->symbol (format "rx~a" pcount))))
- `(define (,procname url sitemap env)
- (let ((result (regexp-match ,rxname url)))
- (if result
- (apply
- (lambda ,(let loop ((index 1))
- (if (> index pattern-regexps-no)
- 'rest
- (cons
- (string->symbol
- (format "arg~a" (number->string index)))
- (loop (+ index 1)))))
- (sitemap:process
- sitemap env '()
- ,(or
- (match-generate pipeline)
- (match-reader pipeline)
- (let* ((nodelist ((node-pos 1) pipeline))
- (node (if (null? nodelist) '() (car nodelist))))
- (xml-error node "Invalid pipeline definition")))))
- (cdr result))
- #f)))
- ))
+ (rxname (string->symbol (format "rx~a" pcount))))
+ `(define (,procname url sitemap env)
+ (let ((result (regexp-match ,rxname url)))
+ (if result
+ (apply
+ (lambda ,(let loop ((index 1))
+ (if (> index pattern-regexps-no)
+ 'rest
+ (cons
+ (string->symbol
+ (format "arg~a" (number->string index)))
+ (loop (+ index 1)))))
+ (sitemap:process
+ sitemap env '()
+ ,(or
+ (match-generate pipeline)
+ (match-reader pipeline)
+ (let* ((nodelist ((node-pos 1) pipeline))
+ (node (if (null? nodelist) '() (car nodelist))))
+ (xml-error node "Invalid pipeline definition")))))
+ (cdr result))
+ #f)))
+ ))
;; This is the main processing function for a 'match' node in the
;; SXML representation of the sitemap. This function returns an
@@ -351,20 +351,20 @@
;; Check for the presence of the 'pattern' attribute and signal
;; an error if not present
(let ((pattern (sxml:attr node 'pattern)))
- (if (not pattern)
- (xml-error
- node "required 'pattern' attribute for <match> is not present"))
- ;; Increment the pipelines count
- (set! pcount (+ pcount 1))
- ;; Translate the pipeline definitions into equivalent Scheme
- ;; functions
- (let ((pipeline (reverse (sxml:child-elements node)))
- (exp-pattern (regexp-split match-pattern-regexp pattern))
- (rxname (string->symbol (format "rx~a" pcount))))
- (set! pattern-regexps-no (/ (- (vector-length exp-pattern) 1) 2))
- (list (cons `(,rxname (regexp ,pattern))
- (match-pipeline pipeline)))
- )))
+ (if (not pattern)
+ (xml-error
+ node "required 'pattern' attribute for <match> is not present"))
+ ;; Increment the pipelines count
+ (set! pcount (+ pcount 1))
+ ;; Translate the pipeline definitions into equivalent Scheme
+ ;; functions
+ (let ((pipeline (reverse (sxml:child-elements node)))
+ (exp-pattern (regexp-split match-pattern-regexp pattern))
+ (rxname (string->symbol (format "rx~a" pcount))))
+ (set! pattern-regexps-no (/ (- (vector-length exp-pattern) 1) 2))
+ (list (cons `(,rxname (regexp ,pattern))
+ (match-pipeline pipeline)))
+ )))
;; Process the SXML representation of the sitemap. This is done by
;; invoking the apply-templates function on the SXML representation
@@ -380,29 +380,62 @@
;; . matcher-function). We iterate on it to construct the top
;; level function that represents the sitemap.
(let* ((matchers
- (apply-templates
- sitemap
- `((match . ,(lambda (node) (process-match node))))))
- (sitemap-code
- `(let ,(let loop ((ms matchers))
- (if (null? ms)
- '()
- (cons (caar ms)
- (loop (cdr ms)))))
- ,@(let loop ((ms matchers))
- (if (null? ms)
- '()
- (cons (cdar ms)
- (loop (cdr ms)))))
- (lambda (url sitemap env)
- (or ,@(let loop ((index 1))
- (if (> index pcount)
- '()
- (cons
- (list (string->symbol (format "p~a" index))
- 'url 'sitemap 'env)
- (loop (+ index 1))))))))))
-; (newline) (write sitemap-code) (newline)
- (eval sitemap-code (interaction-environment))
- )))
+ (apply-templates
+ sitemap
+ `((match . ,(lambda (node) (process-match node))))))
+ (sitemap-code
+ `(let ,(let loop ((ms matchers))
+ (if (null? ms)
+ '()
+ (cons (caar ms)
+ (loop (cdr ms)))))
+ ,@(let loop ((ms matchers))
+ (if (null? ms)
+ '()
+ (cons (cdar ms)
+ (loop (cdr ms)))))
+ (lambda (url sitemap env)
+ (or ,@(let loop ((index 1))
+ (if (> index pcount)
+ '()
+ (cons
+ (list (string->symbol (format "p~a" index))
+ 'url 'sitemap 'env)
+ (loop (+ index 1))))))))))
+; (newline) (write sitemap-code) (newline)
+ (eval sitemap-code (interaction-environment))
+ )))
))
+
+;; `the-sitemap' will contain the compiled version of the sitemap.
+(define the-sitemap #f)
+
+;; Invoked from the Java side to parse the XML representation of the
+;; sitemap and update the `sxml-sitemap' variable. The processing of
+;; the XML sitemap representation happens in two steps.
+;;
+;; In the first step the, using the `sitemap:parse' function, the XML
+;; representation is translated into SXML. This translation happens in
+;; Java, using the XMLtoSXML ContentHandler, which is invoked through
+;; `sitemap:parse', a native function defined in
+;; SchemeSitemapFunctions.
+;;
+;; In the second step, the SXML representation of the sitemap is
+;; converted to a Scheme function, using the `process-sitemap'
+;; function defined above. The result of this processing, the
+;; "executable" sitemap function is set as value for `the-sitemap'
+;; variable.
+;;
+;; When an HTTP request is to be processed by Cocoon, the
+;; 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)
+ (let ((sxml (sitemap:parse manager source))
+ (xsxml (process-sitemap sxml)))
+ (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))
----------------------------------------------------------------------
In case of troubles, e-mail: [EMAIL PROTECTED]
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
