File Coverage

inc/TestML/Compiler/Pegex/AST.pm
Criterion Covered Total %
statement 56 84 66.6
branch 13 26 50.0
condition 2 11 18.1
subroutine 13 21 61.9
pod 0 19 0.0
total 84 161 52.1


line stmt bran cond sub pod time code
1             package TestML::Compiler::Pegex::AST;
2              
3 1     1   6 use TestML::Base;
  1         2  
  1         8  
4             extends 'Pegex::Tree';
5              
6 1     1   6 use TestML::Runtime;
  1         2  
  1         1509  
7              
8             has points => [];
9             has function => sub { TestML::Function->new };
10              
11             # sub final {
12             # my ($self, $match, $top) = @_;
13             # XXX $match;
14             # }
15             # __END__
16              
17             sub got_code_section {
18 1     1 0 1222 my ($self, $code) = @_;
19 1         7 $self->function->{statements} = $code;
20             }
21              
22             sub got_assignment_statement {
23 0     0 0 0 my ($self, $match) = @_;
24 0         0 return TestML::Assignment->new(
25             name => $match->[0],
26             expr => $match->[1],
27             );
28             }
29              
30             sub got_code_statement {
31 1     1 0 114 my ($self, $list) = @_;
32 1         3 my ($expression, $assertion);
33 1         4 my $points = $self->points;
34 1         4 $self->{points} = [];
35              
36 1         3 for (@$list) {
37 2 100       10 if (ref eq 'TestML::Assertion') {
38 1         3 $assertion = $_;
39             }
40             else {
41             #if (ref eq 'TestML::Expression') {
42 1         4 $expression = $_;
43             }
44             }
45 1 50       41 return TestML::Statement->new(
    50          
    50          
46             $expression ? ( expr => $expression ) : (),
47             $assertion ? ( assert => $assertion ) : (),
48             @$points ? ( points => $points ) : (),
49             );
50             }
51              
52             sub got_code_expression {
53 2     2 0 445 my ($self, $list) = @_;
54 2         5 my $calls = [];
55 2 50       8 push @$calls, shift @$list if @$list;
56 2   50     6 $list = shift @$list || [];
57 2         5 for (@$list) {
58 2         5 my $call = $_->[0]; #->{call_call}[0][0];
59 2         4 push @$calls, $call;
60             }
61 2 100       12 return $calls->[0] if @$calls == 1;
62 1         8 return TestML::Expression->new(
63             calls => $calls,
64             );
65             }
66              
67             sub got_string_object {
68 0     0 0 0 my ($self, $string) = @_;
69 0         0 return TestML::Str->new(
70             value => $string,
71             );
72             }
73              
74             sub got_double_quoted_string {
75 0     0 0 0 my ($self, $string) = @_;
76 0         0 $string =~ s/\\n/\n/g;
77 0         0 return $string;
78             }
79              
80             sub got_number_object {
81 0     0 0 0 my ($self, $number) = @_;
82 0         0 return TestML::Num->new(
83             value => $number + 0,
84             );
85             }
86              
87             sub got_point_object {
88 2     2 0 8767 my ($self, $point) = @_;
89 2 50       14 $point =~ s/^\*// or die;
90 2         4 push @{$self->points}, $point;
  2         10  
91 2         25 return TestML::Point->new(
92             name => $point,
93             );
94             }
95              
96             sub got_assertion_call {
97 1     1 0 126 my ($self, $call) = @_;
98             # XXX $call strangley becomes an array when $PERL_PEGEX_DEBUG is on.
99             # Workaround for now, until I figure it out.
100 1 50       5 $call = $call->[0] if ref $call eq 'ARRAY';
101 1         3 my ($name, $expr);
102 1         3 for (qw( eq has ok )) {
103 1 50       6 if ($expr = $call->{"assertion_$_"}) {
104 1         4 $name = uc $_;
105 1   33     12 $expr =
106             $expr->{"assertion_operator_$_"}[0] ||
107             $expr->{"assertion_function_$_"}[0];
108 1         3 last;
109             }
110             }
111 1 50       12 return TestML::Assertion->new(
112             name => $name,
113             $expr ? (expr => $expr) : (),
114             );
115             }
116              
117             sub got_assertion_function_ok {
118 0     0 0 0 my ($self, $ok) = @_;
119             return {
120 0         0 assertion_function_ok => [],
121             }
122             }
123              
124             sub got_function_start {
125 0     0 0 0 my ($self) = @_;
126 0         0 my $function = TestML::Function->new;
127 0         0 $function->outer($self->function);
128 0         0 $self->{function} = $function;
129 0         0 return 1;
130             }
131              
132             sub got_function_object {
133 0     0 0 0 my ($self, $object) = @_;
134              
135 0         0 my $function = $self->function;
136 0         0 $self->{function} = $function->outer;
137              
138 0 0 0     0 if (ref($object->[0]) and ref($object->[0][0])) {
139 0         0 $function->{signature} = $object->[0][0];
140             }
141 0         0 $function->{statements} = $object->[-1];
142              
143 0         0 return $function;
144             }
145              
146             sub got_call_name {
147 2     2 0 991 my ($self, $name) = @_;
148 2         13 return TestML::Call->new(name => $name);
149             }
150              
151             sub got_call_object {
152 2     2 0 160 my ($self, $object) = @_;
153 2         3 my $call = $object->[0];
154 2         9 my $args = $object->[1][-1];
155 2 50       5 if ($args) {
156             $args = [
157             map {
158 0 0 0     0 ($_->isa('TestML::Expression') and @{$_->calls} == 1 and
  0         0  
159             (
160             $_->calls->[0]->isa('TestML::Point') ||
161             $_->calls->[0]->isa('TestML::Object')
162             )) ? $_->calls->[0] : $_;
163             } @$args
164             ];
165 0         0 $call->args($args)
166             }
167 2         7 return $call;
168             }
169              
170             sub got_call_argument_list {
171 0     0 0 0 my ($self, $list) = @_;
172 0         0 return $list;
173             }
174              
175             sub got_call_indicator {
176 2     2 0 282 my ($self) = @_;
177 2         7 return;
178             }
179              
180             sub got_data_section {
181 1     1 0 117 my ($self, $data) = @_;
182 1         8 $self->function->data($data);
183             }
184              
185             sub got_data_block {
186 15     15 0 3252 my ($self, $block) = @_;
187 15         155 return TestML::Block->new(
188             label => $block->[0][0][0],
189 15         33 points => +{map %$_, @{$block->[1]}},
190             );
191             }
192              
193             sub got_block_point {
194 30     30 0 21925 my ($self, $point) = @_;
195             return {
196 30         181 $point->[0] => $point->[1],
197             };
198             }
199              
200             1;