home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / XML / XPath / Step.pm < prev    next >
Encoding:
Perl POD Document  |  2001-04-01  |  13.1 KB  |  520 lines
  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;
  520.