File Coverage

blib/lib/TestML1/Compiler/Lite.pm
Criterion Covered Total %
statement 114 123 92.6
branch 51 70 72.8
condition 23 27 85.1
subroutine 12 13 92.3
pod 0 11 0.0
total 200 244 81.9


line stmt bran cond sub pod time code
1             package TestML1::Compiler::Lite;
2              
3 7     7   2938 use TestML1::Base;
  7         13  
  7         26  
4             extends 'TestML1::Compiler';
5              
6 7     7   1261 use TestML1::Runtime;
  7         12  
  7         11586  
7              
8             has input => ();
9             has points => ();
10             has tokens => ();
11             has function => ();
12              
13             my $WS = qr!\s+!;
14             my $ANY = qr!.!;
15             my $STAR = qr!\*!;
16             my $NUM = qr!-?[0-9]+!;
17             my $WORD = qr![-\w]+!;
18             my $HASH = qr!#!;
19             my $EQ = qr!=!;
20             my $TILDE = qr!~!;
21             my $LP = qr!\(!;
22             my $RP = qr!\)!;
23             my $DOT = qr!\.!;
24             my $COMMA = qr!,!;
25             my $SEMI = qr!;!;
26             my $SSTR = qr!'(?:[^']*)'!;
27             my $DSTR = qr!"(?:[^"]*)"!;
28             my $ENDING = qr!(?:$RP|$COMMA|$SEMI)!;
29              
30             my $POINT = qr!$STAR$WORD!;
31             my $QSTR = qr!(?:$SSTR|$DSTR)!;
32             my $COMP = qr!(?:$EQ$EQ|$TILDE$TILDE)!;
33             my $OPER = qr!(?:$COMP|$EQ)!;
34             my $PUNCT = qr!(?:$LP|$RP|$DOT|$COMMA|$SEMI)!;
35              
36             my $TOKENS = qr!(?:$POINT|$NUM|$WORD|$QSTR|$PUNCT|$OPER)!;
37              
38             our $block_marker = '===';
39             our $point_marker = '---';
40              
41             sub compile_code {
42 9     9 0 20 my ($self) = @_;
43 9         39 $self->{function} = TestML1::Function->new;
44 9         42 while (length $self->{code}) {
45 105         361 $self->{code} =~ s{^(.*)(\r\n|\n|)}{};
46 105         186 $self->{line} = $1;
47 105         170 $self->tokenize;
48 105 100       147 next if $self->done;
49 37 50 66     65 $self->parse_assignment ||
50             $self->parse_assertion ||
51             $self->fail;
52             }
53             }
54              
55             sub tokenize {
56 105     105 0 128 my ($self) = @_;
57 105         146 $self->{tokens} = [];
58 105         187 while (length $self->{line}) {
59 284 100       829 next if $self->{line} =~ s/^$WS//;
60 206 50       445 next if $self->{line} =~ s/^$HASH$ANY*//;
61 206 50       1453 if ($self->{line} =~ s/^($TOKENS)//) {
62 206         214 push @{$self->{tokens}}, $1;
  206         557  
63             }
64             else {
65 0         0 $self->fail("Failed to get token here: '$self->{line}'");
66             }
67             }
68             }
69              
70             sub parse_assignment {
71 37     37 0 47 my ($self) = @_;
72 37 100       58 return unless $self->peek(2) eq '=';
73 14         38 my ($var, $op) = $self->pop(2);
74 14         34 my $expr = $self->parse_expression;
75 14 100 66     25 $self->pop if not $self->done and $self->peek eq ';';
76 14 50       23 $self->fail unless $self->done;
77 14         19 push @{$self->function->statements},
  14         34  
78             TestML1::Assignment->new(name => $var, expr => $expr);
79 14         54 return 1;
80             }
81              
82             sub parse_assertion {
83 23     23 0 35 my ($self) = @_;
84 23 50       33 return unless grep /^$COMP$/, @{$self->tokens};
  23         50  
85 23         57 $self->{points} = [];
86 23         46 my $left = $self->parse_expression;
87 23         34 my $token = $self->pop;
88 23 50       63 my $op =
    100          
89             $token eq '==' ? 'EQ' :
90             $token eq '~~' ? 'HAS' :
91             $self->fail;
92 23         38 my $right = $self->parse_expression;
93 23 100 66     36 $self->pop if not $self->done and $self->peek eq ';';
94 23 50       33 $self->fail unless $self->done;
95              
96 23         42 push @{$self->function->statements}, TestML1::Statement->new(
97             expr => $left,
98             assert => TestML1::Assertion->new(
99             name => $op,
100             expr => $right,
101             ),
102 23 100       27 @{$self->points} ? (points => $self->points) : (),
  23         42  
103             );
104 23         81 return 1;
105             }
106              
107             sub parse_expression {
108 74     74 0 94 my ($self) = @_;
109              
110 74         82 my $calls = [];
111 74   100     104 while (not $self->done and $self->peek !~ /^($ENDING|$COMP)$/) {
112 99         169 my $token = $self->pop;
113 99 100       1245 if ($token =~ /^$NUM$/) {
    100          
    100          
    50          
114 9         56 push @$calls, TestML1::Num->new(value => $token + 0);
115             }
116             elsif ($token =~/^$QSTR$/) {
117 21         44 my $str = substr($token, 1, length($token) - 2);
118 21         53 push @$calls, TestML1::Str->new(value => $str);
119             }
120             elsif ($token =~ /^$WORD$/) {
121 33         94 my $call = TestML1::Call->new(name => $token);
122 33 100 100     53 if (not $self->done and $self->peek eq '(') {
123 10         20 $call->{args} = $self->parse_args;
124             }
125 33         48 push @$calls, $call;
126             }
127             elsif ($token =~ /^$POINT$/) {
128 36 50       287 $token =~ /($WORD)/ or die;
129 36         72 $token = $1;
130 36         52 $token =~ s/-/_/g;
131 36         39 push @{$self->{points}}, $token;
  36         58  
132 36         130 push @$calls, TestML1::Point->new(name => $token);
133             }
134             else {
135 0         0 $self->fail("Unknown token '$token'");
136             }
137 99 100 100     147 if (not $self->done and $self->peek eq '.') {
138 25         37 $self->pop;
139             }
140             }
141 74 100       198 return @$calls == 1
142             ? $calls->[0]
143             : TestML1::Expression->new(calls => $calls);
144             }
145              
146             sub parse_args {
147 10     10 0 14 my ($self) = @_;
148 10 50       16 $self->pop eq '(' or die;
149 10         16 my $args = [];
150 10         18 while ($self->peek ne ')') {
151 14         37 push @$args, $self->parse_expression;
152 14 100       20 $self->pop if $self->peek eq ',';
153             }
154 10         24 $self->pop;
155 10         25 return $args;
156             }
157              
158             sub compile_data {
159 9     9 0 16 my ($self) = @_;
160 9         48 my $input = $self->data;
161 9         26 $input =~ s/^#.*\n/\n/mg;
162 9         236 my @blocks = grep $_, split /(^$block_marker.*?(?=^$block_marker|\z))/ms, $input;
163 9         25 for my $block (@blocks) {
164 12         63 $block =~ s/\n+\z/\n/;
165             }
166              
167 9         17 my $data = [];
168 9         16 for my $string_block (@blocks) {
169 12         46 my $block = TestML1::Block->new;
170 12 50       125 $string_block =~ s/^$block_marker\ +(.*?)\ *\n//g
171             or die "No block label! $string_block";
172 12         46 $block->{label} = $1;
173 12         99 $string_block =~ s/\A(.*?)(^$point_marker\ )/$2/sm;
174 12         32 while (length $string_block) {
175 32 50       66 next if $string_block =~ s/^\n+//;
176 32         36 my ($key, $value);
177 32 50 66     491 if ($string_block =~ s/\A$point_marker\ +($WORD):\ +(.*)\n//g or
178             $string_block =~
179             s/\A$point_marker\ +($WORD)\n(.*?)(?=^$point_marker|\z)//msg
180             ) {
181 32         74 ($key, $value) = ($1, $2);
182 32         42 $key =~ s/-/_/g;
183             }
184             else {
185 0         0 die "Failed to parse TestML1 string:\n$string_block";
186             }
187 32   100     87 $block->{points} ||= {};
188 32 100       66 my $eol = ($value =~ s/(\r?\n)\s*\z//) ? $1 : '';
189 32 50       51 if (length $value) {
190 32         40 $value .= $eol;
191             }
192 32         53 $block->{points}{$key} = $value;
193              
194 32 50       81 if ($key =~ /^(ONLY|SKIP|LAST)$/) {
195 0         0 $block->{$key} = 1;
196             }
197             }
198 12         30 push @$data, $block;
199             }
200 9 100       35 $self->function->{data} = $data if @$data;
201             }
202              
203             sub done {
204 484     484 0 564 my ($self) = @_;
205 484 100       405 @{$self->{tokens}} ? 0 : 1
  484         1181  
206             }
207              
208             sub peek {
209 323     323 0 424 my ($self, $index) = @_;
210 323   100     691 $index ||= 1;
211 323 50       275 die if $index > @{$self->{tokens}};
  323         451  
212 323         1273 $self->{tokens}->[$index - 1];
213             }
214              
215             sub pop {
216 192     192 0 243 my ($self, $count) = @_;
217 192   100     420 $count ||= 1;
218 192 50       176 die if $count > @{$self->{tokens}};
  192         280  
219 192         181 splice @{$self->{tokens}}, 0, $count;
  192         336  
220             }
221              
222             sub fail {
223 0     0 0   my ($self, $message) = @_;
224 0           my $text = "Failed to compile TestML1 document.\n";
225 0 0         $text .= "Reason: $message\n" if $message;
226 0           $text .= "\nCode section of failure:\n$self->{line}\n$self->{code}\n";
227 0           die $text;
228             }
229              
230             1;