local-lib5/lib/perl5/i486-linux-gnu-thread-multi/XML/LibXML/XPathContext.pm

   1 # $Id: XPathContext.pm 422 2002-11-08 17:10:30Z phish $
   2 #
   3 # This is free software, you may use it and distribute it under the same terms as
   4 # Perl itself.
   5 #
   6 # Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
   7 #
   8 #
   9
  10 package XML::LibXML::XPathContext;
  11
  12 use strict;
  13 use vars qw($VERSION @ISA $USE_LIBXML_DATA_TYPES);
  14
  15 use Carp;
  16 use XML::LibXML;
  17 use XML::LibXML::NodeList;
  18
  19 $VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
  20
  21 # should LibXML XPath data types be used for simple objects
  22 # when passing parameters to extension functions (default: no)
  23 $USE_LIBXML_DATA_TYPES = 0;
  24
  25 sub CLONE_SKIP { 1 }
  26
  27 sub findnodes {
  28     my ($self, $xpath, $node) = @_;
  29
  30     my @nodes = $self->_guarded_find_call('_findnodes', $node, $xpath);
  31
  32     if (wantarray) {
  33         return @nodes;
  34     }
  35     else {
  36         return XML::LibXML::NodeList->new(@nodes);
  37     }
  38 }
  39
  40 sub find {
  41     my ($self, $xpath, $node) = @_;
  42
  43     my ($type, @params) = $self->_guarded_find_call('_find', $node, $xpath,0);
  44
  45     if ($type) {
  46         return $type->new(@params);
  47     }
  48     return undef;
  49 }
  50
  51 sub exists {
  52     my ($self, $xpath, $node) = @_;
  53     my (undef, $value) = $self->_guarded_find_call('_find', $node, $xpath,1);
  54     return $value;
  55 }
  56
  57 sub findvalue {
  58     my $self = shift;
  59     return $self->find(@_)->to_literal->value;
  60 }
  61
  62 sub _guarded_find_call {
  63     my ($self, $method, $node)=(shift,shift,shift);
  64
  65     my $prev_node;
  66     if (ref($node)) {
  67         $prev_node = $self->getContextNode();
  68         $self->setContextNode($node);
  69     }
  70     my @ret;
  71     eval {
  72         @ret = $self->$method(@_);
  73     };
  74     $self->_free_node_pool;
  75     $self->setContextNode($prev_node) if ref($node);
  76
  77     if ($@) {
  78       my $err = $@;
  79       chomp $err;
  80       croak $err;
  81     }
  82
  83     return @ret;
  84 }
  85
  86 sub registerFunction {
  87     my ($self, $name, $sub) = @_;
  88     $self->registerFunctionNS($name, undef, $sub);
  89     return;
  90 }
  91
  92 sub unregisterNs {
  93     my ($self, $prefix) = @_;
  94     $self->registerNs($prefix, undef);
  95     return;
  96 }
  97
  98 sub unregisterFunction {
  99     my ($self, $name) = @_;
 100     $self->registerFunctionNS($name, undef, undef);
 101     return;
 102 }
 103
 104 sub unregisterFunctionNS {
 105     my ($self, $name, $ns) = @_;
 106     $self->registerFunctionNS($name, $ns, undef);
 107     return;
 108 }
 109
 110 sub unregisterVarLookupFunc {
 111     my ($self) = @_;
 112     $self->registerVarLookupFunc(undef, undef);
 113     return;
 114 }
 115
 116 # extension function perl dispatcher
 117 # borrowed from XML::LibXSLT
 118
 119 sub _perl_dispatcher {
 120     my $func = shift;
 121     my @params = @_;
 122     my @perlParams;
 123
 124     my $i = 0;
 125     while (@params) {
 126         my $type = shift(@params);
 127         if ($type eq 'XML::LibXML::Literal' or
 128             $type eq 'XML::LibXML::Number' or
 129             $type eq 'XML::LibXML::Boolean')
 130         {
 131             my $val = shift(@params);
 132             unshift(@perlParams, $USE_LIBXML_DATA_TYPES ? $type->new($val) : $val);
 133         }
 134         elsif ($type eq 'XML::LibXML::NodeList') {
 135             my $node_count = shift(@params);
 136             unshift(@perlParams, $type->new(splice(@params, 0, $node_count)));
 137         }
 138     }
 139
 140     $func = "main::$func" unless ref($func) || $func =~ /(.+)::/;
 141     no strict 'refs';
 142     my $res = $func->(@perlParams);
 143     return $res;
 144 }
 145
 146 1;