|
39
|
1 package IMPL::Text::Parser::Player;
|
|
|
2 use strict;
|
|
|
3 use warnings;
|
|
|
4
|
|
|
5 use base qw(IMPL::Object);
|
|
|
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;
|
|
40
|
22 private _direct property _current => prop_all;
|
|
41
|
23 private _direct property _states => prop_all;
|
|
|
24 private _direct property _document => prop_all;
|
|
|
25
|
|
|
26 public _direct property errorLast => prop_all;
|
|
39
|
27 public _direct property Punctuation => prop_all;
|
|
|
28 public _direct property Delimier => prop_all;
|
|
|
29 }
|
|
|
30
|
|
41
|
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
|
|
39
|
37 sub LoadString {
|
|
|
38 my ($this,$string) = @_;
|
|
|
39
|
|
40
|
40 my $rxDelim = /(\s+|[.,;!-+*~$^&|%()`@\\\/])/;
|
|
|
41
|
|
|
42 my $line = 0;
|
|
39
|
43
|
|
40
|
44 $this->{$_data} = [
|
|
|
45 map {
|
|
|
46 $line++;
|
|
|
47 map {
|
|
|
48 [$line,$_]
|
|
|
49 } split $rxDelim, $_
|
|
|
50 } split /\n/, $string
|
|
|
51 ]
|
|
39
|
52 }
|
|
|
53
|
|
41
|
54 sub Play {
|
|
|
55 my ($this) = @_;
|
|
|
56 }
|
|
|
57
|
|
39
|
58 sub PlayChunk {
|
|
|
59 my ($this,$chunk) = @_;
|
|
|
60
|
|
41
|
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);
|
|
39
|
75 }
|
|
|
76
|
|
|
77 sub MatchRegexp {
|
|
|
78 my ($this,$rx) = @_;
|
|
|
79
|
|
41
|
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 }
|
|
39
|
107 }
|
|
41
|
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");
|
|
39
|
134 }
|
|
|
135
|
|
40
|
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} = {
|
|
41
|
146 pos => $pos,
|
|
|
147 token => $this->{$_data}[$pos][1],
|
|
|
148 line => $this->{$_data}
|
|
40
|
149 };
|
|
|
150
|
|
|
151 } else {
|
|
41
|
152 $this->{$_current} = {};
|
|
40
|
153 return undef;
|
|
|
154 }
|
|
|
155 }
|
|
|
156
|
|
41
|
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
|
|
39
|
217 1;
|
