parser.pm

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

        $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;