view Lib/IMPL/Text/Parser/Player.pm @ 245:7c517134c42f

Added Unsupported media type Web exception corrected resourceLocation setting in the resource Implemented localizable resources for text messages fixed TT view scopings, INIT block in controls now sets globals correctly.
author sergey
date Mon, 29 Oct 2012 03:15:22 +0400
parents 4267a2ac3d46
children 4ddb27ff4a0b
line wrap: on
line source

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

use parent 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;