<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># $Id: Step.pm,v 1.35 2001/04/01 16:56:40 matt Exp $

package XML::XPathEngine::Step;
use XML::XPathEngine;
use strict;

# the beginnings of using XS for this file...
# require DynaLoader;
# use vars qw/$VERSION @ISA/;
# $VERSION = '1.0';
# @ISA = qw(DynaLoader);
# 
# bootstrap XML::XPathEngine::Step $VERSION;

sub test_qname () { 0; } # Full name
sub test_ncwild () { 1; } # NCName:*
sub test_any () { 2; } # *

sub test_attr_qname () { 3; } # @ns:attrib
sub test_attr_ncwild () { 4; } # @nc:*
sub test_attr_any () { 5; } # @*

sub test_nt_comment () { 6; } # comment()
sub test_nt_text () { 7; } # text()
sub test_nt_pi () { 8; } # processing-instruction()
sub test_nt_node () { 9; } # node()

sub new {
    my $class = shift;
    my ($pp, $axis, $test, $literal) = @_;
    my $axis_method = "axis_$axis";
    $axis_method =~ tr/-/_/;
    my $self = {
        pp =&gt; $pp, # the XML::XPathEngine class
        axis =&gt; $axis,
        axis_method =&gt; $axis_method,
        test =&gt; $test,
        literal =&gt; $literal,
        predicates =&gt; [],
        };
    bless $self, $class;
}

sub as_string {
    my $self = shift;
    my $string = $self-&gt;{axis} . "::";

    my $test = $self-&gt;{test};
        
    if ($test == test_nt_pi) {
        $string .= 'processing-instruction(';
        if ($self-&gt;{literal}-&gt;value) {
            $string .= $self-&gt;{literal}-&gt;as_string;
        }
        $string .= ")";
    }
    elsif ($test == test_nt_comment) {
        $string .= 'comment()';
    }
    elsif ($test == test_nt_text) {
        $string .= 'text()';
    }
    elsif ($test == test_nt_node) {
        $string .= 'node()';
    }
    elsif ($test == test_ncwild || $test == test_attr_ncwild) {
        $string .= $self-&gt;{literal} . ':*';
    }
    else {
        $string .= $self-&gt;{literal};
    }
    
    foreach (@{$self-&gt;{predicates}}) {
        next unless defined $_;
        $string .= "[" . $_-&gt;as_string . "]";
    }
    return $string;
}

sub as_xml {
    my $self = shift;
    my $string = "&lt;Step&gt;\n";
    $string .= "&lt;Axis&gt;" . $self-&gt;{axis} . "&lt;/Axis&gt;\n";
    my $test = $self-&gt;{test};
    
    $string .= "&lt;Test&gt;";
    
    if ($test == test_nt_pi) {
        $string .= '&lt;processing-instruction';
        if ($self-&gt;{literal}-&gt;value) {
            $string .= '&gt;';
            $string .= $self-&gt;{literal}-&gt;as_string;
            $string .= '&lt;/processing-instruction&gt;';
        }
        else {
            $string .= '/&gt;';
        }
    }
    elsif ($test == test_nt_comment) {
        $string .= '&lt;comment/&gt;';
    }
    elsif ($test == test_nt_text) {
        $string .= '&lt;text/&gt;';
    }
    elsif ($test == test_nt_node) {
        $string .= '&lt;node/&gt;';
    }
    elsif ($test == test_ncwild || $test == test_attr_ncwild) {
        $string .= '&lt;namespace-prefix&gt;' . $self-&gt;{literal} . '&lt;/namespace-prefix&gt;';
    }
    else {
        $string .= '&lt;nametest&gt;' . $self-&gt;{literal} . '&lt;/nametest&gt;';
    }
    
    $string .= "&lt;/Test&gt;\n";
    
    foreach (@{$self-&gt;{predicates}}) {
        next unless defined $_;
        $string .= "&lt;Predicate&gt;\n" . $_-&gt;as_xml() . "&lt;/Predicate&gt;\n";
    }
    
    $string .= "&lt;/Step&gt;\n";
    
    return $string;
}

sub evaluate {
    my $self = shift;
    my $from = shift; # context nodeset

    if( $from &amp;&amp; !$from-&gt;isa( 'XML::XPathEngine::NodeSet'))
      { 
        my $from_nodeset= XML::XPathEngine::NodeSet-&gt;new();
        $from_nodeset-&gt;push( $from); 
        $from= $from_nodeset;
      }
      #warn "Step::evaluate called with ", $from-&gt;size, " length nodeset\n";
    
    my $saved_context = $self-&gt;{pp}-&gt;_get_context_set;
    my $saved_pos = $self-&gt;{pp}-&gt;_get_context_pos;
    $self-&gt;{pp}-&gt;_set_context_set($from);
    
    my $initial_nodeset = XML::XPathEngine::NodeSet-&gt;new();
    
    # See spec section 2.1, paragraphs 3,4,5:
    # The node-set selected by the location step is the node-set
    # that results from generating an initial node set from the
    # axis and node-test, and then filtering that node-set by
    # each of the predicates in turn.
    
    # Make each node in the nodeset be the context node, one by one
    for(my $i = 1; $i &lt;= $from-&gt;size; $i++) {
        $self-&gt;{pp}-&gt;_set_context_pos($i);
        $initial_nodeset-&gt;append($self-&gt;evaluate_node($from-&gt;get_node($i)));
    }
    
#    warn "Step::evaluate initial nodeset size: ", $initial_nodeset-&gt;size, "\n";
    
    $self-&gt;{pp}-&gt;_set_context_set($saved_context);
    $self-&gt;{pp}-&gt;_set_context_pos($saved_pos);

    return $initial_nodeset;
}

# Evaluate the step against a particular node
sub evaluate_node {
    my $self = shift;
    my $context = shift;
    
#    warn "Evaluate node: $self-&gt;{axis}\n";
    
#    warn "Node: ", $context-&gt;[node_name], "\n";
    
    my $method = $self-&gt;{axis_method};
    
    my $results = XML::XPathEngine::NodeSet-&gt;new();
    no strict 'refs';
    eval {
        $method-&gt;($self, $context, $results);
    };
    if ($@) {
        die "axis $method not implemented [$@]\n";
    }
    
#    warn("results: ", join('&gt;&lt;', map {$_-&gt;string_value} @$results), "\n");
    # filter initial nodeset by each predicate
    foreach my $predicate (@{$self-&gt;{predicates}}) {
        $results = $self-&gt;filter_by_predicate($results, $predicate);
    }
    
    return $results;
}

sub axis_ancestor {
    my $self = shift;
    my ($context, $results) = @_;
    
    my $parent = $context-&gt;getParentNode;
        
    START:
    return $results unless $parent;
    if (node_test($self, $parent)) {
        $results-&gt;push($parent);
    }
    $parent = $parent-&gt;getParentNode;
    goto START;
}

sub axis_ancestor_or_self {
    my $self = shift;
    my ($context, $results) = @_;
    
    START:
    return $results unless $context;
    if (node_test($self, $context)) {
        $results-&gt;push($context);
    }
    $context = $context-&gt;getParentNode;
    goto START;
}

sub axis_attribute {
    my $self = shift;
    my ($context, $results) = @_;
    
    foreach my $attrib (@{$context-&gt;getAttributes}) {
        if ($self-&gt;test_attribute($attrib)) {
            $results-&gt;push($attrib);
        }
    }
}

sub axis_child {
    my $self = shift;
    my ($context, $results) = @_;
    
    foreach my $node (@{$context-&gt;getChildNodes}) {
        if (node_test($self, $node)) {
            $results-&gt;push($node);
        }
    }
}

sub axis_descendant {
    my $self = shift;
    my ($context, $results) = @_;

    my @stack = $context-&gt;getChildNodes;

    while (@stack) {
        my $node = shift @stack;
        if (node_test($self, $node)) {
            $results-&gt;push($node);
        }
        unshift @stack, $node-&gt;getChildNodes;
    }
}

sub axis_descendant_or_self {
    my $self = shift;
    my ($context, $results) = @_;
    
    my @stack = ($context);

     while (@stack) {
        my $node = shift @stack;
         if (node_test($self, $node)) {
            $results-&gt;push($node);
         }
        #warn "node is a ", ref( $node);
        unshift @stack, $node-&gt;getChildNodes;
     }
}

sub axis_following 
  { my $self = shift;
    my ($context, $results) = @_;

    my $elt= $context-&gt;getNextSibling || _next_sibling_of_an_ancestor_of( $context);
    while( $elt)
      { if (node_test($self, $elt)) { $results-&gt;push( $elt); }
        $elt= $elt-&gt;getFirstChild || $elt-&gt;getNextSibling || _next_sibling_of_an_ancestor_of( $elt);
      }
  }

sub _next_sibling_of_an_ancestor_of
  { my $elt= shift;
    $elt= $elt-&gt;getParentNode || return;
    my $next_elt;
    while( !($next_elt= $elt-&gt;getNextSibling))
      { $elt= $elt-&gt;getParentNode;  
        return unless( $elt &amp;&amp; $elt-&gt;can( 'getNextSibling')); 
      }
    return $next_elt;
  }


sub axis_following_sibling {
    my $self = shift;
    my ($context, $results) = @_;

    #warn "in axis_following_sibling";
    while ($context = $context-&gt;getNextSibling) {
        if (node_test($self, $context)) {
            $results-&gt;push($context);
        }
    }
}

sub axis_namespace {
    my $self = shift;
    my ($context, $results) = @_;
    
    return $results unless $context-&gt;isElementNode;
    foreach my $ns (@{$context-&gt;getNamespaces}) {
        if ($self-&gt;test_namespace($ns)) {
            $results-&gt;push($ns);
        }
    }
}

sub axis_parent {
    my $self = shift;
    my ($context, $results) = @_;
    
    my $parent = $context-&gt;getParentNode;
    return $results unless $parent;
    if (node_test($self, $parent)) {
        $results-&gt;push($parent);
    }
}

sub axis_preceding 
  { my $self = shift;
    my ($context, $results) = @_;

    my $elt= $context-&gt;getPreviousSibling || _previous_sibling_of_an_ancestor_of( $context);
    while( $elt)
      { if (node_test($self, $elt)) { $results-&gt;push( $elt); }
        $elt= $elt-&gt;getLastChild || $elt-&gt;getPreviousSibling || _previous_sibling_of_an_ancestor_of( $elt);
      }
  }

sub _previous_sibling_of_an_ancestor_of
  { my $elt= shift;
    $elt= $elt-&gt;getParentNode || return;
    my $next_elt;
    while( !($next_elt= $elt-&gt;getPreviousSibling))
      { $elt= $elt-&gt;getParentNode;  
        return unless $elt-&gt;getParentNode; # so we don't have to write a getPreviousSibling 
      }
    return $next_elt;
  }


sub axis_preceding_sibling {
    my $self = shift;
    my ($context, $results) = @_;
    
    while ($context = $context-&gt;getPreviousSibling) {
        if (node_test($self, $context)) {
            $results-&gt;push($context);
        }
    }
}

sub axis_self {
    my $self = shift;
    my ($context, $results) = @_;
    
    if (node_test($self, $context)) {
        $results-&gt;push($context);
    }
}
    
sub node_test {
    my $self = shift;
    my $node = shift;
    
    # if node passes test, return true
    
    my $test = $self-&gt;{test};

    return 1 if $test == test_nt_node;
        
    if ($test == test_any) {
        return 1 if $node-&gt;isElementNode &amp;&amp; defined $node-&gt;getName;
    }
        
    local $^W;

    if ($test == test_ncwild) {
        return unless $node-&gt;isElementNode;
        return _match_ns( $self, $node);
    }
    elsif ($test == test_qname) {
        return unless $node-&gt;isElementNode;
        if ($self-&gt;{literal} =~ /:/ || $self-&gt;{pp}-&gt;{strict_namespaces}) {
            my ($prefix, $name) = _name2prefix_and_local_name( $self-&gt;{literal});
            return 1 if( ($name eq $node-&gt;getLocalName) &amp;&amp; _match_ns( $self, $node));
            }
        else {
            return 1 if $node-&gt;getName eq $self-&gt;{literal};
        }
    }
    elsif ($test == test_nt_text) {
        return 1 if $node-&gt;isTextNode;
    }
    elsif ($test == test_nt_comment) {
        return 1 if $node-&gt;isCommentNode;
    }
     elsif ($test == test_nt_pi &amp;&amp; !$self-&gt;{literal}) {
         return 1 if $node-&gt;isPINode;
     }
    elsif ($test == test_nt_pi) {
        return unless $node-&gt;isPINode;
        if (my $val = $self-&gt;{literal}-&gt;value) {
            return 1 if $node-&gt;getTarget eq $val;
        }
        else {
            return 1;
        }
    }
    
    return; # fallthrough returns false
}

sub _name2prefix_and_local_name
  { my $name= shift; 
    return $name =~ /:/ ? split(':', $name, 2) : ( '', $name);
  }
sub _name2prefix
  { my $name= shift;
    if( $name=~ m{^(.*?):}) { return $1; } else { return ''; } 
  }

sub _match_ns
  { my( $self, $node)= @_;
    my $pp= $self-&gt;{pp};
    my $prefix= _name2prefix( $self-&gt;{literal});
    my( $match_ns, $node_ns);
    if( $pp-&gt;{uses_namespaces} || $pp-&gt;{strict_namespaces})
      { $match_ns = $pp-&gt;get_namespace($prefix);
        if( $match_ns || $pp-&gt;{strict_namespaces})
          { $node_ns= $node-&gt;getNamespace-&gt;getValue; }
        else
          { # non-standard behaviour: if the query prefix is not declared
            # compare the 2 prefixes
            $match_ns = $prefix;
            $node_ns  = _name2prefix( $node-&gt;getName);
          }
      }
    else
      { $match_ns = $prefix;
        $node_ns  = _name2prefix( $node-&gt;getName);
      }

    return $match_ns eq $node_ns;
  }


sub test_attribute {
    my $self = shift;
    my $node = shift;
    
    my $test = $self-&gt;{test};
    
    return 1 if ($test == test_attr_any) || ($test == test_nt_node);
        
    if ($test == test_attr_ncwild) {
        return 1 if _match_ns( $self, $node);
    }
    elsif ($test == test_attr_qname) {
        if ($self-&gt;{literal} =~ /:/) {
            my ($prefix, $name) = _name2prefix_and_local_name( $self-&gt;{literal});

            return 1 if ( ($name eq $node-&gt;getLocalName) &amp;&amp; ( _match_ns( $self, $node)) );
            }
        else {
            return 1 if $node-&gt;getName eq $self-&gt;{literal};
        }
    }
    
    return; # fallthrough returns false
}

sub test_namespace {
    my $self = shift;
    my $node = shift;
    
    # Not sure if this is correct. The spec seems very unclear on what
    # constitutes a namespace test... bah!
    
    my $test = $self-&gt;{test};
    
    return 1 if $test == test_any; # True for all nodes of principal type
    
    if ($test == test_any) {
        return 1;
    }
    elsif ($self-&gt;{literal} eq $node-&gt;getExpanded) {
        return 1;
    }
    
    return;
}

sub filter_by_predicate {
    my $self = shift;
    my ($nodeset, $predicate) = @_;
    
    # See spec section 2.4, paragraphs 2 &amp; 3:
    # For each node in the node-set to be filtered, the predicate Expr
    # is evaluated with that node as the context node, with the number
    # of nodes in the node set as the context size, and with the
    # proximity position of the node in the node set with respect to
    # the axis as the context position.
    
    if (!ref($nodeset)) { # use ref because nodeset has a bool context
        die "No nodeset!!!";
    }
    
#    warn "Filter by predicate: $predicate\n";
    
    my $newset = XML::XPathEngine::NodeSet-&gt;new();

    for(my $i = 1; $i &lt;= $nodeset-&gt;size; $i++) {
        # set context set each time 'cos a loc-path in the expr could change it
        $self-&gt;{pp}-&gt;_set_context_set($nodeset);
        $self-&gt;{pp}-&gt;_set_context_pos($i);
        my $result = $predicate-&gt;evaluate($nodeset-&gt;get_node($i));
        if ($result-&gt;isa('XML::XPathEngine::Boolean')) {
            if ($result-&gt;value) {
                $newset-&gt;push($nodeset-&gt;get_node($i));
            }
        }
        elsif ($result-&gt;isa('XML::XPathEngine::Number')) {
            if ($result-&gt;value == $i) {
                $newset-&gt;push($nodeset-&gt;get_node($i)); last;
            }
        }
        else {
            if ($result-&gt;to_boolean-&gt;value) {
                $newset-&gt;push($nodeset-&gt;get_node($i));
            }
        }
    }
    
    return $newset;
}

1;
</pre></body></html>