view Lib/IMPL/Text/Parser/Player.pm @ 148:e6447ad85cb4

DOM objects now have a schema and schemaSource properties RegExp now can launder data Improved post to DOM transformation (multiple values a now supported) Added new axes to navigation queries: ancestor and descendant minor changes and bug fixes
author wizard
date Mon, 16 Aug 2010 08:26:44 +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;