view Lib/IMPL/Text/Parser/Player.pm @ 250:129e48bb5afb

DOM refactoring ObjectToDOM methods are virtual QueryToDOM uses inflators Fixed transform for the complex values in the ObjectToDOM QueryToDOM doesn't allow to use complex values (HASHes) as values for nodes (overpost problem)
author sergey
date Wed, 07 Nov 2012 04:17:53 +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;