# $Id: Parser.pm 4532 2004-05-11 05:15:40Z ezra $package XML::XPath::Parser;use strict;use vars qw/        $NCName         $QName         $NCWild        $QNWild        $NUMBER_RE         $NODE_TYPE         $AXIS_NAME         %AXES         $LITERAL        %CACHE/;use XML::XPath::XMLParser;use XML::XPath::Step;use XML::XPath::Expr;use XML::XPath::Function;use XML::XPath::LocationPath;use XML::XPath::Variable;use XML::XPath::Literal;use XML::XPath::Number;use XML::XPath::NodeSet;# Axis name to principal node type mapping%AXES = (        'ancestor' => 'element',        'ancestor-or-self' => 'element',        'attribute' => 'attribute',        'namespace' => 'namespace',        'child' => 'element',        'descendant' => 'element',        'descendant-or-self' => 'element',        'following' => 'element',        'following-sibling' => 'element',        'parent' => 'element',        'preceding' => 'element',        'preceding-sibling' => 'element',        'self' => 'element',        );$NCName = '([A-Za-z_][\w\\.\\-]*)';$QName = "($NCName:)?$NCName";$NCWild = "${NCName}:\\*";$QNWild = "\\*";$NODE_TYPE = '((text|comment|processing-instruction|node)\\(\\))';$AXIS_NAME = '(' . join('|', keys %AXES) . ')::';$NUMBER_RE = '\d+(\\.\d*)?|\\.\d+';$LITERAL = '\\"[^\\"]*\\"|\\\'[^\\\']*\\\'';sub new {    my $class = shift;    my $self = bless {}, $class;    debug("New Parser being created.\n");    $self->{context_set} = XML::XPath::NodeSet->new();    $self->{context_pos} = undef; # 1 based position in array context    $self->{context_size} = 0; # total size of context    $self->clear_namespaces();    $self->{vars} = {};    $self->{direction} = 'forward';    $self->{cache} = {};    return $self;}sub get_var {    my $self = shift;    my $var = shift;    $self->{vars}->{$var};}sub set_var {    my $self = shift;    my $var = shift;    my $val = shift;    $self->{vars}->{$var} = $val;}sub set_namespace {    my $self = shift;    my ($prefix, $expanded) = @_;    $self->{namespaces}{$prefix} = $expanded;}sub clear_namespaces {    my $self = shift;    $self->{namespaces} = {};}sub get_namespace {    my $self = shift;    my ($prefix, $node) = @_;    if (my $ns = $self->{namespaces}{$prefix}) {        return $ns;    }    if (my $nsnode = $node->getNamespace($prefix)) {        return $nsnode->getValue();    }}sub get_context_set { $_[0]->{context_set}; }sub set_context_set { $_[0]->{context_set} = $_[1]; }sub get_context_pos { $_[0]->{context_pos}; }sub set_context_pos { $_[0]->{context_pos} = $_[1]; }sub get_context_size { $_[0]->{context_set}->size; }sub get_context_node { $_[0]->{context_set}->get_node($_[0]->{context_pos}); }sub my_sub {    return (caller(1))[3];}sub parse {    my $self = shift;    my $path = shift;    if ($CACHE{$path}) {        return $CACHE{$path};    }    my $tokens = $self->tokenize($path);    $self->{_tokpos} = 0;    my $tree = $self->analyze($tokens);        if ($self->{_tokpos} < scalar(@$tokens)) {        # didn't manage to parse entire expression - throw an exception        die "Parse of expression $path failed - junk after end of expression: $tokens->[$self->{_tokpos}]";    }        $CACHE{$path} = $tree;        debug("PARSED Expr to:\n", $tree->as_string, "\n") if $XML::XPath::Debug;        return $tree;}sub tokenize {    my $self = shift;    my $path = shift;    study $path;        my @tokens;        debug("Parsing: $path\n");        # Bug: We don't allow "'@' NodeType" which is in the grammar, but I think is just plain stupid.    while($path =~ m/\G        \s* # ignore all whitespace        ( # tokens            $LITERAL|            $NUMBER_RE| # Match digits            \.\.| # match parent            \.| # match current            ($AXIS_NAME)?$NODE_TYPE| # match tests            processing-instruction|            \@($NCWild|$QName|$QNWild)| # match attrib            \$$QName| # match variable reference            ($AXIS_NAME)?($NCWild|$QName|$QNWild)| # match NCName,NodeType,Axis::Test            \!=|<=|\-|>=|\/\/|and|or|mod|div| # multi-char seps            [,\+=\|<>\/\(\[\]\)]| # single char seps            (?<!(\@|\(|\[))\*| # multiply operator rules (see xpath spec)            (?<!::)\*|            $ # match end of query        )        \s* # ignore all whitespace        /gcxso) {        my ($token) = ($1);        if (length($token)) {            debug("TOKEN: $token\n");            push @tokens, $token;        }            }        if (pos($path) < length($path)) {        my $marker = ("." x (pos($path)-1));        $path = substr($path, 0, pos($path) + 8) . "...";        $path =~ s/\n/ /g;        $path =~ s/\t/ /g;        die "Query:\n",            "$path\n",            $marker, "^^^\n",            "Invalid query somewhere around here (I think)\n";    }        return \@tokens;}sub analyze {    my $self = shift;    my $tokens = shift;    # lexical analysis        return Expr($self, $tokens);}sub match {    my ($self, $tokens, $match, $fatal) = @_;        $self->{_curr_match} = '';    return 0 unless $self->{_tokpos} < @$tokens;    local $^W;    #    debug ("match: $match\n");        if ($tokens->[$self->{_tokpos}] =~ /^$match$/) {        $self->{_curr_match} = $tokens->[$self->{_tokpos}];        $self->{_tokpos}++;        return 1;    }    else {        if ($fatal) {            die "Invalid token: ", $tokens->[$self->{_tokpos}], "\n";        }        else {            return 0;        }    }}sub Expr {    my ($self, $tokens) = @_;        debug("in SUB\n");        return OrExpr($self, $tokens);}sub OrExpr {    my ($self, $tokens) = @_;        debug("in SUB\n");        my $expr = AndExpr($self, $tokens);     while (match($self, $tokens, 'or')) {        my $or_expr = XML::XPath::Expr->new($self);        $or_expr->set_lhs($expr);        $or_expr->set_op('or');        my $rhs = AndExpr($self, $tokens);        $or_expr->set_rhs($rhs);        $expr = $or_expr;    }        return $expr;}sub AndExpr {    my ($self, $tokens) = @_;        debug("in SUB\n");        my $expr = EqualityExpr($self, $tokens);    while (match($self, $tokens, 'and')) {        my $and_expr = XML::XPath::Expr->new($self);        $and_expr->set_lhs($expr);        $and_expr->set_op('and');                my $rhs = EqualityExpr($self, $tokens);                $and_expr->set_rhs($rhs);        $expr = $and_expr;    }        return $expr;}sub EqualityExpr {    my ($self, $tokens) = @_;        debug("in SUB\n");        my $expr = RelationalExpr($self, $tokens);    while (match($self, $tokens, '!?=')) {        my $eq_expr = XML::XPath::Expr->new($self);        $eq_expr->set_lhs($expr);        $eq_expr->set_op($self->{_curr_match});                my $rhs = RelationalExpr($self, $tokens);                $eq_expr->set_rhs($rhs);        $expr = $eq_expr;    }        return $expr;}sub RelationalExpr {    my ($self, $tokens) = @_;        debug("in SUB\n");        my $expr = AdditiveExpr($self, $tokens);    while (match($self, $tokens, '(<|>|<=|>=)')) {        my $rel_expr = XML::XPath::Expr->new($self);        $rel_expr->set_lhs($expr);        $rel_expr->set_op($self->{_curr_match});                my $rhs = AdditiveExpr($self, $tokens);                $rel_expr->set_rhs($rhs);        $expr = $rel_expr;    }        return $expr;}sub AdditiveExpr {    my ($self, $tokens) = @_;        debug("in SUB\n");        my $expr = MultiplicativeExpr($self, $tokens);    while (match($self, $tokens, '[\\+\\-]')) {        my $add_expr = XML::XPath::Expr->new($self);        $add_expr->set_lhs($expr);        $add_expr->set_op($self->{_curr_match});                my $rhs = MultiplicativeExpr($self, $tokens);                $add_expr->set_rhs($rhs);        $expr = $add_expr;    }        return $expr;}sub MultiplicativeExpr {    my ($self, $tokens) = @_;        debug("in SUB\n");        my $expr = UnaryExpr($self, $tokens);    while (match($self, $tokens, '(\\*|div|mod)')) {        my $mult_expr = XML::XPath::Expr->new($self);        $mult_expr->set_lhs($expr);        $mult_expr->set_op($self->{_curr_match});                my $rhs = UnaryExpr($self, $tokens);                $mult_expr->set_rhs($rhs);        $expr = $mult_expr;    }        return $expr;}sub UnaryExpr {    my ($self, $tokens) = @_;        debug("in SUB\n");        if (match($self, $tokens, '-')) {        my $expr = XML::XPath::Expr->new($self);        $expr->set_lhs(XML::XPath::Number->new(0));        $expr->set_op('-');        $expr->set_rhs(UnaryExpr($self, $tokens));        return $expr;    }    else {        return UnionExpr($self, $tokens);    }}sub UnionExpr {    my ($self, $tokens) = @_;        debug("in SUB\n");        my $expr = PathExpr($self, $tokens);    while (match($self, $tokens, '\\|')) {        my $un_expr = XML::XPath::Expr->new($self);        $un_expr->set_lhs($expr);        $un_expr->set_op('|');                my $rhs = PathExpr($self, $tokens);                $un_expr->set_rhs($rhs);        $expr = $un_expr;    }        return $expr;}sub PathExpr {    my ($self, $tokens) = @_;    debug("in SUB\n");        # PathExpr is LocationPath | FilterExpr | FilterExpr '//?' RelativeLocationPath        # Since we are being predictive we need to find out which function to call next, then.            # LocationPath either starts with "/", "//", ".", ".." or a proper Step.        my $expr = XML::XPath::Expr->new($self);        my $test = $tokens->[$self->{_tokpos}];        # Test for AbsoluteLocationPath and AbbreviatedRelativeLocationPath    if ($test =~ /^(\/\/?|\.\.?)$/) {        # LocationPath        $expr->set_lhs(LocationPath($self, $tokens));    }    # Test for AxisName::...    elsif (is_step($self, $tokens)) {