File Coverage

inc/TestML/Runtime.pm
Criterion Covered Total %
statement 206 268 76.8
branch 45 98 45.9
condition 7 21 33.3
subroutine 43 65 66.1
pod 0 17 0.0
total 301 469 64.1


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