File Coverage

inc/TestML/Runtime.pm
Criterion Covered Total %
statement 195 262 74.4
branch 46 104 44.2
condition 10 21 47.6
subroutine 40 63 63.4
pod 0 17 0.0
total 291 467 62.3


line stmt bran cond sub pod time code
1             package TestML::Runtime;
2              
3 4     4   16 use TestML::Base;
  4         5  
  4         18  
4              
5             has testml => ();
6             has bridge => ();
7             has library => ();
8             has compiler => ();
9             has skip => ();
10              
11             has function => ();
12             has error => ();
13             has global => ();
14             has base => ();
15              
16             sub BUILD {
17 4     4 0 8 my ($self) = @_;
18 4         11 $TestML::Runtime::Singleton = $self;
19 4 50 33     136 $self->{base} ||= $0 =~ m!(.*)/! ? $1 : ".";
20             }
21              
22             sub run {
23 4     4 0 8 my ($self) = @_;
24 4         32 $self->compile_testml;
25 4         962 $self->initialize_runtime;
26 4         66 $self->run_function($self->{function}, []);
27             }
28              
29             # TODO Functions should have return values
30             sub run_function {
31 4     4 0 12 my ($self, $function, $args) = @_;
32              
33 4         35 $self->apply_signature($function, $args);
34              
35 4         12 my $parent = $self->function;
36 4         12 $self->{function} = $function;
37              
38 4         8 for my $statement (@{$function->statements}) {
  4         14  
39 8 100       31 if (ref($statement) eq 'TestML::Assignment') {
40 4         35 $self->run_assignment($statement);
41             }
42             else {
43 4         40 $self->run_statement($statement);
44             }
45             }
46 4         1804 $self->{function} = $parent;
47 4         18 return;
48             }
49              
50             sub apply_signature {
51 4     4 0 9 my ($self, $function, $args) = @_;
52 4         22 my $signature = $function->signature;
53              
54 4 50 33     25 die sprintf(
55             "Function received %d args but expected %d",
56             scalar(@$args),
57             scalar(@$signature),
58             ) if @$signature and @$args != @$signature;
59              
60 4         18 $function->setvar('Self', $function);
61 4         22 for (my $i = 0; $i < @$signature; $i++) {
62 0         0 my $arg = $args->[$i];
63 0 0       0 $arg = $self->run_expression($arg)
64             if ref($arg) eq 'TestML::Expression';
65 0         0 $function->setvar($signature->[$i], $arg);
66             }
67             }
68              
69             sub run_statement {
70 4     4 0 9 my ($self, $statement) = @_;
71 4   50     16 my $blocks = $self->select_blocks($statement->points || []);
72 4         12 for my $block (@$blocks) {
73 6 50       1597 $self->function->setvar('Block', $block) if $block != 1;
74 6         23 my $result = $self->run_expression($statement->expr);
75 6 50       123 if (my $assert = $statement->assert) {
76 6         68 $self->run_assertion($result, $assert);
77             }
78             }
79             }
80              
81             sub run_assignment {
82 4     4 0 10 my ($self, $assignment) = @_;
83 4         14 $self->function->setvar(
84             $assignment->name,
85             $self->run_expression($assignment->expr),
86             );
87             }
88              
89             sub run_assertion {
90 6     6 0 24 my ($self, $left, $assert) = @_;
91 6         46 my $method = 'assert_' . $assert->name;
92              
93 6         40 $self->function->getvar('TestNumber')->{value}++;
94              
95 6 50       33 if ($assert->expr) {
96 6         36 $self->$method($left, $self->run_expression($assert->expr));
97             }
98             else {
99 0         0 $self->$method($left);
100             }
101             }
102              
103             sub run_expression {
104 16     16 0 28 my ($self, $expr) = @_;
105              
106 16         24 my $context = undef;
107 16         4392 $self->{error} = undef;
108 16 100       175 if ($expr->isa('TestML::Expression')) {
109 6         9 my @calls = @{$expr->calls};
  6         24  
110 6 50       21 die if @calls <= 1;
111 6         26 $context = $self->run_call(shift(@calls));
112 6         15 for my $call (@calls) {
113 9 50       31 if ($self->error) {
114             next unless
115 0 0 0     0 $call->isa('TestML::Call') and
116             $call->name eq 'Catch';
117             }
118 9         29 $context = $self->run_call($call, $context);
119             }
120             }
121             else {
122 10         42 $context = $self->run_call($expr);
123             }
124 16 50       125 if ($self->error) {
125 0         0 die $self->error;
126             }
127 16         153 return $context;
128             }
129              
130             sub run_call {
131 25     25 0 37 my ($self, $call, $context) = @_;
132              
133 25 100       171 if ($call->isa('TestML::Object')) {
134 4         53 return $call;
135             }
136 21 50       125 if ($call->isa('TestML::Function')) {
137 0         0 return $call;
138             }
139 21 100       102 if ($call->isa('TestML::Point')) {
140 9         50 return $self->get_point($call->name);
141             }
142 12 50       46 if ($call->isa('TestML::Call')) {
143 12         48 my $name = $call->name;
144 12   50     37 my $callable =
145             $self->function->getvar($name) ||
146             $self->lookup_callable($name) ||
147             die "Can't locate '$name' callable";
148 12 50       98 if ($callable->isa('TestML::Object')) {
149 0         0 return $callable;
150             }
151 12 50 66     57 return $callable unless $call->args or defined $context;
152 12   100     53 $call->{args} ||= [];
153 12         16 my $args = [map $self->run_expression($_), @{$call->args}];
  12         30  
154 12 100       46 unshift @$args, $context if $context;
155 12 50       54 if ($callable->isa('TestML::Callable')) {
156 12         23 my $value = eval { $callable->value->(@$args) };
  12         37  
157 12 50       166 if ($@) {
158 0         0 $self->{error} = $@;
159 0         0 return TestML::Error->new(value => $@);
160             }
161 12 50       484 die "'$name' did not return a TestML::Object object"
162             unless UNIVERSAL::isa($value, 'TestML::Object');
163 12         237 return $value;
164             }
165 0 0       0 if ($callable->isa('TestML::Function')) {
166 0         0 return $self->run_function($callable, $args);
167             }
168 0         0 die;
169             }
170 0         0 die;
171             }
172              
173             sub lookup_callable {
174 6     6 0 19 my ($self, $name) = @_;
175 6         15 for my $library (@{$self->function->getvar('Library')->value}) {
  6         36  
176 7 100       68 if ($library->can($name)) {
177 6     12   44 my $function = sub { $library->$name(@_) };
  12         89  
178 6         44 my $callable = TestML::Callable->new(value => $function);
179 6         25 $self->function->setvar($name, $callable);
180 6         60 return $callable;
181             }
182             }
183 0         0 return;
184             }
185              
186             sub get_point {
187 9     9 0 30 my ($self, $name) = @_;
188 9         44 my $value = $self->function->getvar('Block')->{points}{$name};
189 9 50       138 defined $value or return;
190 9 50 66     232 if ($value =~ s/\n+\z/\n/ and $value eq "\n") {
191 0         0 $value = '';
192             }
193 9         27 $value =~ s/^\\//gm;
194 9         41 return TestML::Str->new(value => $value);
195             }
196              
197             sub select_blocks {
198 4     4 0 7 my ($self, $wanted) = @_;
199 4 50       14 return [1] unless @$wanted;
200 4         8 my $selected = [];
201              
202 4         6 OUTER: for my $block (@{$self->function->data}) {
  4         20  
203 6         9 my %points = %{$block->points};
  6         23  
204 6 50       26 next if exists $points{SKIP};
205 6 50       15 if (exists $points{ONLY}) {
206 0         0 for my $point (@$wanted) {
207 0 0       0 return [] unless exists $points{$point};
208             }
209 0         0 $selected = [$block];
210 0         0 last;
211             }
212 6         14 for my $point (@$wanted) {
213 9 50       31 next OUTER unless exists $points{$point};
214             }
215 6         12 push @$selected, $block;
216 6 50       25 last if exists $points{LAST};
217             }
218 4         12 return $selected;
219             }
220              
221             sub compile_testml {
222 4     4 0 8 my ($self) = @_;
223              
224 4 50       32 die "'testml' document required but not found"
225             unless $self->testml;
226 4 50       17 if ($self->testml !~ /\n/) {
227 0 0       0 $self->testml =~ /(?:(.*)\/)?(.*)/ or die;
228 0         0 $self->{testml} = $2;
229 0 0       0 $self->{base} .= '/' . $1 if $1;
230 0         0 $self->{testml} = $self->read_testml_file($self->testml);
231             }
232 4 50       43 $self->{function} = $self->compiler->new->compile($self->testml)
233             or die "TestML document failed to compile";
234             }
235              
236             sub initialize_runtime {
237 4     4 0 13 my ($self) = @_;
238              
239 4         29 $self->{global} = $self->function->outer;
240              
241 4         25 $self->{global}->setvar(Block => TestML::Block->new);
242 4         29 $self->{global}->setvar(Label => TestML::Str->new(value => '$BlockLabel'));
243 4         18 $self->{global}->setvar(True => $TestML::Constant::True);
244 4         16 $self->{global}->setvar(False => $TestML::Constant::False);
245 4         17 $self->{global}->setvar(None => $TestML::Constant::None);
246 4         28 $self->{global}->setvar(TestNumber => TestML::Num->new(value => 0));
247 4         36 $self->{global}->setvar(Library => TestML::List->new);
248              
249 4         16 my $library = $self->function->getvar('Library');
250 4         32 for my $lib ($self->bridge, $self->library) {
251 8 100       27 if (ref($lib) eq 'ARRAY') {
252 4         39 $library->push($_->new) for @$lib;
253             }
254             else {
255 4         43 $library->push($lib->new);
256             }
257             }
258             }
259              
260             sub get_label {
261 6     6 0 18 my ($self) = @_;
262 6 50       20 my $label = $self->function->getvar('Label') or return;
263 6 50       26 $label = $label->value or return;
264 6         81 $label =~ s/\$(\w+)/$self->replace_label($1)/ge;
  6         82  
265 6         53 return $label;
266             }
267              
268             sub replace_label {
269 6     6 0 63 my ($self, $var) = @_;
270 6         54 my $block = $self->function->getvar('Block');
271 6 50       82 return $block->label if $var eq 'BlockLabel';
272 0 0       0 if (my $v = $block->points->{$var}) {
273 0         0 $v =~ s/\n.*//s;
274 0         0 $v =~ s/^\s*(.*?)\s*$/$1/;
275 0         0 return $v;
276             }
277 0 0       0 if (my $v = $self->function->getvar($var)) {
278 0         0 return $v->value;
279             }
280             }
281              
282             sub read_testml_file {
283 0     0 0 0 my ($self, $file) = @_;
284 0         0 my $path = $self->base . '/' . $file;
285 0 0       0 open my $fh, $path
286             or die "Can't open '$path' for input: $!";
287 0         0 local $/;
288 0         0 return <$fh>;
289             }
290              
291             #-----------------------------------------------------------------------------
292             package TestML::Function;
293              
294 4     4   33 use TestML::Base;
  4         7  
  4         20  
295              
296             has type => 'Func'; # Functions are TestML typed objects
297             has signature => []; # Input variable names
298             has namespace => {}; # Lexical scoped variable stash
299             has statements => []; # Exexcutable code statements
300             has data => []; # Data section scoped to this function
301              
302             my $outer = {};
303 50 100   50   294 sub outer { @_ == 1 ? $outer->{$_[0]} : ($outer->{$_[0]} = $_[1]) }
304              
305             sub getvar {
306 57     57   110 my ($self, $name) = @_;
307 57         148 while ($self) {
308 89 100       197 if (my $object = $self->namespace->{$name}) {
309 47         271 return $object;
310             }
311 42         372 $self = $self->outer;
312             }
313 10         96 undef;
314             }
315              
316             sub setvar {
317 48     48   76 my ($self, $name, $value) = @_;
318 48         102 $self->namespace->{$name} = $value;
319             }
320              
321             sub forgetvar {
322 0     0   0 my ($self, $name) = @_;
323 0         0 delete $self->namespace->{$name};
324             }
325              
326             #-----------------------------------------------------------------------------
327             package TestML::Assignment;
328              
329 4     4   22 use TestML::Base;
  4         6  
  4         16  
330              
331             has name => ();
332             has expr => ();
333              
334             #-----------------------------------------------------------------------------
335             package TestML::Statement;
336              
337 4     4   19 use TestML::Base;
  4         9  
  4         20  
338              
339             has expr => ();
340             has assert => ();
341             has points => ();
342              
343             #-----------------------------------------------------------------------------
344             package TestML::Expression;
345              
346 4     4   18 use TestML::Base;
  4         7  
  4         11  
347              
348             has calls => [];
349              
350             #-----------------------------------------------------------------------------
351             package TestML::Assertion;
352              
353 4     4   18 use TestML::Base;
  4         7  
  4         13  
354              
355             has name => ();
356             has expr => ();
357              
358             #-----------------------------------------------------------------------------
359             package TestML::Call;
360              
361 4     4   21 use TestML::Base;
  4         6  
  4         15  
362              
363             has name => ();
364             has args => ();
365              
366             #-----------------------------------------------------------------------------
367             package TestML::Callable;
368              
369 4     4   20 use TestML::Base;
  4         8  
  4         40  
370             has value => ();
371              
372             #-----------------------------------------------------------------------------
373             package TestML::Block;
374              
375 4     4   18 use TestML::Base;
  4         6  
  4         13  
376              
377             has label => '';
378             has points => {};
379              
380             #-----------------------------------------------------------------------------
381             package TestML::Point;
382              
383 4     4   26 use TestML::Base;
  4         7  
  4         16  
384              
385             has name => ();
386              
387             #-----------------------------------------------------------------------------
388             package TestML::Object;
389              
390 4     4   22 use TestML::Base;
  4         5  
  4         16  
391              
392             has value => ();
393              
394             sub type {
395 0     0   0 my $type = ref($_[0]);
396 0 0       0 $type =~ s/^TestML::// or die "Can't find type of '$type'";
397 0         0 return $type;
398             }
399              
400 0     0   0 sub str { die "Cast from ${\ $_[0]->type} to Str is not supported" }
  0         0  
401 0     0   0 sub num { die "Cast from ${\ $_[0]->type} to Num is not supported" }
  0         0  
402 0     0   0 sub bool { die "Cast from ${\ $_[0]->type} to Bool is not supported" }
  0         0  
403 0     0   0 sub list { die "Cast from ${\ $_[0]->type} to List is not supported" }
  0         0  
404 0     0   0 sub none { $TestML::Constant::None }
405              
406             #-----------------------------------------------------------------------------
407             package TestML::Str;
408              
409 4     4   25 use TestML::Base;
  4         6  
  4         20  
410             extends 'TestML::Object';
411              
412 15     15   61 sub str { $_[0] }
413 0 0   0   0 sub num { TestML::Num->new(
414             value => ($_[0]->value =~ /^-?\d+(?:\.\d+)$/ ? ($_[0]->value + 0) : 0),
415             )}
416             sub bool {
417 0 0   0   0 length($_[0]->value) ? $TestML::Constant::True : $TestML::Constant::False
418             }
419 0     0   0 sub list { TestML::List->new(value => [split //, $_[0]->value]) }
420              
421             #-----------------------------------------------------------------------------
422             package TestML::Num;
423              
424 4     4   157 use TestML::Base;
  4         7  
  4         17  
425             extends 'TestML::Object';
426              
427 0     0   0 sub str { TestML::Str->new(value => $_[0]->value . "") }
428 0     0   0 sub num { $_[0] }
429 0 0   0   0 sub bool { ($_[0]->value != 0) ? $TestML::Constant::True : $TestML::Constant::False }
430             sub list {
431 0     0   0 my $list = [];
432 0         0 $#{$list} = int($_[0]) -1;
  0         0  
433 0         0 TestML::List->new(value =>$list);
434             }
435              
436             #-----------------------------------------------------------------------------
437             package TestML::Bool;
438              
439 4     4   24 use TestML::Base;
  4         8  
  4         17  
440             extends 'TestML::Object';
441              
442 0 0   0   0 sub str { TestML::Str->new(value => $_[0]->value ? "1" : "") }
443 0 0   0   0 sub num { TestML::Num->new(value => $_[0]->value ? 1 : 0) }
444 0     0   0 sub bool { $_[0] }
445              
446             #-----------------------------------------------------------------------------
447             package TestML::List;
448              
449 4     4   25 use TestML::Base;
  4         7  
  4         22  
450             extends 'TestML::Object';
451             has value => [];
452 0     0   0 sub list { $_[0] }
453             sub push {
454 12     12   15 my ($self, $elem) = @_;
455 12         15 push @{$self->value}, $elem;
  12         28  
456             }
457              
458             #-----------------------------------------------------------------------------
459             package TestML::None;
460              
461 4     4   21 use TestML::Base;
  4         8  
  4         14  
462             extends 'TestML::Object';
463              
464 0     0     sub str { TestML::Str->new(value => '') }
465 0     0     sub num { TestML::Num->new(value => 0) }
466 0     0     sub bool { $TestML::Constant::False }
467 0     0     sub list { TestML::List->new(value => []) }
468              
469             #-----------------------------------------------------------------------------
470             package TestML::Native;
471              
472 4     4   24 use TestML::Base;
  4         6  
  4         26  
473             extends 'TestML::Object';
474              
475             #-----------------------------------------------------------------------------
476             package TestML::Error;
477              
478 4     4   22 use TestML::Base;
  4         5  
  4         19  
479             extends 'TestML::Object';
480              
481             #-----------------------------------------------------------------------------
482             package TestML::Constant;
483              
484             our $True = TestML::Bool->new(value => 1);
485             our $False = TestML::Bool->new(value => 0);
486             our $None = TestML::None->new;
487              
488             1;