File Coverage

inc/TestML/Compiler/Pegex/AST.pm
Criterion Covered Total %
statement 65 84 77.3
branch 13 26 50.0
condition 2 11 18.1
subroutine 17 21 80.9
pod 0 19 0.0
total 97 161 60.2


line stmt bran cond sub pod time code
1             package TestML::Compiler::Pegex::AST;
2              
3 1     1   4 use TestML::Base;
  1         1  
  1         5  
4             extends 'Pegex::Tree';
5              
6 1     1   4 use TestML::Runtime;
  1         1  
  1         926  
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 2 my ($self, $code) = @_;
19 1         8 $self->function->{statements} = $code;
20             }
21              
22             sub got_assignment_statement {
23 2     2 0 3 my ($self, $match) = @_;
24 2         14 return TestML::Assignment->new(
25             name => $match->[0],
26             expr => $match->[1],
27             );
28             }
29              
30             sub got_code_statement {
31 1     1 0 2 my ($self, $list) = @_;
32 1         3 my ($expression, $assertion);
33 1         5 my $points = $self->points;
34 1         4 $self->{points} = [];
35              
36 1         3 for (@$list) {
37 2 100       7 if (ref eq 'TestML::Assertion') {
38 1         4 $assertion = $_;
39             }
40             else {
41             #if (ref eq 'TestML::Expression') {
42 1         3 $expression = $_;
43             }
44             }
45 1 50       32 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 4     4 0 8 my ($self, $list) = @_;
54 4         7 my $calls = [];
55 4 50       17 push @$calls, shift @$list if @$list;
56 4   50     17 $list = shift @$list || [];
57 4         11 for (@$list) {
58 3         9 my $call = $_->[0]; #->{call_call}[0][0];
59 3         8 push @$calls, $call;
60             }
61 4 100       27 return $calls->[0] if @$calls == 1;
62 2         15 return TestML::Expression->new(
63             calls => $calls,
64             );
65             }
66              
67             sub got_string_object {
68 1     1 0 2 my ($self, $string) = @_;
69 1         7 return TestML::Str->new(
70             value => $string,
71             );
72             }
73              
74             sub got_double_quoted_string {
75 1     1 0 2 my ($self, $string) = @_;
76 1         2 $string =~ s/\\n/\n/g;
77 1         4 return $string;
78             }
79              
80             sub got_number_object {
81 1     1 0 7 my ($self, $number) = @_;
82 1         11 return TestML::Num->new(
83             value => $number + 0,
84             );
85             }
86              
87             sub got_point_object {
88 2     2 0 5 my ($self, $point) = @_;
89 2 50       12 $point =~ s/^\*// or die;
90 2         4 push @{$self->points}, $point;
  2         12  
91 2         12 return TestML::Point->new(
92             name => $point,
93             );
94             }
95              
96             sub got_assertion_call {
97 1     1 0 4 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       7 $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       7 if ($expr = $call->{"assertion_$_"}) {
104 1         6 $name = uc $_;
105 1   33     16 $expr =
106             $expr->{"assertion_operator_$_"}[0] ||
107             $expr->{"assertion_function_$_"}[0];
108 1         2 last;
109             }
110             }
111 1 50       13 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 3     3 0 6 my ($self, $name) = @_;
148 3         13 return TestML::Call->new(name => $name);
149             }
150              
151             sub got_call_object {
152 3     3 0 7 my ($self, $object) = @_;
153 3         4 my $call = $object->[0];
154 3         8 my $args = $object->[1][-1];
155 3 50       7 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 3         13 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 3     3 0 4 my ($self) = @_;
177 3         12 return;
178             }
179              
180             sub got_data_section {
181 1     1 0 3 my ($self, $data) = @_;
182 1         5 $self->function->data($data);
183             }
184              
185             sub got_data_block {
186 7     7 0 8 my ($self, $block) = @_;
187 7         41 return TestML::Block->new(
188             label => $block->[0][0][0],
189 7         11 points => +{map %$_, @{$block->[1]}},
190             );
191             }
192              
193             sub got_block_point {
194 7     7 0 8 my ($self, $point) = @_;
195             return {
196 7         29 $point->[0] => $point->[1],
197             };
198             }
199              
200             1;