parser.pm

网页留言本,比一般的留言簿管用

# $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)) {