ovidiu 02/01/25 14:59:29
Modified: src/scratchpad/schecoon/scheme sitemap.scm
Log:
Added support for defining and referencing resources, and invoking
Scheme functions directly.
Revision Changes Path
1.7 +319 -86 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.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- sitemap.scm 19 Jan 2002 02:13:19 -0000 1.6
+++ sitemap.scm 25 Jan 2002 22:59:29 -0000 1.7
@@ -1,4 +1,4 @@
-;; Sitemap definitions
+;; Cocoon sitemap translator
;;
;; Author: Ovidiu Predescu <[EMAIL PROTECTED]>
;; Date: December 12, 2001
@@ -67,7 +67,7 @@
;;
;;(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
@@ -117,6 +117,13 @@
;; which, when executed, will process the HTTP request as described in
;; the original XML sitemap.
+;; Converts a name to a resource. `name' is either a string or a
+;; symbol. The return value is r_<name> and is of the same type as
+;; `name'.
+(define (name->resource name)
+ (cond ((string? name) (string-append "r_" name))
+ ((symbol? name) (name->resource (symbol->string name)))
+ (else #f)))
;; The main function to process an SXML representation of the sitemap,
;; and generate a function which is the executable version of the
@@ -132,11 +139,67 @@
;;
(define (process-sitemap sitemap)
(let ((exit #f)
- (arg-regexp (regexp "/({[0-9]+})/"))
- (number-arg-regexp (regexp "[{}]"))
+ ;; Regular expressions for matching various types of arguments
+ (res-arg-regexp (regexp "/({[^0-9].*})/"))
+ (res-arg-regexp-match (regexp "{[^0-9].*}"))
+ (num-arg-regexp (regexp "/({[0-9]+})/"))
+ (arg-regexp-split (regexp "[{}]"))
(match-pattern-regexp (regexp "/(\\([^)]+\\))/"))
+
+ ;; The number of paranthesised groups in the current pattern
+ ;; being analyzed by match-match.
(pattern-regexps-no 0)
- (pcount 0))
+
+ ;; The number of pipelines analyzed so far
+ (pcount 0)
+
+ ;; Identifies all the <map:resource name="..."> elements. It
+ ;; is a list of pairs, with the car being the function
+ ;; signature, and the cons being the function body definition:
+ ;;
+ ;; ((function-name arguments ...) . function-definition-code)
+ ;;
+ ;; This is used in the translating the calls to the pipeline
+ ;; resources defined.
+ (resources '()))
+
+ ;; Search for a resource whose name is `name'. Returns the cons
+ ;; entry in the `resources' store, which holds the function
+ ;; signature and the function body of the resource. #f is returned
+ ;; if no resource `name' is found.
+ (define (lookup-resource name)
+ (let loop ((resources resources))
+ (if (null? resources)
+ #f
+ (let ((elem (caar resources)))
+ (if (eq? elem name)
+ (car resources)
+ (loop (cdr resources)))))))
+
+ ;; Adds a new resource to the available resources. No check is
+ ;; done to see if a similarly named resource exists.
+ (define (add-resource funsig funbody)
+ (set! resources (cons (cons funsig funbody) resources)))
+
+ ;; Return the signature of the resource named `name' or #f if no
+ ;; such resource exits.
+ (define (resource-function-signature name)
+ (let ((resource (lookup-resource name)))
+ (if resource
+ (car resource)
+ #f)))
+
+ ;; Return the body of the resource named `name' or #f if no such
+ ;; resource exists.
+ (define (resource-function-body name)
+ (let ((resource (lookup-resource name)))
+ (if resource
+ (cdr resource)
+ #f)))
+
+ ;; Return a list of all the function bodies.
+ (define (resources-get-function-bodies)
+ (map (lambda (res) (cdr res)) resources))
;; Print out an error message, showing the line in the XML document
;; where the error occured, if such information is present in the
@@ -153,40 +216,64 @@
((take-after (lambda (node) #t)) nodelist))
;; Takes a string value and replaces in it all occurrences of
- ;; '{n}', where 'n' is a number, with argN. If such an occurrence
- ;; is found, the value returned is an expression of this form:
+ ;; '{n}', where 'n' is required to be either a number or a
+ ;; name. If `n' is a number, `{n} will be replace with `argN',
+ ;; which stands for the function argument with the same name. If
+ ;; `n' is a name, `{n}' is replaced with `n', which also stands
+ ;; for the function argument with the same name. If such an
+ ;; occurrence is found, the value returned is an expression of
+ ;; this form:
;;
;; "...{n}..." -> (string-append "..." argN "...")
;;
+ ;; or
+ ;;
+ ;; "...{n}..." -> (string-append "..." n "...")
+ ;;
;; 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)))))))
- )))
+ (define (expand-value node value args-are-numbers?)
+ (let* ((rx (if args-are-numbers? num-arg-regexp res-arg-regexp))
+ (exp (filter (lambda (x) (if (equal? x "") #f x))
+ (vector->list (regexp-split rx value))))
+ (exp2
+ (reverse
+ (let loop ((lst exp) (acc '()))
+ (if (null? lst)
+ acc
+ (let* ((arg (car lst))
+ (split-arg (regexp-split/delimiter
+ arg-regexp-split arg))
+ (n (if (> (vector-length split-arg) 1)
+ (vector-ref split-arg 1)
+ #f)))
+ (if n
+ ;; If we are looking for argument numbers,
+ ;; verify than `n' is greater than the
+ ;; maximum number of paranthesised
+ ;; expressions in the original pattern.
+ (if args-are-numbers?
+ (begin
+ (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)))
+ (set! arg (string->symbol (string-append "arg" n))))
+ ;; If the argument is not a number, we
+ ;; want to convert it to a symbol, so
+ ;; that in the generated code
+ ;; expression it will refer to the
+ ;; function argument with the same
+ ;; name.
+ (set! arg (string->symbol n))))
+ (loop (cdr lst) (cons arg acc)))))
+ )))
+ (if (= (length exp2) 1)
+ (car exp2)
+ `(string-append ,@exp2))))
;; Collect embedded <param> elements into a list of name/value
;; pairs and return it.
- (define (get-params elements)
+ (define (get-params elements args-are-numbers?)
(if (eq? elements '())
'()
(let* ((nodelist ((node-pos 1) elements))
@@ -197,13 +284,13 @@
(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)))
- )))
+ (cons `(cons ,name ,(expand-value node value args-are-numbers?))
+ (get-params (rest-of-nodes elements) args-are-numbers?)))
+ ))
;; 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)
+ (define (get-attributes node required optional allow-params args-are-numbers?)
(let* ((elem-name (sxml:element-name node))
(args '())
(params '())
@@ -215,7 +302,8 @@
(xml-error node
(format "'~s' attribute required in <~s>"
attr-name elem-name))
- `(cons ',attr-name ,(expand-value node attr)))))
+ `(cons ',attr-name
+ ,(expand-value node attr args-are-numbers?)))))
required))
(optional-attrs '()))
(for-each
@@ -223,17 +311,19 @@
(let ((attr (sxml:attr node attr-name)))
(if attr
(set! optional-attrs
- (cons `(cons ',attr-name ,(expand-value node attr))
- optional-attrs)))))
+ (cons
+ `(cons ',attr-name
+ ,(expand-value node attr args-are-numbers?))
+ 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
+ (if allow-params
(begin
- (set! params (get-params (sxml:content node)))
+ (set! params (get-params (sxml:content node) args-are-numbers?))
(if (not (null? params))
(set! args (cons `(cons 'params (list ,@params)) args)))))
(if (null? args) `('()) `((list ,@args)))))
@@ -243,40 +333,45 @@
;; grammar like approach seems appropriate here.
;; Translate a <generate> element.
- (define (match-generate pipeline)
+ (define (match-generate pipeline args-are-numbers?)
(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)))
+ (let ((args (get-attributes node '(src) '(type) #t
+ args-are-numbers?)))
(match-transform
(rest-of-nodes pipeline)
- `(sitemap:generate sitemap env ,@args))
+ `(sitemap:generate sitemap env ,@args)
+ args-are-numbers?)
)))))
;; Translate zero or more <transform> elements
- (define (match-transform pipeline compfunc)
+ (define (match-transform pipeline compfunc args-are-numbers?)
(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)))
+ (let ((args (get-attributes node '(src) '(type) #t
+ args-are-numbers?)))
(match-transform
(rest-of-nodes pipeline)
- `(sitemap:transform sitemap env ,@args ,compfunc))
+ `(sitemap:transform sitemap env ,@args ,compfunc)
+ args-are-numbers?)
))
- (else (match-serialize pipeline compfunc))
+ (else (match-serialize pipeline compfunc args-are-numbers?))
)))
;; Transform zero or one <serializer> elements
- (define (match-serialize pipeline compfunc)
+ (define (match-serialize pipeline compfunc args-are-numbers?)
(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)))
+ (let ((args (get-attributes node '() '(type mime-type) #t
+ args-are-numbers?)))
(match-pipeline-end
(rest-of-nodes pipeline)
`(sitemap:serialize sitemap env ,@args ,compfunc))))
@@ -291,12 +386,13 @@
)))
;; Translate a <read> element
- (define (match-reader pipeline)
+ (define (match-reader pipeline args-are-numbers?)
(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)))
+ (let ((args (get-attributes node '(src) '(type mime-type) #t
+ args-are-numbers?)))
(match-pipeline-end
(rest-of-nodes pipeline)
`(sitemap:read sitemap env ,@args))
@@ -304,6 +400,41 @@
(else #f)
)))
+ ;; Translate a <call function="..."> element
+ (define (match-call-function pipeline args-are-numbers?)
+ (let* ((nodelist ((node-pos 1) pipeline))
+ (node (if (null? nodelist) '() (car nodelist))))
+ (cond
+ ((and (eq? (sxml:element-name node) 'call)
+ (sxml:attr node 'function))
+ (let ((args (get-attributes node '(function) '() #t
+ args-are-numbers?)))
+ (match-pipeline-end
+ (rest-of-nodes pipeline)
+ `(begin (function-call-v sitemap env ,@args) #t))
+ ))
+ (else #f)
+ )))
+
+ ;; Translate a <call resource="..."> element
+ (define (match-call-resource pipeline args-are-numbers?)
+ (let* ((nodelist ((node-pos 1) pipeline))
+ (node (if (null? nodelist) '() (car nodelist))))
+ (cond
+ ((and (eq? (sxml:element-name node) 'call)
+ (sxml:attr node 'resource))
+ (let* ((args (get-attributes node '(resource) '() #t
+ args-are-numbers?))
+ (pipeline
+ ((sxpath '(resources (resource (@ (equal? (name ))))))
+ sitemap)))
+ (match-pipeline-end
+ (rest-of-nodes pipeline)
+ `(begin (display (format "calling ~s~%" ,@args)) (newline)
(resource-call-v sitemap env ,@args) #t))
+ ))
+ (else #f)
+ )))
+
;; Make sure nothing follows the pipeline definition
(define (match-pipeline-end pipeline compfunc)
(let* ((nodelist ((node-pos 1) pipeline))
@@ -315,7 +446,7 @@
;; 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)
+ (define (match-match pipeline args-are-numbers?)
(let ((procname (string->symbol (format "p~a" pcount)))
(rxname (string->symbol (format "rx~a" pcount))))
`(define (,procname url sitemap env)
@@ -329,19 +460,28 @@
(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")))))
+ ,(generate-function-body pipeline args-are-numbers?))
(cdr result))
#f))
(regexp-match ,rxname url)))
))
+ ;; Generates the code for the function body to processes a
+ ;; pipeline
+ (define (generate-function-body pipeline args-are-numbers?)
+ (let ((is-call (or (match-call-function pipeline args-are-numbers?)
+ (match-call-resource pipeline args-are-numbers?))))
+ (if is-call
+ is-call
+ `(sitemap:process
+ sitemap env '()
+ ,(or
+ (match-generate pipeline args-are-numbers?)
+ (match-reader pipeline args-are-numbers?)
+ (let* ((nodelist ((node-pos 1) pipeline))
+ (node (if (null? nodelist) '() (car nodelist))))
+ (xml-error node "Invalid pipeline definition")))))))
+
;; This is the main processing function for a 'match' node in the
;; SXML representation of the sitemap. This function returns an
;; entry like this:
@@ -349,7 +489,7 @@
;; (regexp . matcher-function-representation)
;;
;; The `apply-templates' function which invokes `process-match'
- ;; will collect all these pair and return them in a list.
+ ;; will collect all these pairs and return them in a list.
(define (process-match node)
;; Check for the presence of the 'pattern' attribute and signal
;; an error if not present
@@ -366,9 +506,81 @@
(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)))
+ (match-match pipeline #t)))
)))
+ ;; This function is called by the `apply-templates' function below
+ ;; to process SXML nodes corresponding to <map:resource>.
+ ;;
+ ;; For each named resource we create a function whose name is
+ ;; r_<resource-name>, which contains the definition of the
+ ;; resource obtained by calling `match-match'.
+ ;;
+ ;; This function returns an association whose car is a list, whose
+ ;; first element is a symbol for the function name, and the rest
+ ;; are symbols for the arguments of the function. The cdr of the
+ ;; topmost list is the definition of the function:
+ ;;
+ ;; ((r_<resource-name> arguments ...) . <function-definition>)
+ ;;
+ ;; Each resource might make use of named parameters, like below:
+ ;;
+ ;; <map:resource name="document2html">
+ ;; <map:generate src="{source}" type="file"/>
+ ;; ...
+ ;; </map:resource>
+ ;;
+ ;; This function will identify all the parameters used in the
+ ;; definition of the resource, and will make them arguments in the
+ ;; function definition. The created function will use the
+ ;; `function' macro, instead of the normal Scheme `define'. This
+ ;; allows for named parameters to be passed to the function at
+ ;; runtime.
+ (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))
+ (funsymbol (string->symbol funname))
+ ;; Check to see if a similar resource has already
+ ;; been defined.
+ (_ (if (lookup-resource funsymbol)
+ (xml-error node "A resource named ~s already defined"
+ funsymbol)))
+ (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 `(,funsymbol ,@argument-symbols))
+ (funbody
+ `(function (,funsymbol sitemap env ,@argument-symbols)
+ ,(generate-function-body
+ (reverse (sxml:child-elements node)) #f))))
+ (add-resource funsig funbody)
+ ))))
+
;; Process the SXML representation of the sitemap. This is done by
;; invoking the apply-templates function on the SXML representation
;; of the sitemap.
@@ -379,19 +591,31 @@
(lambda (k)
(set! exit k)
(set! pcount 0)
- ;; `matchers' will contain a list of (regexp
- ;; . matcher-function). We iterate on it to construct the top
- ;; level function that represents the sitemap.
+ ;; Compute the available resources first.
+ (apply-templates
+ sitemap
+ `((resources resource . ,(lambda (node) (process-resource node)))))
+
+ ;; `matchers' will contain a list of (regexp . matcher-function)
+ ;; We'll 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
- `((lambda (,@(let loop ((ms matchers))
+ `((pipelines pipeline match
+ . ,(lambda (node) (process-match node))))))
+ (sitemap-code
+ `((lambda (,@(let loop ((ms matchers))
(if (null? ms)
'()
(cons (caaar ms)
(loop (cdr ms))))))
+ ;; Generate the code for the resource function
+ ;; definitions
+ ,@(resources-get-function-bodies)
+
+ ;; Generate the code corresponding to the
+ ;; <map:match> definitions
,@(let loop ((ms matchers))
(if (null? ms)
'()
@@ -411,13 +635,16 @@
(cons (cadaar ms)
(loop (cdr ms))))))
))
-; (newline) (pretty-print sitemap-code) (newline)
+ (newline) (pretty-print sitemap-code) (newline)
(eval sitemap-code (interaction-environment))
)))
))
;; `the-sitemap' will contain the compiled version of the sitemap.
-(define the-sitemap #f)
+(define the-sitemap
+ (lambda (url sitemap env)
+ (display "Sitemap was not compiled because of errors!")
+ (newline)))
;; Invoked from the Java side to parse the XML representation of the
;; sitemap and update the `sxml-sitemap' variable. The processing of
@@ -442,7 +669,8 @@
(define (sitemap-parse! manager source)
(let* ((sxml (sitemap:parse manager source))
(xsxml (process-sitemap sxml)))
- (set! the-sitemap xsxml)))
+ (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.
@@ -450,17 +678,22 @@
(the-sitemap url sitemap environment))
(define test-sitemap
- '(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)))
- )
-
- (match (@ (pattern "sites/images/(.*).gif") (*line* 10))
- (read (@ (src "{1}") (mime-type "image/gif") (@ (*line* 11)))))
- )))
-
+ '(sitemap (@ (*line* 3))
+ (resources (@ (*line* 5))
+ (resource (@ (name "document2html") (*line* 7))
+ (generate (@ (src "{source}") (type "file") (*line* 8)))
+ (transform (@ (src "stylesheets/document2html.xsl") (*line* 9)))
+ (serialize (@ (*line* 10)))
+ ))
+
+ (pipelines (@ (*line* 15))
+ (pipeline (@ (*line* 16))
+ (match (@ (pattern "a") (*line* 18))
+ (generate (@ (src "docs/{1}.xml") (type "file") (*line* 19)))
+ (transform (@ (src "stylesheets/document2html.xsl") (*line* 20)))
+ (serialize (@ (*line* 21)))
+ )
+
+ (match (@ (pattern "sites/images/(.*).gif") (*line* 23))
+ (read (@ (src "{1}") (mime-type "image/gif") (*line* 24))))
+ ))))
----------------------------------------------------------------------
In case of troubles, e-mail: [EMAIL PROTECTED]
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
