One Hat Cyber Team

View File Name : XPath.pm

# $Id: /xmltwig/trunk/Twig/XPath.pm 32 2008-01-18T13:11:52.128782Z mrodrigu  $
package XML::Twig::XPath;
use strict;
use warnings;
use XML::Twig;

my $XPATH;        # XPath engine (XML::XPath or XML::XPathEngine);
my $XPATH_NUMBER; # <$XPATH>::Number, the XPath number class
BEGIN
  { foreach my $xpath_engine ( qw( XML::XPathEngine XML::XPath) )
      { if(  XML::Twig::_use( $xpath_engine) ) { $XPATH= $xpath_engine; last; } }
    unless( $XPATH) { die "cannot use XML::Twig::XPath: neither XML::XPathEngine 0.09+ nor XML::XPath are available"; }
    $XPATH_NUMBER= "${XPATH}::Number";
  }


use vars qw($VERSION);
$VERSION="0.02";

BEGIN
{ package # hide from PAUSE
    XML::XPath::NodeSet;
  no warnings; # to avoid the "Subroutine sort redefined" message
  # replace the native sort routine by a Twig'd one
  sub sort
    { my $self = CORE::shift;
      @$self = CORE::sort { $a->node_cmp( $b) } @$self;
      return $self;
    }

  package # hide from PAUSE
    XML::XPathEngine::NodeSet;
  no warnings; # to avoid the "Subroutine sort redefined" message
  # replace the native sort routine by a Twig'd one
  sub sort
    { my $self = CORE::shift;
      @$self = CORE::sort { $a->node_cmp( $b) } @$self;
      return $self;
    }
}

package XML::Twig::XPath;

use base 'XML::Twig';

my $XP; # the global xp object;

sub to_number { return $XPATH_NUMBER->new( $_[0]->root->text); }

sub new
  { my $class= shift;
    my $t= XML::Twig->new( elt_class => 'XML::Twig::XPath::Elt', @_);
    $t->{twig_xp}= $XPATH->new();
    bless $t, $class;
    return $t;
  }


sub set_namespace         { my $t= shift; $t->{twig_xp}->set_namespace( @_); }
sub set_strict_namespaces { my $t= shift; $t->{twig_xp}->set_strict_namespaces( @_); }

sub node_cmp($$)          { return $_[1] == $_[0] ? 0 : -1; } # document is before anything but itself

sub isElementNode   { 0 }
sub isAttributeNode { 0 }
sub isTextNode      { 0 }
sub isProcessingInstructionNode { 0 }
sub isPINode        { 0 }
sub isCommentNode   { 0 }
sub isNamespaceNode { 0 }
sub getAttributes   { [] }
sub getValue { return $_[0]->root->text; }

sub findnodes           { my( $t, $path)= @_; return $t->{twig_xp}->findnodes(           $path, $t); }
sub findnodes_as_string { my( $t, $path)= @_; return $t->{twig_xp}->findnodes_as_string( $path, $t); }
sub findvalue           { my( $t, $path)= @_; return $t->{twig_xp}->findvalue(           $path, $t); }
sub exists              { my( $t, $path)= @_; return $t->{twig_xp}->exists(              $path, $t); }
sub find                { my( $t, $path)= @_; return $t->{twig_xp}->find(                $path, $t); }
sub matches             { my( $t, $path, $node)= @_; $node ||= $t; return $t->{twig_xp}->matches( $node, $path, $t) || 0; }

sub getNamespaces { $_[0]->root->getNamespaces(); }

#TODO: it would be nice to be able to pass in any object in this
#distribution and cast it to the proper $XPATH class to use as a
#variable (via 'nodes' argument or something)
sub set_var {
  my ($t, $name, $value) = @_;
  if( ! ref $value) { $value= $t->findnodes( qq{"$value"}); } 
  $t->{twig_xp}->set_var($name, $value);
}

1;

# adds the appropriate methods to XML::Twig::Elt so XML::XPath can be used as the XPath engine
package XML::Twig::XPath::Elt;
use base 'XML::Twig::Elt';

*getLocalName= *XML::Twig::Elt::local_name;
*getValue    = *XML::Twig::Elt::text;
sub isAttributeNode { 0 }
sub isNamespaceNode { 0 }

sub to_number { return $XPATH_NUMBER->new( $_[0]->text); }

sub getAttributes
  { my $elt= shift;
    my $atts= $elt->atts;
    # alternate, faster but less clean, way
    my @atts= map { bless( { name => $_, value => $atts->{$_}, elt => $elt },
                           'XML::Twig::XPath::Attribute')
                  }
                   sort keys %$atts;
    # my @atts= map { XML::Twig::XPath::Attribute->new( $elt, $_) } sort keys %$atts;
    return wantarray ? @atts : \@atts;
  }

sub getNamespace
  { my $elt= shift;
    my $prefix= shift() || $elt->ns_prefix;
    if( my $expanded= $elt->namespace( $prefix))
      { return XML::Twig::XPath::Namespace->new( $prefix, $expanded); }
    else
      { return XML::Twig::XPath::Namespace->new( $prefix, ''); }
  }

# returns namespaces declared in the element
sub getNamespaces #_get_namespaces
  { my( $elt)= @_;
    my @namespaces;
    foreach my $att ($elt->att_names)
          { if( $att=~ m{^xmlns(?::(\w+))?$})
              { my $prefix= $1 || '';
                my $expanded= $elt->att( $att); 
                push @namespaces, XML::Twig::XPath::Namespace->new( $prefix, $expanded);
              }
          }
    return wantarray() ? @namespaces : \@namespaces;
  }

sub node_cmp($$)
  { my( $a, $b)= @_;
    if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Elt'))
      { # 2 elts, compare them
        return $a->cmp( $b);
      }
    elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Attribute'))
      { # elt <=> att, compare the elt to the att->{elt}
        # if the elt is the att->{elt} (cmp return 0) then -1, elt is before att
        return ($a->cmp( $b->{elt}) ) || -1 ;
      }
    elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath'))
      { # elt <=> document, elt is after document
        return 1;
      }
    else
      { die "unknown node type ", ref( $b); }
  }

sub getParentNode
  { return $_[0]->_parent
        || $_[0]->twig;
  }

sub findnodes           { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findnodes(           $path, $elt); }
sub findnodes_as_string { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findnodes_as_string( $path, $elt); }
sub findvalue           { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->findvalue(           $path, $elt); }
sub exists              { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->exists(              $path, $elt); }
sub find                { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->find(                $path, $elt); }
sub matches             { my( $elt, $path)= @_; return $elt->twig->{twig_xp}->matches( $elt, $path, $elt->getParentNode) || 0; }


1;

# this package is only used to allow XML::XPath as the XPath engine, otherwise
# attributes are just attached to their parent element and are not considered objects

package XML::Twig::XPath::Attribute;

sub new
  { my( $class, $elt, $att)= @_;
    return bless { name => $att, value => $elt->att( $att), elt => $elt }, $class;
  }

sub getValue     { return $_[0]->{value}; }
sub getName      { return $_[0]->{name} ; }
sub getLocalName { (my $name= $_[0]->{name}) =~ s{^.*:}{}; $name; }
sub string_value { return $_[0]->{value}; }
sub to_number    { return $XPATH_NUMBER->new( $_[0]->{value}); }
sub isElementNode   { 0 }
sub isAttributeNode { 1 }
sub isNamespaceNode { 0 }
sub isTextNode      { 0 }
sub isProcessingInstructionNode { 0 }
sub isPINode        { 0 }
sub isCommentNode   { 0 }
sub toString { return qq{$_[0]->{name}="$_[0]->{value}"}; }

sub getNamespace
  { my $att= shift;
    my $prefix= shift();
    if( ! defined( $prefix))
      { if($att->{name}=~ m{^(.*):}) { $prefix= $1; }
        else                         { $prefix='';  }
      }

    if( my $expanded= $att->{elt}->namespace( $prefix))
      { return XML::Twig::XPath::Namespace->new( $prefix, $expanded); }
  }

sub node_cmp($$)
  { my( $a, $b)= @_;
    if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Attribute'))
      { # 2 attributes, compare their elements, then their name
        return ($a->{elt}->cmp( $b->{elt}) ) || ($a->{name} cmp $b->{name});
      }
    elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Elt'))
      { # att <=> elt : compare the att->elt and the elt
        # if att->elt is the elt (cmp returns 0) then 1 (elt is before att)
        return ($a->{elt}->cmp( $b) ) || 1 ;
      }
    elsif( UNIVERSAL::isa( $b, 'XML::Twig::XPath'))
      { # att <=> document, att is after document
        return 1;
      }
    else
      { die "unknown node type ", ref( $b); }
  }

*cmp=*node_cmp;

1;

package XML::Twig::XPath::Namespace;

sub new
  { my( $class, $prefix, $expanded)= @_;
    bless { prefix => $prefix, expanded => $expanded }, $class;
  }

sub isNamespaceNode { 1; }

sub getPrefix   { $_[0]->{prefix};   }
sub getExpanded { $_[0]->{expanded}; }
sub getValue    { $_[0]->{expanded}; }
sub getData     { $_[0]->{expanded}; }

sub node_cmp($$)
  { my( $a, $b)= @_;
    if( UNIVERSAL::isa( $b, 'XML::Twig::XPath::Namespace'))
      { # 2 attributes, compare their elements, then their name
        return $a->{prefix} cmp $b->{prefix};
      }
    else
      { die "unknown node type ", ref( $b); }
  }

*cmp=*node_cmp;

1