From 62acea7a298b18e9a34389435c0734db596ede1f Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 28 Sep 2003 04:12:54 +0000 Subject: [PATCH] Initial draft. This design has some bugs, so I'm checkpointing prior to redesign. --- v7/src/xml/xpath.scm | 402 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 402 insertions(+) create mode 100644 v7/src/xml/xpath.scm diff --git a/v7/src/xml/xpath.scm b/v7/src/xml/xpath.scm new file mode 100644 index 000000000..aca498aba --- /dev/null +++ b/v7/src/xml/xpath.scm @@ -0,0 +1,402 @@ +#| -*-Scheme-*- + +$Id: xpath.scm,v 1.1 2003/09/28 04:12:54 cph Exp $ + +Copyright 2003 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; XPath implementation + +(declare (usual-integrations)) + +(define-generic nodify-item (item parent index)) +(define-generic node-eq? (n1 n2)) +(define-generic node-item (node)) +(define-generic parent-node (node)) +(define-generic node-child-items (node)) +(define-generic walk-children+ (node index p a)) +(define-generic walk-children- (node index p a)) +(define-generic parent-index (node)) +(define-generic node-name (node)) +(define-generic node-string (node)) + +(define-class () + (item accessor node-item)) + +(define-method parent-node ((node )) + node + #f) + +(define-method node-child-items ((node )) + node + '()) + +(define-generic walk-children+ ((node ) index p a) + node index p a + unspecific) + +(define-generic walk-children- ((node ) index p a) + node index p a + unspecific) + +(define-method node-name ((node )) + node + #f) + +(define-class () + (parent accessor parent-node)) + +(define (parented-node-nodifier item-class node-class) + (let ((constructor (instance-constructor node-class '(item parent)))) + (define-method nodify-item ((item item-class) parent index) + index + (constructor item parent)))) + +(define-class ()) + +(define-method walk-children+ ((node ) index p a) + (let loop ((items (node-child-items node)) (i 0) (a a)) + (if (pair? items) + (loop (cdr items) + (fix:+ i 1) + (if (fix:> i index) + (p (nodify-item (car items) node i) a) + a)) + a))) + +(define-method walk-children- ((node ) index p a) + (let loop ((items (node-child-items node)) (i 0)) + (if (fix:< i index) + (p (nodify-item (car items) node i) + (loop (cdr items) (fix:+ i 1))) + a))) + +(define-class () + (index accessor parent-index)) + +(define (content-node-nodifier item-class node-class) + (let ((constructor (instance-constructor node-class '(item parent index)))) + (define-method nodify-item ((item item-class) parent index) + (constructor item parent index)))) + +(define-method node-eq? ((n1 ) (n2 )) + (and (eq? (instance-class n1) (instance-class n2)) + (eq? (node-item n1) (node-item n2)))) + +(define-method node-eq? ((n1 ) (n2 )) + (and (call-next-method n1 n2) + (node-eq? (parent-node n1) (parent-node n2)))) + +(define-method node-eq? ((n1 ) (n2 )) + (and (call-next-method n1 n2) + (fix:= (parent-index n1) (parent-index n2)))) + +(define-class () + (child-items accessor node-child-items)) + +(define make-root-node + (let ((c (instance-constructor '(item child-items)))) + (lambda (doc) + (c doc + (let ((p + (lambda (item) + (or (xml-comment? item) + (xml-processing-instructions? item))))) + (append! (keep-matching-items (xml-document-misc-1 doc) p) + (keep-matching-items (xml-document-misc-2 doc) p) + (list (xml-document-root doc)) + (keep-matching-items (xml-document-misc-3 doc) p))))))) + +(define-method node-string ((node )) + (node-string + (let ((doc (node-item node))) + (nodify-item (xml-document-root doc) + node + (fix:+ (length (xml-document-misc-1 doc)) + (length (xml-document-misc-2 doc))))))) + + +(define-class ( )) + +(content-node-nodifier ) + +(define-method node-name ((node )) + (xml-element-name (node-item node))) + +(define-method node-child-items ((node )) + (xml-element-content (node-item node))) + +(define-method node-string ((node )) + (call-with-output-string + (lambda (port) + (let loop ((elt (node-item node))) + (for-each (lambda (item) + (cond ((string? item) (write-string item port)) + ((xml-element? item) (loop item)))) + (xml-element-contents elt)))))) + +(define-class ()) +(define-class ()) + +(define make-attribute-node + (instance-constructor '(item parent))) + +(define make-namespace-node + (instance-constructor '(item parent))) + +(define-method node-name ((node )) + (xml-attribute-name (node-item node))) + +(define-method node-string ((node )) + (xml-attribute-value (node-item node))) + +(define-method node-name ((node )) + (let ((name (xml-attribute-name (node-item node)))) + (if (xml-name-qname=? name 'xmlns) + (null-xml-name-prefix) + (xml-name-local name)))) + + +(define-class ()) + +(content-node-nodifier + ) + +(define-method node-name ((node )) + (xml-processing-instructions-name (node-item node))) + +(define-method node-string ((node )) + (xml-processing-instructions-text (node-item node))) + + +(define-class ()) + +(content-node-nodifier ) + +(define-method node-string ((node )) + (xml-comment-text (node-item node))) + + +(define-class ()) + +(content-node-nodifier ) + +(define-method node-string ((node )) + (node-item node)) + +(define (node-n-children node) + (length (node-child-items node))) + +(define ((ped node-test size env) node pos) + (node-test node pos size env) + (fix:+ pos 1)) + +(define ((axis:self node-test) node env) + (node-test node 1 (delay 1) env)) + +(define ((axis:child node-test) node env) + (walk-children+ node + -1 + (ped node-test + (delay (node-n-children parent)) + env) + 1)) + +(define ((axis:following-sibling node-test) node env) + (let ((parent (parent-node node)) + (index (parent-index node))) + (walk-children+ parent + index + (ped node-test + (delay (fix:- (node-n-children parent) + (fix:+ index 1))) + env) + 1))) + +(define ((axis:preceding-sibling node-test) node env) + (let ((parent (parent-node node)) + (index (parent-index node))) + (walk-children- parent + index + (ped node-test (delay index) env) + 1))) + +(define ((axis:descendant node-test) node env) + (let ((p (ped node-test (delay (count-descendants node 0)) env))) + (let loop ((node node) (pos 1)) + (walk-children+ node + -1 + (lambda (node pos) + (loop node (p node pos))) + pos)))) + +(define ((axis:descendant-or-self node-test) node env) + (let ((p (ped node-test (delay (count-descendants node 1)) env))) + (let loop ((node node) (pos 1)) + (walk-children+ node + -1 + loop + (p node pos))))) + +(define (count-descendants node offset) + (let loop ((node node) (size offset)) + (walk-children+ node + -1 + (lambda (node size) + (loop node (fix:+ size 1))) + size))) + +(define ((axis:following node-test) node env) + ) + +(define ((axis:preceding node-test) node env) + ) + +(define ((axis:parent node-test) node env) + (let ((parent (node-parent node))) + (if parent + (node-test parent 1 (delay 1) env)))) + +(define ((axis:ancestor node-test) node env) + (let ((size (delay (count-ancestors node 0)))) + (let loop ((node node) (pos 1)) + (let ((parent (node-parent node))) + (if parent + (begin + (node-test parent pos size env) + (loop parent (fix:+ pos 1)))))))) + +(define ((axis:ancestor-or-self node-test) node env) + (let ((size (delay (count-ancestors node 1)))) + (let loop ((node node) (pos 1)) + (node-test node pos size env) + (let ((parent (node-parent node))) + (if parent + (loop parent (fix:+ pos 1))))))) + +(define (count-ancestors node offset) + (let loop ((node node) (size offset)) + (let ((parent (node-parent node))) + (if parent + (loop parent (fix:+ size 1)) + size)))) + +(define ((axis:attribute node-test) node env) + (if (element-node? node) + (let ((attrs (xml-element-attributes node))) + (let ((p (ped node-test (delay (count-attributes attrs)) env))) + (do ((attrs attrs (cdr attrs)) + (pos 1 + (let ((attr (car attrs))) + (if (xml-attribute-namespace-decl? attr) + pos + (p (make-attribute-node attr node) pos))))) + ((not (pair? attrs)))))))) + +(define (count-attributes attrs) + (do ((attrs attrs (cdr attrs)) + (n 0 + (if (xml-attribute-namespace-decl? (car attrs)) + n + (fix:+ n 1)))) + ((not (pair? attrs)) n))) + +(define ((axis:namespace node-test) node env) + (if (element-node? node) + (let ((p (ped node-test (delay (count-namespace-decls node)) env)) + (seen (make-namespace-hash-table))) + (do ((node node (parent-node node)) + (pos 1 + (do ((attrs (xml-element-attributes (node-item node)) + (cdr attrs)) + (pos pos + (let ((attr (car attrs))) + (if (namespace-unseen? seen attr) + (p (make-namespace-node attr node) pos) + pos)))) + ((not (pair? attrs)) pos)))) + ((not (xml-element? node))))))) + +(define (count-namespace-decls node) + (let ((seen (make-namespace-hash-table))) + (do ((node node (parent-node node)) + (n 0 + (do ((attrs (xml-element-attributes (node-item node)) (cdr attrs)) + (n n + (if (namespace-unseen? seen (car attrs)) + (fix:+ n 1) + n))) + ((not (pair? attrs)))))) + ((not (element-node? node)) n)))) + +(define (make-namespace-hash-table) + (make-eq-hash-table)) + +(define (namespace-unseen? table attr) + (if (xml-attribute-namespace-decl? attr) + (let ((qname (xml-name-qname (xml-attribute-name attr)))) + (if (hash-table/get table qname #f) + #f + (begin + (hash-table/put! table qname #t) + #t))) + #f)) + +(define (node-test:* type predicate) + (case type + ((attribute namespace) + predicate) + ((element) + (lambda (node pos size env) + (if (element-node? node) + (predicate node pos size env)))) + (else + (error:bad-range-argument type 'NODE-TEST:*)))) + +(define (node-test:name qname) + (lambda (type predicate) + (case type + ((attribute) + (lambda (node pos size env) + (if (xml-name=? (node-name node) (expand-name qname node)) + (predicate node pos size env)))) + ((namespace) + (lambda (node pos size env) + (if (xml-name=? (node-name node) qname) + (predicate node pos size env)))) + ((element) + (lambda (node pos size env) + (if (and (element-node? node) + (xml-name=? (node-name node) (expand-name qname node))) + (predicate node pos size env)))) + (else + (error:bad-range-argument type 'NODE-TEST:NAME))))) + +(define (expand-name qname node) + (let ((prefix (xml-name-prefix qname))) + (if (null-xml-name-prefix? prefix) + qname + (make-xml-name qname + (let loop ((node node)) + (if (element-node? node) + (or (xml-element-namespace-iri (node-item node) + prefix) + (loop (parent-node node))))))))) -- 2.25.1