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