Revision: 6130
Author: iratqq
Date: Thu Dec 31 15:47:51 2009
Log: * scm/sxpathlib.scm:
* scm/sxml-tools.scm:
- New files.
- Note that sxml of attribute symbol is using '%.
That is not the same as original version that attribute symbol is '@,
because sigscheme's (read) doesn't allow (quote @).
* scm/Makefile.am (SCM_FILES):
- Add sxpathlib.scm and sxml-tools.scm.
http://code.google.com/p/uim/source/detail?r=6130
Added:
/trunk/scm/sxml-tools.scm
/trunk/scm/sxpathlib.scm
Modified:
/trunk/scm/Makefile.am
=======================================
--- /dev/null
+++ /trunk/scm/sxml-tools.scm Thu Dec 31 15:47:51 2009
@@ -0,0 +1,889 @@
+;; S X M L T o o l s
+; $Revision: 3.14 $ from $Date: 2003/12/23 05:39:31 $:
+;
+; This software is in Public Domain.
+; IT IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND.
+;
+; Please send bug reports and comments to [email protected]
+; Kirill Lisovsky
+;
+; SXML normal form used for normalization-dependent functions:
+; If attr-list is present it's always the second in SXML element.
+; If aux-list is present - then list of attributes is always
+; included, and aux-list is always the third.
+; Minimized form is just the same, but all the empty aux-lists are
+; absent, and empty attr-lists are present only in elements with aux-lists
+; present.
+
+;==============================================================================
+; Auxiliary functions.
+
+(define (make-char-quotator char-encoding)
+ (let ((bad-chars (map car char-encoding)))
+
+ ; Check to see if str contains one of the characters in charset,
+ ; from the position i onward. If so, return that character's index.
+ ; otherwise, return #f
+ (define (index-cset str i charset)
+ (let loop ((i i))
+ (and (< i (string-length str))
+ (if (memv (string-ref str i) charset) i
+ (loop (inc i))))))
+
+ ; The body of the function
+ (lambda (str)
+ (let ((bad-pos (index-cset str 0 bad-chars)))
+ (if (not bad-pos) str ; str had all good chars
+ (let loop ((from 0) (to bad-pos))
+ (cond
+ ((>= from (string-length str)) '())
+ ((not to)
+ (cons (substring str from (string-length str)) '()))
+ (else
+ (let ((quoted-char
+ (cdr (assv (string-ref str to) char-encoding)))
+ (new-to
+ (index-cset str (inc to) bad-chars)))
+ (if (< from to)
+ (cons
+ (substring str from to)
+ (cons quoted-char (loop (inc to) new-to)))
+ (cons quoted-char (loop (inc to) new-to))))))))))
+))
+
+; unlike filter-map from SRFI-1 this function uses separate predicate
+; and mapping functions.
+; Applies proc to all the elements of source list that satisfy the
predicate
+; and return the list of the results.
+(define (filter-and-map pred proc lis)
+ (let rpt ((l lis))
+ (if (null? l)
+ '()
+ (if (pred (car l))
+ (cons (proc (car l)) (rpt (cdr l)))
+ (rpt (cdr l))))))
+
+; Applies pred to every member of lst and yields #t if all the results
+; are #t
+(define (check-list pred lst)
+ (cond
+ ((null? lst) #t)
+ ((pred (car lst))
+ (check-list pred (cdr lst)))
+ (else #f)))
+
+; Returns attr-list node for a given obj
+; or #f if it is absent
+(define (sxml:attr-list-node obj)
+ (if (and (not (null? (cdr obj)))
+ (pair? (cadr obj))
+ (eq? '% (caadr obj)))
+ (cadr obj)
+ #f))
+
+; Returns attr-list wrapped in list
+; or '((%)) if it is absent and aux-list is present
+; or '() if both lists are absent
+(define (sxml:attr-as-list obj)
+ (cond
+ ((sxml:attr-list-node obj)
+ => list)
+ ((sxml:aux-list-node obj)
+ '((%)))
+ (else '())))
+
+
+; Returns aux-list node for a given obj
+; or #f if it is absent
+(define (sxml:aux-list-node obj)
+ (if
+ (or (null? (cdr obj))
+ (null? (cddr obj))
+ (not (pair? (caddr obj)))
+ (not (eq? (caaddr obj) '%%)))
+ #f
+ (caddr obj)))
+
+; Returns aux-list wrapped in list
+; or '() if it is absent
+(define (sxml:aux-as-list obj)
+ (cond
+ ((sxml:aux-list-node obj)
+ => list)
+ (else '())))
+
+; optimized (string-rindex name #\:)
+; returns position of a separator between namespace-id and LocalName
+(define-macro (sxml:find-name-separator len)
+ `(let rpt ((pos (mm ,len)))
+ (cond
+ ((negative? pos) #f)
+ ((char=? #\: (string-ref name pos)) pos)
+ (else (rpt (mm pos))))))
+
+
+;==============================================================================
+; Predicates
+
+; Predicate which returns #t if given element <obj> is empty.
+; Empty element has no nested elements, text nodes, PIs, Comments or
entities
+; but it may contain attributes or namespace-id.
+; It is a SXML counterpart of XML empty-element.
+(define (sxml:empty-element? obj)
+ (not
+ ((select-first-kid
+ (lambda(x)
+ (or ((ntype-names?? '(*PI* *COMMENT* *ENTITY*)) x)
+ ((ntype?? '*) x)
+ (string? x)))) obj)))
+
+; Returns #t if the given <obj> is shallow-normalized SXML element.
+; The element itself has to be normalised but its nested elements are not
tested.
+(define (sxml:shallow-normalized? obj)
+ (or
+ (null? (cdr obj))
+ (and (or
+ (and
+ (pair? (cadr obj))
+ (eq? (caadr obj) '%))
+ (not ((select-first-kid (ntype-names?? '(% %%))) obj)))
+ (or (null? (cddr obj))
+ (and (pair? (caddr obj))
+ (eq? (caaddr obj) '%%))
+ (not ((select-first-kid (ntype?? '%%)) obj))))))
+
+; Returns #t if the given <obj> is normalized SXML element.
+; The element itself and all its nested elements have to be normalised.
+(define (sxml:normalized? obj)
+ (and
+ (sxml:shallow-normalized? obj)
+ (check-list
+ (lambda(x)
+ (if
+ (sxml:element? x)
+ (sxml:normalized? x)
+ #t))
+ (sxml:content obj))
+ ))
+
+; Returns #t if the given <obj> is shallow-minimized SXML element.
+; The element itself has to be minimised but its nested elements are not
tested.
+(define (sxml:shallow-minimized? obj)
+ (and
+ (sxml:shallow-normalized? obj)
+ (not (and (sxml:aux-list-node obj)
+ (null? (sxml:aux-list obj))))
+ (not (and (sxml:attr-list-node obj)
+ (null? (sxml:attr-list obj))
+ (not (sxml:aux-list-node obj))))))
+
+; Returns #t if the given <obj> is minimized SXML element.
+; The element itself and all its nested elements have to be minimised.
+(define (sxml:minimized? obj)
+ (and
+ (sxml:shallow-minimized? obj)
+ (check-list
+ (lambda(x)
+ (if
+ (sxml:element? x)
+ (sxml:minimized? x)
+ #t))
+ (sxml:content obj))
+ ))
+
+;==============================================================================
+; Accessors
+
+; Returns a name of a given SXML node
+; It is introduced for the sake of encapsulation.
+(define sxml:name car)
+
+; A version of sxml:name, which returns #f if the given <obj> is
+; not a SXML element.
+; Otherwise returns its name.
+(define (sxml:element-name obj)
+ (and ((ntype?? '*) obj)
+ (car obj)))
+
+; Safe version of sxml:name, which returns #f if the given <obj> is
+; not a SXML node.
+; Otherwise returns its name.
+(define (sxml:node-name obj)
+ (and (pair? obj)
+ (symbol? (car obj))
+ (car obj)))
+
+; Returns Local Part of Qualified Name (Namespaces in XML production [6])
+; for given obj, which is ":"-separated suffix of its Qualified Name
+; If a name of a node given is NCName (Namespaces in XML production [4]),
then
+; it is returned as is.
+; Please note that while SXML name is a symbol this function returns a
string.
+(define (sxml:ncname obj)
+ (let* ((name (symbol->string (car obj)))
+ (len (string-length name)))
+ (cond
+ ((sxml:find-name-separator len)
+ => (lambda (pos)
+ (substring name (+ pos 1) len)))
+ (else name))))
+
+; Returns namespace-id part of given name, or #f if it's LocalName
+(define (sxml:name->ns-id sxml-name)
+ (let* ((name (symbol->string sxml-name)))
+ (cond
+ ((sxml:find-name-separator (string-length name))
+ => (lambda (pos)
+ (substring name 0 pos)))
+ (else #f))))
+
+
+; Returns the content of given SXML element or nodeset (just text and
element
+; nodes) representing it as a list of strings and nested elements in
document
+; order. This list is empty if <obj> is empty element or empty list.
+(define (sxml:content obj)
+ (((if (nodeset? obj)
+ sxml:filter
+ select-kids)
+ (lambda(x)
+ (or
+ (string? x) ; ((ntype?? '*text*) x)
+ ((ntype?? '*) x))))
+ obj))
+
+; Returns a string which combines all the character data
+; from text node childrens of the given SXML element
+; or "" if there is no text node children
+(define (sxml:text obj)
+ (let ((tnodes
+ ((select-kids
+ string?)
+ obj)))
+ (cond
+ ((null? tnodes) "")
+ ((null? (cdr tnodes))
+ (car tnodes))
+ (else (string-intersperse tnodes "")))))
+
+;------------------------------------------------------------------------------
+; Normalization-dependent accessors
+;
+;
+; "Universal" accessors are less effective but may be used for
non-normalized SXML
+; Safe accessors are named with suffix '-u'
+;
+; "Fast" accessors are optimized for normalized SXML data.
+; They are not applicable to arbitrary non-normalized SXML data
+; Their names has no specific suffixes
+
+; Returns all the content of normalized SXML element except attr-list and
+; aux-list.
+; Thus it includes PI, COMMENT and ENTITY nodes as well as TEXT and
ELEMENT nodes
+; returned by sxml:content.
+; Returns a list of nodes in document order or empty list if <obj> is
empty
+; element or empty list.
+; This function is faster than sxml:content
+(define (sxml:content-raw obj)
+ ((if (and (not (null? (cdr obj)))
+ (pair? (cadr obj)) (eq? (caadr obj) '%))
+ (if (and (not (null? (cddr obj)))
+ (pair? (caddr obj)) (eq? (caaddr obj) '%%))
+ cdddr
+ cddr)
+ cdr) obj))
+
+
+; Returns the list of attributes for given element or nodeset.
+; Analog of ((sxpath '(% *)) obj)
+; Empty list is returned if there is no list of attributes.
+(define (sxml:attr-list-u obj)
+ (cond (((select-first-kid (ntype?? '%)) obj)
+ => cdr)
+ (else '())))
+
+; Returns the list of auxiliary nodes for given element or nodeset.
+; Analog of ((sxpath '(%% *)) obj)
+; Empty list is returned if a list of auxiliary nodes is absent.
+(define (sxml:aux-list obj)
+ (if
+ (or (null? (cdr obj))
+ (null? (cddr obj))
+ (not (pair? (caddr obj)))
+ (not (eq? (caaddr obj) '%%)))
+ '()
+ (cdaddr obj)))
+
+; Returns the list of auxiliary nodes for given element or nodeset.
+; Analog of ((sxpath '(%% *)) obj)
+; Empty list is returned if a list of auxiliary nodes is absent.
+(define (sxml:aux-list-u obj)
+ (cond (((select-first-kid (ntype?? '%%)) obj)
+ => cdr)
+ (else '())))
+
+; Return the first aux-node with <aux-name> given in SXML element <obj>
+; or #f is such a node is absent.
+; NOTE: it returns just the FIRST node found even if multiple nodes are
+; present, so it's mostly intended for nodes with unique names
+(define (sxml:aux-node obj aux-name)
+ (cond
+ ((assq aux-name (sxml:aux-list obj)))
+ (else #f)))
+
+; Return a list of aux-node with <aux-name> given in SXML element <obj>
+; or '() if such a node is absent.
+(define (sxml:aux-nodes obj aux-name)
+ (filter
+ (lambda(x) (eq? aux-name (car x)))
+ (sxml:aux-list obj)))
+
+; Accessor for an attribute <attr-name> of given SXML element <obj> which
+; It returns:
+; the value of the attribute if the attribute is present
+; #f if there is no such an attribute in the given element
+(define (sxml:attr obj attr-name)
+ (cond
+ ((assq attr-name (sxml:attr-list obj))
+ => cadr)
+ (else #f)))
+
+; Extracts a value of attribute with given name from attr-list
+(define (sxml:attr-from-list attr-list name)
+ (cond
+ ((assq name attr-list)
+ => cadr)
+ (else #f)))
+
+; Accessor for a numerical attribute <attr-name> of given SXML element
<obj>
+; which It returns:
+; a value of the attribute as the attribute as a number if the attribute
+; is present and its value may be converted to number using
string->number
+; #f if there is no such an attribute in the given element or
+; its value can't be converted to a number
+(define (sxml:num-attr obj attr-name)
+ (cond
+ ((assq attr-name (sxml:attr-list obj))
+ => (lambda(x) (string->number (cadr x))))
+ (else #f)))
+
+; Accessor for an attribute <attr-name> of given SXML element <obj> which
+; may also be an attributes-list or nodeset (usually content of SXML
element)
+;
+; It returns:
+; the value of the attribute if the attribute is present
+; #f if there is no such an attribute in the given element
+(define (sxml:attr-u obj attr-name)
+ (cond
+ ((assq attr-name
+ ; the list of attributes is computed below
+ (cond
+ ((and (not (null? (cdr obj)))
+ (pair? (cadr obj))
+ (eq? '% (caadr obj)))
+ (cdadr obj)) ; fast track for normalized elements
+ ((eq? '% (car obj))
+ (cdr obj)) ; if applied to attr-list
+ (else (sxml:attr-list-u obj))))
+ => cadr)
+ (else #f)))
+
+; Returns the list of namespaces for given element.
+; Analog of ((sxpath '(%% *NAMESPACES* *)) obj)
+; Empty list is returned if there is no list of namespaces.
+(define (sxml:ns-list obj)
+ (cond ((assv '*NAMESPACES* (sxml:aux-list obj))
+ => cdr)
+ (else '())))
+
+; Returns the list of namespace-assoc's for given namespace-id in
+; SXML element <obj>.
+; Analog of ((sxpath '(%% *NAMESPACES* namespace-id)) obj)
+; Empty list is returned if there is no namespace-assoc with namespace-id
+; given.
+(define (sxml:ns-id->nodes obj namespace-id)
+ (filter
+ (lambda(x)
+ (eq? (car x) namespace-id))
+ (sxml:ns-list obj)))
+
+; It returns:
+; A URI's for namespace-id given
+; #f if there is no namespace-assoc with namespace-id given
+(define (sxml:ns-id->uri obj namespace-id)
+ (cond
+ ((assq namespace-id (sxml:ns-list obj))
+ => cadr)
+ (else #f)))
+
+; Returns a list of namespace-assocs nodes for NS URI given
+(define (sxml:ns-uri->nodes obj URI)
+ (filter
+ (lambda (ns-assoc)
+ (string=? (cadr ns-assoc) URI))
+ (sxml:ns-list obj)))
+
+; Returns a namespace-id for NS URI given
+(define (sxml:ns-uri->id obj URI)
+ (let rpt ((ns-assocs (sxml:ns-list obj)))
+ (cond
+ ((null? ns-assocs) #f)
+ ((string=? (cadar ns-assocs) URI)
+ (caar ns-assocs))
+ (else (rpt (cdr ns-assocs)))
+ )))
+
+; Returns namespace-id for given namespace-assoc list
+(define sxml:ns-id car)
+
+; Returns URI for given namespace-assoc list
+(define sxml:ns-uri cadr)
+
+; It returns namespace prefix for given namespace-assoc list
+; Original (as in XML document) prefix for namespace-id given
+; has to be strored as the third element in namespace-assoc list
+; if it is different from namespace-id.
+; If original prefix is omitted in namespace-assoc then
+; namespace-id is used instead
+(define (sxml:ns-prefix ns-assoc)
+ (if (> (length ns-assoc) 2)
+ (caddr ns-assoc)
+ (car ns-assoc)))
+
+;==============================================================================
+; Data modification functions
+; Constructors and mutators for normalized SXML data
+;
+; This functions are optimized for normalized SXML data.
+; They are not applicable to arbitrary non-normalized SXML data
+;
+; Most of the functions are provided in two variants:
+; 1. side-effect intended functions for linear update of given elements.
+; Their names are ended with exclamation mark.
+; An example:
+; sxml:change-content!
+; 2. pure functions without side-effects which return modified elements.
+; An example:
+; sxml:change-content
+
+; Change the content of given SXML element to <new-content>
+; If <new-content> is an empty list then the <obj> is transformed
+; The resulting SXML element is normalized
+; Former name sxml:content!
+(define (sxml:change-content! obj new-content)
+ (set-cdr! obj
+ `(
+ ,@(sxml:attr-as-list obj)
+ ,@(sxml:aux-as-list obj)
+ ,@new-content)))
+
+; Change the content of given SXML element to <new-content>
+; If <new-content> is an empty list then the <obj> is transformed
+; to an empty element
+; The resulting SXML element is normalized
+(define (sxml:change-content obj new-content)
+ `(,(sxml:name obj)
+ ,@(sxml:attr-as-list obj)
+ ,@(sxml:aux-as-list obj)
+ ,@new-content))
+
+; The resulting SXML element is normalized, if <new-attrlist> is empty,
+; the cadr of <obj> is (%)
+(define (sxml:change-attrlist obj new-attrlist)
+ `(,(sxml:name obj)
+ ,@(cond
+ (new-attrlist
+ `((% ,@new-attrlist)))
+ ((sxml:aux-list-node obj)
+ '((%)))
+ (else `()))
+ ,@(sxml:aux-as-list obj)
+ ,@(sxml:content obj)))
+
+; The resulting SXML element is normalized, if <new-attrlist> is empty,
+; the cadr of <obj> is (%)
+; Former name sxml:attrlist!
+(define (sxml:change-attrlist! obj new-attrlist)
+ (set-cdr! obj
+ `(
+ ,@(cond
+ (new-attrlist
+ `((% ,@new-attrlist)))
+ ((sxml:aux-list-node obj)
+ '((%)))
+ (else `()))
+ ,@(sxml:aux-as-list obj)
+ ,@(sxml:content obj))))
+
+; Change a name of SXML element destructively
+; Former name was 'sxml:name!'
+(define (sxml:change-name! obj new-name)
+ (set-car! obj new-name))
+
+; Returns SXML element with its name changed
+(define (sxml:change-name obj new-name)
+ (cons new-name (cdr obj)))
+
+; Returns SXML element <obj> with attribute <attr> added or #f
+; if the attribute with given name already exists,
+; <attr> is (<attr-name> <attr-value>)
+; Pure functional counterpart to sxml:add-attr!
+(define (sxml:add-attr obj attr)
+ (let ((attr-list (sxml:attr-list obj)))
+ (if (assq (car attr) attr-list)
+ #f
+ `(,(sxml:name obj)
+ (% ,@(cons attr attr-list))
+ ,@(sxml:aux-as-list obj)
+ ,@(sxml:content obj)))))
+
+; Add an attribute <attr> for an element <obj>
+; Returns #f if the attribute with given name already exists.
+; The resulting SXML node is normalized.
+; Linear update counterpart to sxml:add-attr
+(define (sxml:add-attr! obj attr)
+ (let ((attr-list (sxml:attr-list obj)))
+ (if (assq (car attr) attr-list)
+ #f
+ (begin
+ (set-cdr! obj
+ `(
+ (% ,@(cons attr attr-list))
+ ,@(sxml:aux-as-list obj)
+ ,@(sxml:content obj)))
+ obj))))
+
+
+; Returns SXML element <obj> with changed value of attribute <attr> or #f
+; if where is no attribute with given name.
+; <attr> is (<attr-name> <attr-value>)
+(define (sxml:change-attr obj attr)
+ (let ((attr-list (sxml:attr-list obj)))
+ (if (null? attr-list)
+ #f
+ (cond
+ ((assv (car attr) attr-list)
+ => (lambda (y)
+ `(,(sxml:name obj)
+ (% ,@(map
+ (lambda(at)
+ (if
+ (eq? at y)
+ attr
+ at))
+ attr-list))
+ ,@(sxml:aux-as-list obj)
+ ,@(sxml:content obj)
+ )))
+ (else #f)))))
+
+; Change value of the attribute for element <obj>
+; <attr> is (<attr-name> <attr-value>)
+; Returns #f if where is no such attribute
+(define (sxml:change-attr! obj attr)
+ (let ((x (sxml:attr-list obj)))
+ (if (null? x)
+ #f
+ (cond
+ ((assv (car attr) x) => (lambda (y)
+ (set-cdr! y (cdr attr)) obj))
+ (else #f)))))
+
+; Set attribute <attr> of element <obj>
+; If there is no such attribute the new one is added
+(define (sxml:set-attr obj attr)
+ (let ((attr-list (sxml:attr-list obj)))
+ (cond
+ ((assv (car attr) attr-list)
+ => (lambda (y)
+ `(,(sxml:name obj)
+ (% ,@(map
+ (lambda(at)
+ (if
+ (eq? at y)
+ attr
+ at))
+ attr-list))
+ ,@(sxml:aux-as-list obj)
+ ,@(sxml:content obj)
+ )))
+ (else
+ `(,(sxml:name obj)
+ (% ,@(cons attr attr-list))
+ ,@(sxml:aux-as-list obj)
+ ,@(sxml:content obj))))
+ ))
+
+; Set attribute <attr> of element <obj>
+; If there is no such attribute the new one is added
+(define (sxml:set-attr! obj attr)
+ (let ((attr-list (sxml:attr-list obj)))
+ (cond
+ ((assv (car attr) attr-list)
+ => (lambda (x) (set-cdr! x (cdr attr))))
+ (else (set-cdr! obj
+ `((% ,@(cons attr attr-list))
+ ,@(sxml:aux-as-list obj)
+ ,@(sxml:content obj))))
+ )))
+
+; Returns SXML element <obj> with an auxiliary node <aux-node> added
+(define (sxml:add-aux obj aux-node)
+ `(,(sxml:name obj)
+ (% ,@(sxml:attr-list obj))
+ (%% ,@(cons aux-node (sxml:aux-list obj)))
+ ,@(sxml:content obj)))
+
+; Add an auxiliary node <aux-node> for an element <obj>
+(define (sxml:add-aux! obj aux-node)
+ (set-cdr! obj
+ `(
+ (% ,@(sxml:attr-list obj))
+ (%% ,@(cons aux-node (sxml:aux-list obj)))
+ ,@(sxml:content obj)))
+ obj)
+
+; Eliminates empty lists of attributes and aux-lists for given SXML element
+; <obj> and its descendants ("minimize" it)
+; Returns: minimized and normalized SXML element
+(define (sxml:squeeze! obj)
+ (set-cdr! obj
+ `(,@(cond
+ ((sxml:attr-list-node obj)
+ => (lambda (atl)
+ (if (and (null? (cdr atl))
+ (null? (sxml:aux-list obj)))
+ '()
+ (list atl))))
+ (else '()))
+ ,@(cond ((sxml:aux-list-node obj)
+ => (lambda (axl)
+ (if (null? (cdr axl))
+ '()
+ (list axl))))
+ (else '()))
+ ,@(map
+ (lambda(x)
+ (cond
+ (((ntype?? '*) x)
+ (sxml:squeeze! x)
+ x)
+ (else x)))
+ (sxml:content obj))
+ ))
+ )
+
+
+; Eliminates empty lists of attributes and aux-lists for given SXML element
+; <obj> and its descendants ("minimize" it)
+; Returns: minimized and normalized SXML element
+(define (sxml:squeeze obj)
+ `(,(sxml:name obj)
+ ,@(cond
+ ((sxml:attr-list-node obj)
+ => (lambda (atl)
+ (if (and (null? (cdr atl))
+ (null? (sxml:aux-list obj)))
+ '()
+ (list atl))))
+ (else '()))
+ ,@(cond ((sxml:aux-list-node obj)
+ => (lambda (axl)
+ (if (null? (cdr axl))
+ '()
+ (list axl))))
+ (else '()))
+ ,@(map
+ (lambda(x)
+ (cond
+ (((ntype?? '*) x)
+ (sxml:squeeze x))
+ (else x)))
+ (sxml:content obj))))
+
+; Eliminates empty lists of attributes and ALL aux-lists for given SXML
element
+; <obj> and its descendants
+; Returns: minimized and normalized SXML element
+(define (sxml:clean obj)
+ `(,(sxml:name obj)
+ ,@(cond
+ ((sxml:attr-list-node obj)
+ => (lambda (atl)
+ (if (null? (cdr atl))
+ '()
+ (list atl))))
+ (else '()))
+ ,@(map
+ (lambda(x)
+ (cond
+ (((ntype?? '*) x)
+ (sxml:clean x))
+ (else x)))
+ (sxml:content obj))))
+;==============================================================================
+; SXPath-related
+
+;------------------------------------------------------------------------------
+; Extensions
+
+; select-first-kid:: Pred -> Node -> Node
+; Given a Node, return its first child that satisfy
+; the test-pred?
+; Returns #f if there is no such a child
+; select-first-kid:: Pred -> Nodeset -> Node
+; The same as above, but select among children of all the nodes in
+; the Nodeset
+(define (select-first-kid test-pred?)
+ (lambda(obj)
+ (let rpt ((lst (if (symbol? (car obj))
+ (cdr obj)
+ obj)))
+ (cond
+ ((null? lst) #f)
+ ((and (pair? (car lst))
+ (test-pred? (car lst)))
+ (car lst))
+ (else (rpt (cdr lst))))
+ )))
+
+;------------------------------------------------------------------------------
+; Fast node-parent
+
+; Returns a function of one argument - SXML element - which returns its
parent
+; node using *PARENT* pointer in aux-list
+; '*TOP-PTR* may be used as a pointer to root node
+; It return an empty list when applyed to root node
+(define (sxml:node-parent rootnode)
+ (lambda(obj)
+ (cond
+ ((sxml:aux-node obj '*PARENT*)
+ => (lambda(x)
+ (if
+ (eq? '*TOP-PTR* (cadr x))
+ rootnode
+ ((cadr x)))))
+ ((and (pair? obj)
+ (eq? (car obj) '*TOP* ))
+ '())
+ (else (sxml:error nl "PARENT pointer is absent in: " obj nl)
+ ))))
+
+(define (sxml:add-parents obj . top-ptr)
+ (let rpt
+ ((elt obj)
+ (p '*TOP*)
+ (at-aux (if (eq? (sxml:name obj) '*TOP*)
+ (list (cons '%% (sxml:aux-list-u obj)))
+ (list
+ (cons '% (sxml:attr-list obj))
+ (cons '%% (cons `(*PARENT* ,(lambda() (car top-ptr)))
+ (sxml:aux-list obj))))))
+ ) ; *TOP* is a parent for top-level element
+ (let* ((h (list (sxml:name elt)))
+ (b (append
+ at-aux
+ (map
+ (lambda(x)
+ (cond
+ (((ntype?? '*) x)
+ (rpt x h
+ (list
+ (cons '% (sxml:attr-list x))
+ (cons '%% (cons `(*PARENT* ,(lambda() h))
+ (sxml:aux-list x))))
+ ))
+ (else x)))
+ (sxml:content elt)))))
+ (set-cdr! h b)
+ h)))
+
+; Lookup an element using its ID
+(define (sxml:lookup id index)
+ (cond
+ ((assoc id index)
+ => cdr)
+ (else #f)))
+
+;==============================================================================
+; Markup generation
+
+;------------------------------------------------------------------------------
+; XML
+
+; Creates the XML markup for attributes.
+(define (sxml:attr->xml attr)
+ (list " " (sxml:ncname attr)
+ "='" (cadr attr) "'"))
+
+; Return a string or a list of strings where all the occurences of
+; characters < > & " ' in a given string are replaced by corresponding
+; character entity references. See also: sxml:string->html
+(define sxml:string->xml
+ (make-char-quotator
+ '((#\< . "<") (#\> . ">") (#\& . "&")
+ (#\" . """) (#\' . "'"))))
+
+; A version of dispatch-node specialized and optimized for SXML->XML
+; transformation.
+(define (sxml:sxml->xml tree)
+ (cond
+ ((nodeset? tree)
+ (map (lambda (a-tree)
+ (sxml:sxml->xml a-tree))
+ tree))
+ ((pair? tree)
+ (let* ((name (sxml:name tree)) ; NS (URI-prefixed) not supported
+ (nm (symbol->string name))
+ (content (sxml:content-raw tree)))
+ `("<" ,nm ,@(map sxml:attr->xml (sxml:attr-list tree))
+ ,@(if (null? content) '("/>")
+ `(">" ,@(sxml:sxml->xml content) "</" ,nm ">")))))
+ ((string? tree) (sxml:string->xml tree)) ; *text*
+ (else (sxml:error "sxml->html - unexpected type of node: " tree))))
+
+
+;------------------------------------------------------------------------------
+; HTML
+
+; Creates the HTML markup for attributes.
+(define (sxml:attr->html attr)
+ (if (equal? "" (cadr attr))
+ (list " " (sxml:ncname attr))
+ (list " " (sxml:ncname attr) "='" (cadr attr) "'")))
+
+
+
+; Given a string, check to make sure it does not contain characters
+; < > & " that require encoding. Return either the original
+; string, or a list of string fragments with special characters
+; replaced by appropriate character entities.
+; Borrowed from Oleg Kiselyov's XML-to-HTML.scm (where its name is
+; string->goodHTML)
+(define sxml:string->html
+ (make-char-quotator
+ '((#\< . "<") (#\> . ">") (#\& . "&") (#\" . """))))
+
+
+; This predicate yields #t for "unterminated" HTML 4.0 tags
+(define (sxml:non-terminated-html-tag? tag)
+ (memq tag
+ '(area base basefont br col frame hr img input isindex link meta
param)))
+
+
+; A version of dispatch-node specialized and optimized for SXML->HTML
+; transformation.
+(define (sxml:sxml->html tree)
+ (cond
+ ((nodeset? tree)
+ (map (lambda (a-tree)
+ (sxml:sxml->html a-tree))
+ tree))
+ ((pair? tree)
+ (let* ((name (sxml:name tree))
+ (nm (symbol->string name))
+ (content (sxml:content-raw tree)))
+ `("<" ,nm ,@(map sxml:attr->html (sxml:attr-list tree))
+ ,@(if (null? content)
+ (if (sxml:non-terminated-html-tag? name) '(">") '("/>"))
+ `(">" ,@(sxml:sxml->html content) "</" ,nm ">")))))
+ ((string? tree) (sxml:string->html tree)) ; *text*
+ (else (sxml:error "sxml->html - unexpected type of node: " tree))))
+
=======================================
--- /dev/null
+++ /trunk/scm/sxpathlib.scm Thu Dec 31 15:47:51 2009
@@ -0,0 +1,536 @@
+;; XML processing in Scheme
+; SXPath -- SXML Query Language
+;
+; $Id: sxpathlib.scm,v 1.1 2003-07-22 11:22:11 shirok Exp $
+;
+; This code is in Public Domain
+; It's based on SXPath by Oleg Kiselyov, and multiple improvements
+; implemented by Dmitry Lizorkin.
+;
+; The list of differences from original SXPath.scm my be found in
changelog.txt
+;
+; Kirill Lisovsky [email protected]
+;
+; * * *
+;
+; SXPath is a query language for SXML, an instance of XML Information
+; set (Infoset) in the form of s-expressions. See SSAX.scm for the
+; definition of SXML and more details. SXPath is also a translation into
+; Scheme of an XML Path Language, XPath:
+; http://www.w3.org/TR/xpath
+; XPath and SXPath describe means of selecting a set of Infoset's items
+; or their properties.
+;
+; To facilitate queries, XPath maps the XML Infoset into an explicit
+; tree, and introduces important notions of a location path and a
+; current, context node. A location path denotes a selection of a set of
+; nodes relative to a context node. Any XPath tree has a distinguished,
+; root node -- which serves as the context node for absolute location
+; paths. Location path is recursively defined as a location step joined
+; with a location path. A location step is a simple query of the
+; database relative to a context node. A step may include expressions
+; that further filter the selected set. Each node in the resulting set
+; is used as a context node for the adjoining location path. The result
+; of the step is a union of the sets returned by the latter location
+; paths.
+;
+; The SXML representation of the XML Infoset (see SSAX.scm) is rather
+; suitable for querying as it is. Bowing to the XPath specification,
+; we will refer to SXML information items as 'Nodes':
+; <Node> ::= <Element> | <attributes-coll> | <attrib>
+; | "text string" | <PI>
+; This production can also be described as
+; <Node> ::= (name . <Nodeset>) | "text string"
+; An (ordered) set of nodes is just a list of the constituent nodes:
+; <Nodeset> ::= (<Node> ...)
+; Nodesets, and Nodes other than text strings are both lists. A
+; <Nodeset> however is either an empty list, or a list whose head is not
+; a symbol. A symbol at the head of a node is either an XML name (in
+; which case it's a tag of an XML element), or an administrative name
+; such as '@'. This uniform list representation makes processing rather
+; simple and elegant, while avoiding confusion. The multi-branch tree
+; structure formed by the mutually-recursive datatypes <Node> and
+; <Nodeset> lends itself well to processing by functional languages.
+;
+; A location path is in fact a composite query over an XPath tree or
+; its branch. A singe step is a combination of a projection, selection
+; or a transitive closure. Multiple steps are combined via join and
+; union operations. This insight allows us to _elegantly_ implement
+; XPath as a sequence of projection and filtering primitives --
+; converters -- joined by _combinators_. Each converter takes a node
+; and returns a nodeset which is the result of the corresponding query
+; relative to that node. A converter can also be called on a set of
+; nodes. In that case it returns a union of the corresponding queries over
+; each node in the set. The union is easily implemented as a list
+; append operation as all nodes in a SXML tree are considered
+; distinct, by XPath conventions. We also preserve the order of the
+; members in the union. Query combinators are high-order functions:
+; they take converter(s) (which is a Node|Nodeset -> Nodeset function)
+; and compose or otherwise combine them. We will be concerned with
+; only relative location paths [XPath]: an absolute location path is a
+; relative path applied to the root node.
+;
+; Similarly to XPath, SXPath defines full and abbreviated notations
+; for location paths. In both cases, the abbreviated notation can be
+; mechanically expanded into the full form by simple rewriting
+; rules. In case of SXPath the corresponding rules are given as
+; comments to a sxpath function, below. The regression test suite at
+; the end of this file shows a representative sample of SXPaths in
+; both notations, juxtaposed with the corresponding XPath
+; expressions. Most of the samples are borrowed literally from the
+; XPath specification, while the others are adjusted for our running
+; example, tree1.
+;
+
+;; Read-only decrement
+(define-macro (mm x) `(- ,x 1))
+
+;=============================================================================
+; Basic converters and applicators
+; A converter is a function
+; type Converter = Node|Nodeset -> Nodeset
+; A converter can also play a role of a predicate: in that case, if a
+; converter, applied to a node or a nodeset, yields a non-empty
+; nodeset, the converter-predicate is deemed satisfied. Throughout
+; this file a nil nodeset is equivalent to #f in denoting a failure.
+
+; Returns #t if given object is a nodeset
+(define (nodeset? x)
+ (or (and (pair? x) (not (symbol? (car x)))) (null? x)))
+
+; If x is a nodeset - returns it as is, otherwise wrap it in a list.
+(define (as-nodeset x)
+ (if (nodeset? x) x (list x)))
+
+;-----------------------------------------------------------------------------
+; Node test
+; The following functions implement 'Node test's as defined in
+; Sec. 2.3 of XPath document. A node test is one of the components of a
+; location step. It is also a converter-predicate in SXPath.
+
+; Predicate which returns #t if <obj> is SXML element, otherwise returns
#f.
+(define (sxml:element? obj)
+ (and (pair? obj)
+ (symbol? (car obj))
+ (not (memq (car obj)
+ ; '(% %% *PI* *COMMENT* *ENTITY* *NAMESPACES*)
+ ; the line above is a workaround for old SXML
+ '(% %% *PI* *COMMENT* *ENTITY*)))))
+
+; The function ntype-names?? takes a list of acceptable node names as a
+; criterion and returns a function, which, when applied to a node,
+; will return #t if the node name is present in criterion list and #f
+; othervise.
+; ntype-names?? :: ListOfNames -> Node -> Boolean
+(define (ntype-names?? crit)
+ (lambda(node)
+ (and (pair? node)
+ (memq (car node) crit))))
+
+; The function ntype?? takes a type criterion and returns
+; a function, which, when applied to a node, will tell if the node
satisfies
+; the test.
+; ntype?? :: Crit -> Node -> Boolean
+;
+; The criterion 'crit' is
+; one of the following symbols:
+; id - tests if the Node has the right name (id)
+; % - tests if the Node is an <attributes-list>
+; * - tests if the Node is an <Element>
+; *text* - tests if the Node is a text node
+; *data* - tests if the Node is a data node
+; (text, number, boolean, etc., but not pair)
+; *PI* - tests if the Node is a PI node
+; *COMMENT* - tests if the Node is a COMMENT node
+; *ENTITY* - tests if the Node is a ENTITY node
+; *any* - #t for any type of Node
+(define (ntype?? crit)
+ (case crit
+ ((*) sxml:element?)
+ ((*any*) (lambda (node) #t))
+ ((*text*) (lambda (node) (string? node)))
+ ((*data*) (lambda (node) (not (pair? node))))
+ (else (lambda (node) (and (pair? node) (eq? crit (car node)))))
+ ))
+
+; This function takes a namespace-id, and returns a predicate
+; Node -> Boolean, which is #t for nodes with this very namespace-id.
+; ns-id is a string
+; (ntype-namespace-id?? #f) will be #t for nodes with non-qualified names.
+(define (ntype-namespace-id?? ns-id)
+ (lambda (node)
+ (and (pair? node)
+ (not (memq (car node)
+ '(% %% *PI* *COMMENT* *ENTITY*)))
+ (let ((nm (symbol->string (car node))))
+ (cond
+ ((string-rindex nm #\:)
+ => (lambda (pos)
+ (and
+ (= pos (string-length ns-id))
+ (string-prefix? ns-id nm))))
+ (else (not ns-id)))))))
+;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+; This function takes a predicate and returns it inverted
+; That is if the given predicate yelds #f or '() the inverted one
+; yields the given node (#t) and vice versa.
+(define (sxml:invert pred)
+ (lambda(node)
+ (case (pred node)
+ ((#f '()) node)
+ (else #f))))
+
+; Curried equivalence converter-predicates
+(define (node-eq? other)
+ (lambda (node)
+ (eq? other node)))
+
+(define (node-equal? other)
+ (lambda (node)
+ (equal? other node)))
+
+; node-pos:: N -> Nodeset -> Nodeset, or
+; node-pos:: N -> Converter
+; Select the N'th element of a Nodeset and return as a singular Nodeset;
+; Return an empty nodeset if the Nth element does not exist.
+; ((node-pos 1) Nodeset) selects the node at the head of the Nodeset,
+; if exists; ((node-pos 2) Nodeset) selects the Node after that, if
+; exists.
+; N can also be a negative number: in that case the node is picked from
+; the tail of the list.
+; ((node-pos -1) Nodeset) selects the last node of a non-empty nodeset;
+; ((node-pos -2) Nodeset) selects the last but one node, if exists.
+(define (node-pos n)
+ (lambda (nodeset)
+ (cond
+ ((not (nodeset? nodeset)) '())
+ ((null? nodeset) nodeset)
+ ((eqv? n 1) (list (car nodeset)))
+ ((negative? n) ((node-pos (+ n 1 (length nodeset))) nodeset))
+ (else
+ (assert (positive? n))
+ ((node-pos (mm n)) (cdr nodeset))))))
+
+; filter:: Converter -> Converter
+; A filter applicator, which introduces a filtering context. The argument
+; converter is considered a predicate, with either #f or nil result meaning
+; failure.
+(define (sxml:filter pred?)
+ (lambda (lst) ; a nodeset or a node (will be converted to a singleton
nset)
+ (let loop ((lst (as-nodeset lst))
+ (res '()))
+ (if (null? lst)
+ (reverse res)
+ (let ((pred-result (pred? (car lst))))
+ (loop (cdr lst)
+ (if (and pred-result (not (null? pred-result)))
+ (cons (car lst) res)
+ res)))))))
+
+; take-until:: Converter -> Converter, or
+; take-until:: Pred -> Node|Nodeset -> Nodeset
+; Given a converter-predicate and a nodeset, apply the predicate to
+; each element of the nodeset, until the predicate yields anything but #f
or
+; nil. Return the elements of the input nodeset that have been processed
+; till that moment (that is, which fail the predicate).
+; take-until is a variation of the filter above: take-until passes
+; elements of an ordered input set till (but not including) the first
+; element that satisfies the predicate.
+; The nodeset returned by ((take-until (not pred)) nset) is a subset --
+; to be more precise, a prefix -- of the nodeset returned by
+; ((filter pred) nset)
+(define (take-until pred?)
+ (lambda (lst) ; a nodeset or a node (will be converted to a singleton
nset)
+ (let loop ((lst (as-nodeset lst)))
+ (if (null? lst) lst
+ (let ((pred-result (pred? (car lst))))
+ (if (and pred-result (not (null? pred-result)))
+ '()
+ (cons (car lst) (loop (cdr lst)))))
+ ))))
+
+; take-after:: Converter -> Converter, or
+; take-after:: Pred -> Node|Nodeset -> Nodeset
+; Given a converter-predicate and a nodeset, apply the predicate to
+; each element of the nodeset, until the predicate yields anything but #f
or
+; nil. Return the elements of the input nodeset that have not been
processed:
+; that is, return the elements of the input nodeset that follow the first
+; element that satisfied the predicate.
+; take-after along with take-until partition an input nodeset into three
+; parts: the first element that satisfies a predicate, all preceding
+; elements and all following elements.
+(define (take-after pred?)
+ (lambda (lst) ; a nodeset or a node (will be converted to a singleton
nset)
+ (let loop ((lst (as-nodeset lst)))
+ (if (null? lst) lst
+ (let ((pred-result (pred? (car lst))))
+ (if (and pred-result (not (null? pred-result)))
+ (cdr lst)
+ (loop (cdr lst))))
+ ))))
+
+; Apply proc to each element of lst and return the list of results.
+; if proc returns a nodeset, splice it into the result
+;
+; From another point of view, map-union is a function Converter->Converter,
+; which places an argument-converter in a joining context.
+(define (map-union proc lst)
+ (if (null? lst) lst
+ (let ((proc-res (proc (car lst))))
+ ((if (nodeset? proc-res) append cons)
+ proc-res (map-union proc (cdr lst))))))
+
+; node-reverse :: Converter, or
+; node-reverse:: Node|Nodeset -> Nodeset
+; Reverses the order of nodes in the nodeset
+; This basic converter is needed to implement a reverse document order
+; (see the XPath Recommendation).
+(define node-reverse
+ (lambda (node-or-nodeset)
+ (if (not (nodeset? node-or-nodeset)) (list node-or-nodeset)
+ (reverse node-or-nodeset))))
+
+; node-trace:: String -> Converter
+; (node-trace title) is an identity converter. In addition it prints out
+; a node or nodeset it is applied to, prefixed with the 'title'.
+; This converter is very useful for debugging.
+(define (node-trace title)
+ (lambda (node-or-nodeset)
+ (cout nl "-->" title " :")
+ (pp node-or-nodeset)
+ node-or-nodeset))
+
+
+;------------------------------------------------------------------------------
+; Converter combinators
+;
+; Combinators are higher-order functions that transmogrify a converter
+; or glue a sequence of converters into a single, non-trivial
+; converter. The goal is to arrive at converters that correspond to
+; XPath location paths.
+;
+; From a different point of view, a combinator is a fixed, named
+; _pattern_ of applying converters. Given below is a complete set of
+; such patterns that together implement XPath location path
+; specification. As it turns out, all these combinators can be built
+; from a small number of basic blocks: regular functional composition,
+; map-union and filter applicators, and the nodeset union.
+
+
+
+; select-kids:: Pred -> Node -> Nodeset
+; Given a Node, return an (ordered) subset its children that satisfy
+; the Pred (a converter, actually)
+; select-kids:: Pred -> Nodeset -> Nodeset
+; The same as above, but select among children of all the nodes in
+; the Nodeset
+;
+; More succinctly, the signature of this function is
+; select-kids:: Converter -> Converter
+(define (select-kids test-pred?)
+ (lambda (node) ; node or node-set
+ (cond
+ ((null? node) node)
+ ((not (pair? node)) '()) ; No children
+ ((symbol? (car node))
+ ((sxml:filter test-pred?) (cdr node))) ; it's a single node
+ (else (map-union (select-kids test-pred?) node)))))
+
+
+; node-self:: Pred -> Node -> Nodeset, or
+; node-self:: Converter -> Converter
+; Similar to select-kids but apply to the Node itself rather
+; than to its children. The resulting Nodeset will contain either one
+; component, or will be empty (if the Node failed the Pred).
+(define node-self sxml:filter)
+
+
+; node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or
+; node-join:: [Converter] -> Converter
+; join the sequence of location steps or paths as described
+; in the title comments above.
+(define (node-join . selectors)
+ (lambda (nodeset) ; Nodeset or node
+ (let loop ((nodeset nodeset) (selectors selectors))
+ (if (null? selectors) nodeset
+ (loop
+ (if (nodeset? nodeset)
+ (map-union (car selectors) nodeset)
+ ((car selectors) nodeset))
+ (cdr selectors))))))
+
+
+; node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or
+; node-reduce:: [Converter] -> Converter
+; A regular functional composition of converters.
+; From a different point of view,
+; ((apply node-reduce converters) nodeset)
+; is equivalent to
+; (foldl apply nodeset converters)
+; i.e., folding, or reducing, a list of converters with the nodeset
+; as a seed.
+(define (node-reduce . converters)
+ (lambda (nodeset) ; Nodeset or node
+ (let loop ((nodeset nodeset) (converters converters))
+ (if (null? converters) nodeset
+ (loop ((car converters) nodeset) (cdr converters))))))
+
+
+; node-or:: [Converter] -> Converter
+; This combinator applies all converters to a given node and
+; produces the union of their results.
+; This combinator corresponds to a union, '|' operation for XPath
+; location paths.
+; (define (node-or . converters)
+; (lambda (node-or-nodeset)
+; (if (null? converters) node-or-nodeset
+; (append
+; ((car converters) node-or-nodeset)
+; ((apply node-or (cdr converters)) node-or-nodeset)))))
+; More optimal implementation follows
+(define (node-or . converters)
+ (lambda (node-or-nodeset)
+ (let loop ((result '()) (converters converters))
+ (if (null? converters) result
+ (loop (append result (or ((car converters) node-or-nodeset) '()))
+ (cdr converters))))))
+
+
+; node-closure:: Converter -> Converter
+; Select all _descendants_ of a node that satisfy a converter-predicate.
+; This combinator is similar to select-kids but applies to
+; grand... children as well.
+; This combinator implements the "descendant::" XPath axis
+; Conceptually, this combinator can be expressed as
+; (define (node-closure f)
+; (node-or
+; (select-kids f)
+; (node-reduce (select-kids (ntype?? '*)) (node-closure f))))
+; This definition, as written, looks somewhat like a fixpoint, and it
+; will run forever. It is obvious however that sooner or later
+; (select-kids (ntype?? '*)) will return an empty nodeset. At
+; this point further iterations will no longer affect the result and
+; can be stopped.
+(define (node-closure test-pred?)
+ (lambda (node) ; Nodeset or node
+ (let loop ((parent node) (result '()))
+ (if (null? parent) result
+ (loop (sxml:child-elements parent)
+ (append result
+ ((select-kids test-pred?) parent)))
+ ))))
+
+;=============================================================================
+; Unified with sxpath-ext and sxml-tools
+
+; According to XPath specification 2.3, this test is true for any
+; XPath node.
+; For SXML auxiliary lists and lists of attributes has to be excluded.
+(define (sxml:node? node)
+ (not (and
+ (pair? node)
+ (memq (car node) '(% %%)))))
+
+; Returns the list of attributes for a given SXML node
+; Empty list is returned if the given node os not an element,
+; or if it has no list of attributes
+(define (sxml:attr-list obj)
+ (if (and (sxml:element? obj)
+ (not (null? (cdr obj)))
+ (pair? (cadr obj))
+ (eq? '% (caadr obj)))
+ (cdadr obj)
+ '()))
+
+; Attribute axis
+(define (sxml:attribute test-pred?)
+ (let ((fltr (sxml:filter test-pred?)))
+ (lambda (node)
+ (fltr
+ (apply append
+ (map
+ sxml:attr-list
+ (as-nodeset node)))))))
+
+; Child axis
+; This function is similar to 'select-kids', but it returns an empty
+; child-list for PI, Comment and Entity nodes
+(define (sxml:child test-pred?)
+ (lambda (node) ; node or node-set
+ (cond
+ ((null? node) node)
+ ((not (pair? node)) '()) ; No children
+ ((memq (car node) '(*PI* *COMMENT* *ENTITY*)) ; PI, Comment or
Entity
+ '()) ; No children
+ ((symbol? (car node)) ; it's a single node
+ ((sxml:filter test-pred?) (cdr node)))
+ (else (map-union (sxml:child test-pred?) node)))))
+
+; Parent axis
+; Given a predicate, it returns a function
+; RootNode -> Converter
+; which which yields a
+; node -> parent
+; converter then applied to a rootnode.
+; Thus, such a converter may be constructed using
+; ((sxml:parent test-pred) rootnode)
+; and returns a parent of a node it is applied to.
+; If applied to a nodeset, it returns the
+; list of parents of nodes in the nodeset. The rootnode does not have
+; to be the root node of the whole SXML tree -- it may be a root node
+; of a branch of interest.
+; The parent:: axis can be used with any SXML node.
+(define (sxml:parent test-pred?)
+ (lambda (root-node) ; node or nodeset
+ (lambda (node) ; node or nodeset
+ (if (nodeset? node)
+ (map-union ((sxml:parent test-pred?) root-node) node)
+ (let rpt ((pairs
+ (apply append
+ (map
+ (lambda (root-n)
+ (map
+ (lambda (arg) (cons arg root-n))
+ (append
+ (sxml:attr-list root-n)
+ (sxml:child-nodes root-n))))
+ (as-nodeset root-node)))
+ ))
+ (if (null? pairs)
+ '()
+ (let ((pair (car pairs)))
+ (if (eq? (car pair) node)
+ ((sxml:filter test-pred?) (list (cdr pair)))
+ (rpt (append
+ (map
+ (lambda (arg) (cons arg (car pair)))
+ (append
+ (sxml:attr-list (car pair))
+ (sxml:child-nodes (car pair))))
+ (cdr pairs)
+ ))))))))))
+
+
+;=============================================================================
+; Popular short cuts
+
+; node-parent:: RootNode -> Converter
+; (node-parent rootnode) yields a converter that returns a parent of a
+; node it is applied to. If applied to a nodeset, it returns the list
+; of parents of nodes in the nodeset.
+; Given the notation of Philip Wadler's paper on semantics of XSLT,
+; parent(x) = { y | y=subnode*(root), x=subnode(y) }
+; Therefore, node-parent is not the fundamental converter: it can be
+; expressed through the existing ones. Yet node-parent is a rather
+; convenient converter. It corresponds to a parent:: axis of SXPath.
+;
+; Please note: this function is provided for backward compatibility
+; with SXPath/SXPathlib ver. 3.5.x.x and earlier.
+; Now it's a particular case of 'sxml:parent' application:
+(define node-parent (sxml:parent (ntype?? '*any*)))
+
+(define sxml:child-nodes (sxml:child sxml:node?))
+
+(define sxml:child-elements (select-kids sxml:element?))
+
=======================================
--- /trunk/scm/Makefile.am Thu Dec 31 15:44:40 2009
+++ /trunk/scm/Makefile.am Thu Dec 31 15:47:51 2009
@@ -51,7 +51,8 @@
sqlite3.scm \
lolevel.scm \
input-parse.scm match.scm \
- http-client.scm http-server.scm
+ http-client.scm http-server.scm \
+ sxml-tools.scm sxpathlib.scm
ETAGS_ARGS=$(SCM_FILES) $(GENERATED_SCM_FILES)
