Parser.pm   [plain text]

# $Id: Parser.pm,v 1.33 2001/11/26 17:41:18 matt Exp $

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)) {
        $expr->set_lhs(LocationPath($self, $tokens));
    }
    else {
        # Not a LocationPath
        # Use FilterExpr instead:
        
        $expr = FilterExpr($self, $tokens);
        if (match($self, $tokens, '//?')) {
            my $loc_path = XML::XPath::LocationPath->new();
            push @$loc_path, $expr;
            if ($self->{_curr_match} eq '//') {
                push @$loc_path, XML::XPath::Step->new($self, 'descendant-or-self', 
                                        XML::XPath::Step::test_nt_node);
            }
            push @$loc_path, RelativeLocationPath($self, $tokens);
            my $new_expr = XML::XPath::Expr->new($self);
            $new_expr->set_lhs($loc_path);
            return $new_expr;
        }
    }
    
    return $expr;
}

sub FilterExpr {
    my ($self, $tokens) = @_;
    
    debug("in SUB\n");
    
    my $expr = PrimaryExpr($self, $tokens);
    while (match($self, $tokens, '\\[')) {
        # really PredicateExpr...
        $expr->push_predicate(Expr($self, $tokens));
        match($self, $tokens, '\\]', 1);
    }
    
    return $expr;
}

sub PrimaryExpr {
    my ($self, $tokens) = @_;

    debug("in SUB\n");
    
    my $expr = XML::XPath::Expr->new($self);
    
    if (match($self, $tokens, $LITERAL)) {
        # new Literal with $self->{_curr_match}...
        $self->{_curr_match} =~ m/^(["'])(.*)\1$/;
        $expr->set_lhs(XML::XPath::Literal->new($2));
    }
    elsif (match($self, $tokens, $NUMBER_RE)) {
        # new Number with $self->{_curr_match}...
        $expr->set_lhs(XML::XPath::Number->new($self->{_curr_match}));
    }
    elsif (match($self, $tokens, '\\(')) {
        $expr->set_lhs(Expr($self, $tokens));
        match($self, $tokens, '\\)', 1);
    }
    elsif (match($self, $tokens, "\\\$$QName")) {
        # new Variable with $self->{_curr_match}...
        $self->{_curr_match} =~ /^\$(.*)$/;
        $expr->set_lhs(XML::XPath::Variable->new($self, $1));
    }
    elsif (match($self, $tokens, $QName)) {
        # check match not Node_Type - done in lexer...
        # new Function
        my $func_name = $self->{_curr_match};
        match($self, $tokens, '\\(', 1);
        $expr->set_lhs(
                XML::XPath::Function->new(
                    $self,
                    $func_name,
                    Arguments($self, $tokens)
                )
            );
        match($self, $tokens, '\\)', 1);
    }
    else {
        die "Not a PrimaryExpr at ", $tokens->[$self->{_tokpos}], "\n";
    }
    
    return $expr;
}

sub Arguments {
    my ($self, $tokens) = @_;
    
    debug("in SUB\n");
    
    my @args;
    
    if($tokens->[$self->{_tokpos}] eq ')') {
        return \@args;
    }
    
    push @args, Expr($self, $tokens);
    while (match($self, $tokens, ',')) {
        push @args, Expr($self, $tokens);
    }
    
    return \@args;
}

sub LocationPath {
    my ($self, $tokens) = @_;

    debug("in SUB\n");
    
    my $loc_path = XML::XPath::LocationPath->new();
    
    if (match($self, $tokens, '/')) {
        # root
        debug("SUB: Matched root\n");
        push @$loc_path, XML::XPath::Root->new();
        if (is_step($self, $tokens)) {
            debug("Next is step\n");
            push @$loc_path, RelativeLocationPath($self, $tokens);
        }
    }
    elsif (match($self, $tokens, '//')) {
        # root
        push @$loc_path, XML::XPath::Root->new();
        my $optimised = optimise_descendant_or_self($self, $tokens);
        if (!$optimised) {
            push @$loc_path, XML::XPath::Step->new($self, 'descendant-or-self',
                                XML::XPath::Step::test_nt_node);
            push @$loc_path, RelativeLocationPath($self, $tokens);
        }
        else {
            push @$loc_path, $optimised, RelativeLocationPath($self, $tokens);
        }
    }
    else {
        push @$loc_path, RelativeLocationPath($self, $tokens);
    }
    
    return $loc_path;
}

sub optimise_descendant_or_self {
    my ($self, $tokens) = @_;
    
    debug("in SUB\n");
    
    my $tokpos = $self->{_tokpos};
    
    # // must be followed by a Step.
    if ($tokens->[$tokpos+1] && $tokens->[$tokpos+1] eq '[') {
        # next token is a predicate
        return;
    }
    elsif ($tokens->[$tokpos] =~ /^\.\.?$/) {
        # abbreviatedStep - can't optimise.
        return;
    }                                                                                              
    else {
        debug("Trying to optimise //\n");
        my $step = Step($self, $tokens);
        if ($step->{axis} ne 'child') {
            # can't optimise axes other than child for now...
            $self->{_tokpos} = $tokpos;
            return;
        }
        $step->{axis} = 'descendant';
        $step->{axis_method} = 'axis_descendant';
        $self->{_tokpos}--;
        $tokens->[$self->{_tokpos}] = '.';
        return $step;
    }
}

sub RelativeLocationPath {
    my ($self, $tokens) = @_;
    
    debug("in SUB\n");
    
    my @steps;
    
    push @steps, Step($self, $tokens);
    while (match($self, $tokens, '//?')) {
        if ($self->{_curr_match} eq '//') {
            my $optimised = optimise_descendant_or_self($self, $tokens);
            if (!$optimised) {
                push @steps, XML::XPath::Step->new($self, 'descendant-or-self',
                                        XML::XPath::Step::test_nt_node);
            }
            else {
                push @steps, $optimised;
            }
        }
        push @steps, Step($self, $tokens);
        if (@steps > 1 && 
                $steps[-1]->{axis} eq 'self' && 
                $steps[-1]->{test} == XML::XPath::Step::test_nt_node) {
            pop @steps;
        }
    }
    
    return @steps;
}

sub Step {
    my ($self, $tokens) = @_;

    debug("in SUB\n");
    
    if (match($self, $tokens, '\\.')) {
        # self::node()
        return XML::XPath::Step->new($self, 'self', XML::XPath::Step::test_nt_node);
    }
    elsif (match($self, $tokens, '\\.\\.')) {
        # parent::node()
        return XML::XPath::Step->new($self, 'parent', XML::XPath::Step::test_nt_node);
    }
    else {
        # AxisSpecifier NodeTest Predicate(s?)
        my $token = $tokens->[$self->{_tokpos}];
        
        debug("SUB: Checking $token\n");
        
        my $step;
        if ($token eq 'processing-instruction') {
            $self->{_tokpos}++;
            match($self, $tokens, '\\(', 1);
            match($self, $tokens, $LITERAL);
            $self->{_curr_match} =~ /^["'](.*)["']$/;
            $step = XML::XPath::Step->new($self, 'child',
                                    XML::XPath::Step::test_nt_pi,
                        XML::XPath::Literal->new($1));
            match($self, $tokens, '\\)', 1);
        }
        elsif ($token =~ /^\@($NCWild|$QName|$QNWild)$/o) {
            $self->{_tokpos}++;
                        if ($token eq '@*') {
                            $step = XML::XPath::Step->new($self,
                                    'attribute',
                                    XML::XPath::Step::test_attr_any,
                                    '*');
                        }
                        elsif ($token =~ /^\@($NCName):\*$/o) {
                            $step = XML::XPath::Step->new($self,
                                    'attribute',
                                    XML::XPath::Step::test_attr_ncwild,
                                    $1);
                        }
                        elsif ($token =~ /^\@($QName)$/o) {
                            $step = XML::XPath::Step->new($self,
                                    'attribute',
                                    XML::XPath::Step::test_attr_qname,
                                    $1);
                        }
        }
        elsif ($token =~ /^($NCName):\*$/o) { # ns:*
            $self->{_tokpos}++;
            $step = XML::XPath::Step->new($self, 'child', 
                                XML::XPath::Step::test_ncwild,
                                $1);
        }
        elsif ($token =~ /^$QNWild$/o) { # *
            $self->{_tokpos}++;
            $step = XML::XPath::Step->new($self, 'child', 
                                XML::XPath::Step::test_any,
                                $token);
        }
        elsif ($token =~ /^$QName$/o) { # name:name
            $self->{_tokpos}++;
            $step = XML::XPath::Step->new($self, 'child', 
                                XML::XPath::Step::test_qname,
                                $token);
        }
        elsif ($token eq 'comment()') {
                    $self->{_tokpos}++;
            $step = XML::XPath::Step->new($self, 'child',
                            XML::XPath::Step::test_nt_comment);
        }
        elsif ($token eq 'text()') {
            $self->{_tokpos}++;
            $step = XML::XPath::Step->new($self, 'child',
                    XML::XPath::Step::test_nt_text);
        }
        elsif ($token eq 'node()') {
            $self->{_tokpos}++;
            $step = XML::XPath::Step->new($self, 'child',
                    XML::XPath::Step::test_nt_node);
        }
        elsif ($token eq 'processing-instruction()') {
            $self->{_tokpos}++;
            $step = XML::XPath::Step->new($self, 'child',
                    XML::XPath::Step::test_nt_pi);
        }
        elsif ($token =~ /^$AXIS_NAME($NCWild|$QName|$QNWild|$NODE_TYPE)$/o) {
                    my $axis = $1;
                    $self->{_tokpos}++;
                    $token = $2;
            if ($token eq 'processing-instruction') {
                match($self, $tokens, '\\(', 1);
                match($self, $tokens, $LITERAL);
                $self->{_curr_match} =~ /^["'](.*)["']$/;
                $step = XML::XPath::Step->new($self, $axis,
                                        XML::XPath::Step::test_nt_pi,
                            XML::XPath::Literal->new($1));
                match($self, $tokens, '\\)', 1);
            }
            elsif ($token =~ /^($NCName):\*$/o) { # ns:*
                $step = XML::XPath::Step->new($self, $axis, 
                                    (($axis eq 'attribute') ? 
                                    XML::XPath::Step::test_attr_ncwild
                                        :
                                    XML::XPath::Step::test_ncwild),
                                    $1);
            }
            elsif ($token =~ /^$QNWild$/o) { # *
                $step = XML::XPath::Step->new($self, $axis, 
                                    (($axis eq 'attribute') ?
                                    XML::XPath::Step::test_attr_any
                                        :
                                    XML::XPath::Step::test_any),
                                    $token);
            }
            elsif ($token =~ /^$QName$/o) { # name:name
                $step = XML::XPath::Step->new($self, $axis, 
                                    (($axis eq 'attribute') ?
                                    XML::XPath::Step::test_attr_qname
                                        :
                                    XML::XPath::Step::test_qname),
                                    $token);
            }
            elsif ($token eq 'comment()') {
                $step = XML::XPath::Step->new($self, $axis,
                                XML::XPath::Step::test_nt_comment);
            }
            elsif ($token eq 'text()') {
                $step = XML::XPath::Step->new($self, $axis,
                        XML::XPath::Step::test_nt_text);
            }
            elsif ($token eq 'node()') {
                $step = XML::XPath::Step->new($self, $axis,
                        XML::XPath::Step::test_nt_node);
            }
            elsif ($token eq 'processing-instruction()') {
                $step = XML::XPath::Step->new($self, $axis,
                        XML::XPath::Step::test_nt_pi);
            }
            else {
                die "Shouldn't get here";
            }
        }
        else {
            die "token $token doesn't match format of a 'Step'\n";
        }
        
        while (match($self, $tokens, '\\[')) {
            push @{$step->{predicates}}, Expr($self, $tokens);
            match($self, $tokens, '\\]', 1);
        }
        
        return $step;
    }
}

sub is_step {
    my ($self, $tokens) = @_;
    
    my $token = $tokens->[$self->{_tokpos}];
    
    return unless defined $token;
        
    debug("SUB: Checking if '$token' is a step\n");
    
        local $^W;
        
    if ($token eq 'processing-instruction') {
        return 1;
    }
    elsif ($token =~ /^\@($NCWild|$QName|$QNWild)$/o) {
        return 1;
    }
    elsif ($token =~ /^($NCWild|$QName|$QNWild)$/o && $tokens->[$self->{_tokpos}+1] ne '(') {
        return 1;
    }
    elsif ($token =~ /^$NODE_TYPE$/o) {
        return 1;
    }
    elsif ($token =~ /^$AXIS_NAME($NCWild|$QName|$QNWild|$NODE_TYPE)$/o) {
        return 1;
    }
    
    debug("SUB: '$token' not a step\n");

    return;
}

sub debug {
    return unless $XML::XPath::Debug;
    
    my ($pkg, $file, $line, $sub) = caller(1);
    
    $sub =~ s/^$pkg\:://;
    
    while (@_) {
        my $x = shift;
        $x =~ s/\bPKG\b/$pkg/g;
        $x =~ s/\bLINE\b/$line/g;
        $x =~ s/\bSUB\b/$sub/g;
        print STDERR $x;
    }
}

1;