[Summary view] [Print] [Text view]

   1  # $Id: Step.pm,v 1.35 2001/04/01 16:56:40 matt Exp $
   2  
   3  package XML::XPath::Step;
   4  use XML::XPath::Parser;
   5  use XML::XPath::Node;
   6  use strict;
   7  
   8  # the beginnings of using XS for this file...
   9  # require DynaLoader;
  10  # use vars qw/$VERSION @ISA/;
  11  # $VERSION = '1.0';
  12  # @ISA = qw(DynaLoader);
  13  # 
  14  # bootstrap XML::XPath::Step $VERSION;
  15  
  16  sub test_qname () { 0; } # Full name
  17  sub test_ncwild () { 1; } # NCName:*
  18  sub test_any () { 2; } # *
  19  
  20  sub test_attr_qname () { 3; } # @ns:attrib
  21  sub test_attr_ncwild () { 4; } # @nc:*
  22  sub test_attr_any () { 5; } # @*
  23  
  24  sub test_nt_comment () { 6; } # comment()
  25  sub test_nt_text () { 7; } # text()
  26  sub test_nt_pi () { 8; } # processing-instruction()
  27  sub test_nt_node () { 9; } # node()
  28  
  29  sub new {
  30      my $class = shift;
  31      my ($pp, $axis, $test, $literal) = @_;
  32      my $axis_method = "axis_$axis";
  33      $axis_method =~ tr/-/_/;
  34      my $self = {
  35          pp => $pp, # the XML::XPath::Parser class
  36          axis => $axis,
  37          axis_method => $axis_method,
  38          test => $test,
  39          literal => $literal,
  40          predicates => [],
  41          };
  42      bless $self, $class;
  43  }
  44  
  45  sub as_string {
  46      my $self = shift;
  47      my $string = $self->{axis} . "::";
  48  
  49      my $test = $self->{test};
  50          
  51      if ($test == test_nt_pi) {
  52          $string .= 'processing-instruction(';
  53          if ($self->{literal}->value) {
  54              $string .= $self->{literal}->as_string;
  55          }
  56          $string .= ")";
  57      }
  58      elsif ($test == test_nt_comment) {
  59          $string .= 'comment()';
  60      }
  61      elsif ($test == test_nt_text) {
  62          $string .= 'text()';
  63      }
  64      elsif ($test == test_nt_node) {
  65          $string .= 'node()';
  66      }
  67      elsif ($test == test_ncwild || $test == test_attr_ncwild) {
  68          $string .= $self->{literal} . ':*';
  69      }
  70      else {
  71          $string .= $self->{literal};
  72      }
  73      
  74      foreach (@{$self->{predicates}}) {
  75          next unless defined $_;
  76          $string .= "[" . $_->as_string . "]";
  77      }
  78      return $string;
  79  }
  80  
  81  sub as_xml {
  82      my $self = shift;
  83      my $string = "<Step>\n";
  84      $string .= "<Axis>" . $self->{axis} . "</Axis>\n";
  85      my $test = $self->{test};
  86      
  87      $string .= "<Test>";
  88      
  89      if ($test == test_nt_pi) {
  90          $string .= '<processing-instruction';
  91          if ($self->{literal}->value) {
  92              $string .= '>';
  93              $string .= $self->{literal}->as_string;
  94              $string .= '</processing-instruction>';
  95          }
  96          else {
  97              $string .= '/>';
  98          }
  99      }
 100      elsif ($test == test_nt_comment) {
 101          $string .= '<comment/>';
 102      }
 103      elsif ($test == test_nt_text) {
 104          $string .= '<text/>';
 105      }
 106      elsif ($test == test_nt_node) {
 107          $string .= '<node/>';
 108      }
 109      elsif ($test == test_ncwild || $test == test_attr_ncwild) {
 110          $string .= '<namespace-prefix>' . $self->{literal} . '</namespace-prefix>';
 111      }
 112      else {
 113          $string .= '<nametest>' . $self->{literal} . '</nametest>';
 114      }
 115      
 116      $string .= "</Test>\n";
 117      
 118      foreach (@{$self->{predicates}}) {
 119          next unless defined $_;
 120          $string .= "<Predicate>\n" . $_->as_xml() . "</Predicate>\n";
 121      }
 122      
 123      $string .= "</Step>\n";
 124      
 125      return $string;
 126  }
 127  
 128  sub evaluate {
 129      my $self = shift;
 130      my $from = shift; # context nodeset
 131      
 132  #    warn "Step::evaluate called with ", $from->size, " length nodeset\n";
 133      
 134      $self->{pp}->set_context_set($from);
 135      
 136      my $initial_nodeset = XML::XPath::NodeSet->new();
 137      
 138      # See spec section 2.1, paragraphs 3,4,5:
 139      # The node-set selected by the location step is the node-set
 140      # that results from generating an initial node set from the
 141      # axis and node-test, and then filtering that node-set by
 142      # each of the predicates in turn.
 143      
 144      # Make each node in the nodeset be the context node, one by one
 145      for(my $i = 1; $i <= $from->size; $i++) {
 146          $self->{pp}->set_context_pos($i);
 147          $initial_nodeset->append($self->evaluate_node($from->get_node($i)));
 148      }
 149      
 150  #    warn "Step::evaluate initial nodeset size: ", $initial_nodeset->size, "\n";
 151      
 152      $self->{pp}->set_context_set(undef);
 153  
 154      $initial_nodeset->sort;
 155          
 156      return $initial_nodeset;
 157  }
 158  
 159  # Evaluate the step against a particular node
 160  sub evaluate_node {
 161      my $self = shift;
 162      my $context = shift;
 163      
 164  #    warn "Evaluate node: $self->{axis}\n";
 165      
 166  #    warn "Node: ", $context->[node_name], "\n";
 167      
 168      my $method = $self->{axis_method};
 169      
 170      my $results = XML::XPath::NodeSet->new();
 171      no strict 'refs';
 172      eval {
 173          $method->($self, $context, $results);
 174      };
 175      if ($@) {
 176          die "axis $method not implemented [$@]\n";
 177      }
 178      
 179  #    warn("results: ", join('><', map {$_->string_value} @$results), "\n");
 180      # filter initial nodeset by each predicate
 181      foreach my $predicate (@{$self->{predicates}}) {
 182          $results = $self->filter_by_predicate($results, $predicate);
 183      }
 184      
 185      return $results;
 186  }
 187  
 188  sub axis_ancestor {
 189      my $self = shift;
 190      my ($context, $results) = @_;
 191      
 192      my $parent = $context->getParentNode;
 193          
 194      START:
 195      return $results unless $parent;
 196      if (node_test($self, $parent)) {
 197          $results->push($parent);
 198      }
 199      $parent = $parent->getParentNode;
 200      goto START;
 201  }
 202  
 203  sub axis_ancestor_or_self {
 204      my $self = shift;
 205      my ($context, $results) = @_;
 206      
 207      START:
 208      return $results unless $context;
 209      if (node_test($self, $context)) {
 210          $results->push($context);
 211      }
 212      $context = $context->getParentNode;
 213      goto START;
 214  }
 215  
 216  sub axis_attribute {
 217      my $self = shift;
 218      my ($context, $results) = @_;
 219      
 220      foreach my $attrib (@{$context->getAttributes}) {
 221          if ($self->test_attribute($attrib)) {
 222              $results->push($attrib);
 223          }
 224      }
 225  }
 226  
 227  sub axis_child {
 228      my $self = shift;
 229      my ($context, $results) = @_;
 230      
 231      foreach my $node (@{$context->getChildNodes}) {
 232          if (node_test($self, $node)) {
 233              $results->push($node);
 234          }
 235      }
 236  }
 237  
 238  sub axis_descendant {
 239      my $self = shift;
 240      my ($context, $results) = @_;
 241  
 242      my @stack = $context->getChildNodes;
 243  
 244      while (@stack) {
 245          my $node = pop @stack;
 246          if (node_test($self, $node)) {
 247              $results->unshift($node);
 248          }
 249          push @stack, $node->getChildNodes;
 250      }
 251  }
 252  
 253  sub axis_descendant_or_self {
 254      my $self = shift;
 255      my ($context, $results) = @_;
 256      
 257      my @stack = ($context);
 258      
 259      while (@stack) {
 260          my $node = pop @stack;
 261          if (node_test($self, $node)) {
 262              $results->unshift($node);
 263          }
 264          push @stack, $node->getChildNodes;
 265      }
 266  }
 267  
 268  sub axis_following {
 269      my $self = shift;
 270      my ($context, $results) = @_;
 271      
 272      START:
 273  
 274      my $parent = $context->getParentNode;
 275      return $results unless $parent;
 276          
 277      while ($context = $context->getNextSibling) {
 278          axis_descendant_or_self($self, $context, $results);
 279      }
 280  
 281      $context = $parent;
 282      goto START;
 283  }
 284  
 285  sub axis_following_sibling {
 286      my $self = shift;
 287      my ($context, $results) = @_;
 288  
 289      while ($context = $context->getNextSibling) {
 290          if (node_test($self, $context)) {
 291              $results->push($context);
 292          }
 293      }
 294  }
 295  
 296  sub axis_namespace {
 297      my $self = shift;
 298      my ($context, $results) = @_;
 299      
 300      return $results unless $context->isElementNode;
 301      foreach my $ns (@{$context->getNamespaces}) {
 302          if ($self->test_namespace($ns)) {
 303              $results->push($ns);
 304          }
 305      }
 306  }
 307  
 308  sub axis_parent {
 309      my $self = shift;
 310      my ($context, $results) = @_;
 311      
 312      my $parent = $context->getParentNode;
 313      return $results unless $parent;
 314      if (node_test($self, $parent)) {
 315          $results->push($parent);
 316      }
 317  }
 318  
 319  sub axis_preceding {
 320      my $self = shift;
 321      my ($context, $results) = @_;
 322      
 323      # all preceding nodes in document order, except ancestors
 324      
 325      START:
 326  
 327      my $parent = $context->getParentNode;
 328      return $results unless $parent;
 329  
 330      while ($context = $context->getPreviousSibling) {
 331          axis_descendant_or_self($self, $context, $results);
 332      }
 333      
 334      $context = $parent;
 335      goto START;
 336  }
 337  
 338  sub axis_preceding_sibling {
 339      my $self = shift;
 340      my ($context, $results) = @_;
 341      
 342      while ($context = $context->getPreviousSibling) {
 343          if (node_test($self, $context)) {
 344              $results->push($context);
 345          }
 346      }
 347  }
 348  
 349  sub axis_self {
 350      my $self = shift;
 351      my ($context, $results) = @_;
 352      
 353      if (node_test($self, $context)) {
 354          $results->push($context);
 355      }
 356  }
 357      
 358  sub node_test {
 359      my $self = shift;
 360      my $node = shift;
 361      
 362      # if node passes test, return true
 363      
 364      my $test = $self->{test};
 365  
 366      return 1 if $test == test_nt_node;
 367          
 368      if ($test == test_any) {
 369          return 1 if $node->isElementNode && defined $node->getName;
 370      }
 371          
 372      local $^W;
 373  
 374      if ($test == test_ncwild) {
 375          return unless $node->isElementNode;
 376          my $match_ns = $self->{pp}->get_namespace($self->{literal}, $node);
 377          if (my $node_nsnode = $node->getNamespace()) {
 378              return 1 if $match_ns eq $node_nsnode->getValue;
 379          }
 380      }
 381      elsif ($test == test_qname) {
 382          return unless $node->isElementNode;
 383          if ($self->{literal} =~ /:/) {
 384              my ($prefix, $name) = split(':', $self->{literal}, 2);
 385              my $match_ns = $self->{pp}->get_namespace($prefix, $node);
 386              if (my $node_nsnode = $node->getNamespace()) {
 387  #                warn "match: '$self->{literal}' match NS: '$match_ns' got NS: '", $node_nsnode->getValue, "'\n";
 388                  return 1 if ($match_ns eq $node_nsnode->getValue) &&
 389                          ($name eq $node->getLocalName);
 390              }
 391          }
 392          else {
 393  #            warn "Node test: ", $node->getName, "\n";
 394              return 1 if $node->getName eq $self->{literal};
 395          }
 396      }
 397      elsif ($test == test_nt_text) {
 398          return 1 if $node->isTextNode;
 399      }
 400      elsif ($test == test_nt_comment) {
 401          return 1 if $node->isCommentNode;
 402      }
 403  #     elsif ($test == test_nt_pi && !$self->{literal}) {
 404  #         warn "Unreachable code???";
 405  #         return 1 if $node->isPINode;
 406  #     }
 407      elsif ($test == test_nt_pi) {
 408          return unless $node->isPINode;
 409          if (my $val = $self->{literal}->value) {
 410              return 1 if $node->getTarget eq $val;
 411          }
 412          else {
 413              return 1;
 414          }
 415      }
 416      
 417      return; # fallthrough returns false
 418  }
 419  
 420  sub test_attribute {
 421      my $self = shift;
 422      my $node = shift;
 423      
 424  #    warn "test_attrib: '$self->{test}' against: ", $node->getName, "\n";
 425  #    warn "node type: $node->[node_type]\n";
 426      
 427      my $test = $self->{test};
 428      
 429      return 1 if ($test == test_attr_any) || ($test == test_nt_node);
 430          
 431      if ($test == test_attr_ncwild) {
 432          my $match_ns = $self->{pp}->get_namespace($self->{literal}, $node);
 433          if (my $node_nsnode = $node->getNamespace()) {
 434              return 1 if $match_ns eq $node_nsnode->getValue;
 435          }
 436      }
 437      elsif ($test == test_attr_qname) {
 438          if ($self->{literal} =~ /:/) {
 439              my ($prefix, $name) = split(':', $self->{literal}, 2);
 440              my $match_ns = $self->{pp}->get_namespace($prefix, $node);
 441              if (my $node_nsnode = $node->getNamespace()) {
 442                  return 1 if ($match_ns eq $node_nsnode->getValue) &&
 443                          ($name eq $node->getLocalName);
 444              }
 445          }
 446          else {
 447              return 1 if $node->getName eq $self->{literal};
 448          }
 449      }
 450      
 451      return; # fallthrough returns false
 452  }
 453  
 454  sub test_namespace {
 455      my $self = shift;
 456      my $node = shift;
 457      
 458      # Not sure if this is correct. The spec seems very unclear on what
 459      # constitutes a namespace test... bah!
 460      
 461      my $test = $self->{test};
 462      
 463      return 1 if $test == test_any; # True for all nodes of principal type
 464      
 465      if ($test == test_any) {
 466          return 1;
 467      }
 468      elsif ($self->{literal} eq $node->getExpanded) {
 469          return 1;
 470      }
 471      
 472      return;
 473  }
 474  
 475  sub filter_by_predicate {
 476      my $self = shift;
 477      my ($nodeset, $predicate) = @_;
 478      
 479      # See spec section 2.4, paragraphs 2 & 3:
 480      # For each node in the node-set to be filtered, the predicate Expr
 481      # is evaluated with that node as the context node, with the number
 482      # of nodes in the node set as the context size, and with the
 483      # proximity position of the node in the node set with respect to
 484      # the axis as the context position.
 485      
 486      if (!ref($nodeset)) { # use ref because nodeset has a bool context
 487          die "No nodeset!!!";
 488      }
 489      
 490  #    warn "Filter by predicate: $predicate\n";
 491      
 492      my $newset = XML::XPath::NodeSet->new();
 493      
 494      for(my $i = 1; $i <= $nodeset->size; $i++) {
 495          # set context set each time 'cos a loc-path in the expr could change it
 496          $self->{pp}->set_context_set($nodeset);
 497          $self->{pp}->set_context_pos($i);
 498          my $result = $predicate->evaluate($nodeset->get_node($i));
 499          if ($result->isa('XML::XPath::Boolean')) {
 500              if ($result->value) {
 501                  $newset->push($nodeset->get_node($i));
 502              }
 503          }
 504          elsif ($result->isa('XML::XPath::Number')) {
 505              if ($result->value == $i) {
 506                  $newset->push($nodeset->get_node($i));
 507              }
 508          }
 509          else {
 510              if ($result->to_boolean->value) {
 511                  $newset->push($nodeset->get_node($i));
 512              }
 513          }
 514      }
 515      
 516      return $newset;
 517  }
 518  
 519  1;