49
+ − 1 package IMPL::Text::Parser::Player;
+ − 2 use strict;
+ − 3 use warnings;
+ − 4
166
+ − 5 use parent qw(IMPL::Object);
49
+ − 6 use IMPL::Class::Property;
+ − 7 use IMPL::Class::Property::Direct;
+ − 8
+ − 9 use IMPL::Text::Parser::Chunk;
+ − 10
+ − 11 my %opCodesMap = (
+ − 12 IMPL::Text::Parser::Chunk::OP_REGEXP , &MatchRegexp ,
+ − 13 IMPL::Text::Parser::Chunk::OP_STRING , &MatchString ,
+ − 14 IMPL::Text::Parser::Chunk::OP_REFERENCE , &MatchReference ,
+ − 15 IMPL::Text::Parser::Chunk::OP_CHUNK , &PlayChunk ,
+ − 16 IMPL::Text::Parser::Chunk::OP_SWITCH , &MatchSwitch ,
+ − 17 IMPL::Text::Parser::Chunk::OP_REPEAT , &MatchRepeat
+ − 18 );
+ − 19
+ − 20 BEGIN {
+ − 21 private _direct property _data => prop_all;
+ − 22 private _direct property _current => prop_all;
+ − 23 private _direct property _states => prop_all;
+ − 24 private _direct property _document => prop_all;
+ − 25
+ − 26 public _direct property errorLast => prop_all;
+ − 27 public _direct property Punctuation => prop_all;
+ − 28 public _direct property Delimier => prop_all;
+ − 29 }
+ − 30
+ − 31 sub CTOR {
+ − 32 my ($this,$document) = @_;
+ − 33
+ − 34 $this->{$_document} = $document or die new IMPL::InvalidArgumentException("The first parameter must be a document");
+ − 35 }
+ − 36
+ − 37 sub LoadString {
+ − 38 my ($this,$string) = @_;
+ − 39
+ − 40 my $rxDelim = /(\s+|[.,;!-+*~$^&|%()`@\\\/])/;
+ − 41
+ − 42 my $line = 0;
+ − 43
+ − 44 $this->{$_data} = [
+ − 45 map {
+ − 46 $line++;
+ − 47 map {
+ − 48 [$line,$_]
+ − 49 } split $rxDelim, $_
+ − 50 } split /\n/, $string
+ − 51 ]
+ − 52 }
+ − 53
+ − 54 sub Play {
+ − 55 my ($this) = @_;
+ − 56 }
+ − 57
+ − 58 sub PlayChunk {
+ − 59 my ($this,$chunk) = @_;
+ − 60
+ − 61 my $end = 0;
+ − 62
+ − 63 my $name = $chunk->chunkName;
+ − 64
+ − 65 $this->enter($name) if $name;
+ − 66
+ − 67 foreach my $op ( @{$chunk->opStream} ) {
+ − 68 $this->leave(0) and return $this->error("no more data") if $end;
+ − 69
+ − 70 $opCodesMap{shift @$op}->(@$op) || return $this->leave(0) ;
+ − 71 $this->moveNext or $end = 1;
+ − 72 }
+ − 73
+ − 74 return $this->leave(1);
+ − 75 }
+ − 76
+ − 77 sub MatchRegexp {
+ − 78 my ($this,$rx) = @_;
+ − 79
+ − 80 $this->{$_current}{token} =~ $rx ? ($this->data() and return 1) : return $this->error("Expected: $rx");
+ − 81 }
+ − 82
+ − 83 sub MatchString {
+ − 84 my ($this,$string) = @_;
+ − 85
+ − 86 $this->{$_current}{token} eq $string ? ($this->data() and return 1) : return $this->error("Expected: $string");
+ − 87 }
+ − 88
+ − 89 sub MatchReference {
+ − 90 my ($this,$name) = @_;
+ − 91
+ − 92 my $chunk = $this->ResolveChunk($name) || return $this->error("Invalid reference: $name");
+ − 93 return $this->PlayChunk($chunk);
+ − 94 }
+ − 95
+ − 96 sub MatchSwitch {
+ − 97 my ($this,@chunks) = @_;
+ − 98
+ − 99 foreach my $chunk (@chunks) {
+ − 100 $this->save;
+ − 101 if ( $this->PlayChunk($chunk) ) {
+ − 102 $this->apply;
+ − 103 return 1;
+ − 104 } else {
+ − 105 $this->restore;
+ − 106 }
+ − 107 }
+ − 108
+ − 109 return 0; # passthrough last error
+ − 110 }
+ − 111
+ − 112 sub MatchRepeat {
+ − 113 my ($this,$chunk, $min, $max) = @_;
+ − 114
+ − 115 my $count = 0;
+ − 116
+ − 117 $this->save;
+ − 118 while (1) {
+ − 119 $this->save;
+ − 120 if ($this->PlayChunk($chunk)) {
+ − 121 $count ++;
+ − 122 $this->apply;
+ − 123 $this->apply and return 1 if ($count >= $max)
+ − 124 } else {
+ − 125 $this->restore;
+ − 126 $count >= $min ?
+ − 127 ($this->apply() and return 1) :
+ − 128 ($this->restore() and return $this->error("Expected at least $min occurances, got only $count"));
+ − 129 }
+ − 130 }
+ − 131
+ − 132 # we should never get here
+ − 133 die new IMPL::InvalidOperationException("unexpected error");
+ − 134 }
+ − 135
+ − 136 sub moveNext {
+ − 137 my ($this) = @_;
+ − 138
+ − 139 my $pos = $this->{$_current}{pos};
+ − 140
+ − 141 $pos ++;
+ − 142
+ − 143 if ($pos < @{$this->{$_data}}) {
+ − 144
+ − 145 $this->{$_current} = {
+ − 146 pos => $pos,
+ − 147 token => $this->{$_data}[$pos][1],
+ − 148 line => $this->{$_data}
+ − 149 };
+ − 150
+ − 151 } else {
+ − 152 $this->{$_current} = {};
+ − 153 return undef;
+ − 154 }
+ − 155 }
+ − 156
+ − 157 sub ResolveChunk {
+ − 158 my ($this,$name) = @_;
+ − 159 }
+ − 160
+ − 161 sub save {
+ − 162 my ($this) = @_;
+ − 163
+ − 164 push @{$this->{$_states}}, $this->{$_current};
+ − 165 }
+ − 166
+ − 167 sub restore {
+ − 168 my ($this) = @_;
+ − 169
+ − 170 $this->{$_current} = pop @{$this->{$_states}};
+ − 171 }
+ − 172
+ − 173 sub apply {
+ − 174 my ($this) = @_;
+ − 175
+ − 176 pop @{$this->{$_states}};
+ − 177 }
+ − 178
+ − 179 sub error {
+ − 180 my ($this,$message) = @_;
+ − 181
+ − 182 $this->{$errorLast} = {
+ − 183 message => $message,
+ − 184 line => $this->{$_current}{line},
+ − 185 token => $this->{$_current}{token}
+ − 186 };
+ − 187
+ − 188 return 0;
+ − 189 }
+ − 190
+ − 191 sub __debug {
+ − 192
+ − 193 }
+ − 194 sub enter {
+ − 195 my ($this,$name) = @_;
+ − 196
+ − 197 #always return true;
+ − 198 return 1;
+ − 199 }
+ − 200
+ − 201 sub leave {
+ − 202 my ($this,$isEmpty) = @_;
+ − 203
+ − 204 #always return true;
+ − 205 return 1;
+ − 206 }
+ − 207
+ − 208 sub data {
+ − 209 my ($this) = @_;
+ − 210
+ − 211 my $data = $this->{$_current}{token};
+ − 212
+ − 213 # always return true;
+ − 214 return 1;
+ − 215 }
+ − 216
+ − 217 1;