view Lib/IMPL/Text/Parser/Player.pm @ 134:44977efed303

Significant performance optimizations Fixed recursion problems due converting objects to JSON Added cache support for the templates Added discovery feature for the web methods
author wizard
date Mon, 21 Jun 2010 02:39:53 +0400
parents 16ada169ca75
children 4267a2ac3d46
line wrap: on
line source

package IMPL::Text::Parser::Player;
use strict;
use warnings;

use base qw(IMPL::Object);
use IMPL::Class::Property;
use IMPL::Class::Property::Direct;

use IMPL::Text::Parser::Chunk;

my %opCodesMap = (
    IMPL::Text::Parser::Chunk::OP_REGEXP , &MatchRegexp ,
    IMPL::Text::Parser::Chunk::OP_STRING , &MatchString ,
    IMPL::Text::Parser::Chunk::OP_REFERENCE , &MatchReference ,
    IMPL::Text::Parser::Chunk::OP_CHUNK , &PlayChunk ,
    IMPL::Text::Parser::Chunk::OP_SWITCH , &MatchSwitch ,
    IMPL::Text::Parser::Chunk::OP_REPEAT , &MatchRepeat
);

BEGIN {
    private _direct property _data => prop_all;
    private _direct property _current => prop_all;
    private _direct property _states => prop_all;
    private _direct property _document => prop_all;
    
    public _direct property errorLast => prop_all;
    public _direct property Punctuation => prop_all;
    public _direct property Delimier => prop_all;
}

sub CTOR {
    my ($this,$document) = @_;
    
    $this->{$_document} = $document or die new IMPL::InvalidArgumentException("The first parameter must be a document");
}

sub LoadString {
    my ($this,$string) = @_;
    
    my $rxDelim = /(\s+|[.,;!-+*~$^&|%()`@\\\/])/;
    
    my $line = 0;
    
    $this->{$_data} = [
        map {
            $line++;
            map {
                [$line,$_]
            } split $rxDelim, $_
        } split /\n/, $string
    ]
}

sub Play {
    my ($this) = @_;
}

sub PlayChunk {
    my ($this,$chunk) = @_;
    
    my $end = 0;
    
    my $name = $chunk->chunkName;
    
    $this->enter($name) if $name;
    
    foreach my $op ( @{$chunk->opStream} ) {
        $this->leave(0) and return $this->error("no more data") if $end;
    
        $opCodesMap{shift @$op}->(@$op) || return $this->leave(0) ;
        $this->moveNext or $end = 1;
    }
    
    return $this->leave(1);
}

sub MatchRegexp {
    my ($this,$rx) = @_;
    
    $this->{$_current}{token} =~ $rx ? ($this->data() and return 1) : return $this->error("Expected: $rx");
}

sub MatchString {
    my ($this,$string) = @_;
    
    $this->{$_current}{token} eq $string ? ($this->data() and return 1) : return $this->error("Expected: $string");
}

sub MatchReference {
    my ($this,$name) = @_;
    
    my $chunk = $this->ResolveChunk($name) || return $this->error("Invalid reference: $name");
    return $this->PlayChunk($chunk);
}

sub MatchSwitch {
    my ($this,@chunks) = @_;
    
    foreach my $chunk (@chunks) {
        $this->save;
        if ( $this->PlayChunk($chunk) ) {
            $this->apply;
            return 1;
        } else {
            $this->restore;
        }
    }
    
    return 0; # passthrough last error
}

sub MatchRepeat {
    my ($this,$chunk, $min, $max) = @_;
    
    my $count = 0;
    
    $this->save;
    while (1) {
        $this->save;
        if ($this->PlayChunk($chunk)) {
            $count ++;
            $this->apply;
            $this->apply and return 1 if ($count >= $max)
        } else {
            $this->restore;
            $count >= $min ?
                ($this->apply() and return 1) :
                ($this->restore() and return $this->error("Expected at least $min occurances, got only $count"));
        }
    }
    
    # we should never get here
    die new IMPL::InvalidOperationException("unexpected error");
}

sub moveNext {
    my ($this) = @_;
    
    my $pos = $this->{$_current}{pos};
    
    $pos ++;
    
    if ($pos < @{$this->{$_data}}) {
        
        $this->{$_current} = {
            pos => $pos,
            token => $this->{$_data}[$pos][1],
            line => $this->{$_data}
        };
        
    } else {
        $this->{$_current} = {};
        return undef;
    }
}

sub ResolveChunk {
    my ($this,$name) = @_;
}

sub save {
    my ($this) = @_;
    
    push @{$this->{$_states}}, $this->{$_current};
}

sub restore {
    my ($this) = @_;
    
    $this->{$_current} = pop @{$this->{$_states}};
}

sub apply {
    my ($this) = @_;
    
    pop @{$this->{$_states}};
}

sub error {
    my ($this,$message) = @_;
    
    $this->{$errorLast} = {
        message => $message,
        line => $this->{$_current}{line},
        token => $this->{$_current}{token}
    };
    
    return 0;
}

sub __debug {
    
}
sub enter {
    my ($this,$name) = @_;
    
    #always return true;
    return 1;
}

sub leave {
    my ($this,$isEmpty) = @_;
    
    #always return true;
    return 1;
}

sub data {
    my ($this) = @_;
    
    my $data = $this->{$_current}{token};
    
    # always return true;
    return 1;
}

1;