File Coverage

inc/TestML/Compiler/Pegex/AST.pm
Criterion Covered Total %
statement 65 84 77.3
branch 14 26 53.8
condition 3 11 27.2
subroutine 16 21 76.1
pod 0 19 0.0
total 98 161 60.8


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         6  
4             extends 'Pegex::Tree';
5              
6 1     1   4 use TestML::Runtime;
  1         2  
  1         981  
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 3 my ($self, $code) = @_;
19 1         5 $self->function->{statements} = $code;
20             }
21              
22             sub got_assignment_statement {
23 4     4 0 5 my ($self, $match) = @_;
24 4         22 return TestML::Assignment->new(
25             name => $match->[0],
26             expr => $match->[1],
27             );
28             }
29              
30             sub got_code_statement {
31 4     4 0 6 my ($self, $list) = @_;
32 4         5 my ($expression, $assertion);
33 4         12 my $points = $self->points;
34 4         12 $self->{points} = [];
35              
36 4         11 for (@$list) {
37 8 100       17 if (ref eq 'TestML::Assertion') {
38 4         9 $assertion = $_;
39             }
40             else {
41             #if (ref eq 'TestML::Expression') {
42 4         5 $expression = $_;
43             }
44             }
45 4 50       45 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 16     16 0 21 my ($self, $list) = @_;
54 16         21 my $calls = [];
55 16 50       43 push @$calls, shift @$list if @$list;
56 16   50     32 $list = shift @$list || [];
57 16         28 for (@$list) {
58 4         8 my $call = $_->[0]; #->{call_call}[0][0];
59 4         12 push @$calls, $call;
60             }
61 16 100       67 return $calls->[0] if @$calls == 1;
62 4         17 return TestML::Expression->new(
63             calls => $calls,
64             );
65             }
66              
67             sub got_string_object {
68 8     8 0 12 my ($self, $string) = @_;
69 8         30 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 8     8 0 12 my ($self, $point) = @_;
89 8 50       35 $point =~ s/^\*// or die;
90 8         8 push @{$self->points}, $point;
  8         21  
91 8         27 return TestML::Point->new(
92             name => $point,
93             );
94             }
95              
96             sub got_assertion_call {
97 4     4 0 9 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 4 50       24 $call = $call->[0] if ref $call eq 'ARRAY';
101 4         4 my ($name, $expr);
102 4         12 for (qw( eq has ok )) {
103 4 50       16 if ($expr = $call->{"assertion_$_"}) {
104 4         9 $name = uc $_;
105 4   33     22 $expr =
106             $expr->{"assertion_operator_$_"}[0] ||
107             $expr->{"assertion_function_$_"}[0];
108 4         7 last;
109             }
110             }
111 4 50       33 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 4     4 0 9 my ($self, $name) = @_;
148 4         16 return TestML::Call->new(name => $name);
149             }
150              
151             sub got_call_object {
152 4     4 0 8 my ($self, $object) = @_;
153 4         6 my $call = $object->[0];
154 4         11 my $args = $object->[1][-1];
155 4 50       8 if ($args) {
156             $args = [
157             map {
158 4 50 33     8 ($_->isa('TestML::Expression') and @{$_->calls} == 1 and
  4         61  
159             (
160             $_->calls->[0]->isa('TestML::Point') ||
161             $_->calls->[0]->isa('TestML::Object')
162             )) ? $_->calls->[0] : $_;
163             } @$args
164             ];
165 4         16 $call->args($args)
166             }
167 4         17 return $call;
168             }
169              
170             sub got_call_argument_list {
171 4     4 0 7 my ($self, $list) = @_;
172 4         11 return $list;
173             }
174              
175             sub got_call_indicator {
176 4     4 0 6 my ($self) = @_;
177 4         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 3     3 0 6 my ($self, $block) = @_;
187 3         40 return TestML::Block->new(
188             label => $block->[0][0][0],
189 3         9 points => +{map %$_, @{$block->[1]}},
190             );
191             }
192              
193             sub got_block_point {
194 9     9 0 12 my ($self, $point) = @_;
195             return {
196 9         42 $point->[0] => $point->[1],
197             };
198             }
199              
200             1;