File Coverage

inc/TestML/Compiler/Pegex.pm
Criterion Covered Total %
statement 34 34 100.0
branch 5 10 50.0
condition n/a
subroutine 7 7 100.0
pod 0 3 0.0
total 46 54 85.1


line stmt bran cond sub pod time code
1             package TestML::Compiler::Pegex;
2              
3 1     1   4 use TestML::Base;
  1         2  
  1         4  
4             extends 'TestML::Compiler';
5              
6 1     1   337 use TestML::Compiler::Pegex::Grammar;
  1         3  
  1         12  
7 1     1   366 use TestML::Compiler::Pegex::AST;
  1         3  
  1         41  
8 1     1   507 use Pegex::Parser;
  1         2  
  1         431  
9              
10             has parser => ();
11              
12             sub compile_code {
13 1     1 0 2 my ($self) = @_;
14              
15 1         9 $self->{parser} = Pegex::Parser->new(
16             grammar => TestML::Compiler::Pegex::Grammar->new,
17             receiver => TestML::Compiler::Pegex::AST->new,
18             );
19 1         4 $self->fixup_grammar;
20              
21 1 50       4 $self->parser->parse($self->code, 'code_section')
22             or die "Parse TestML code section failed";
23             }
24              
25             sub compile_data {
26 1     1 0 3 my ($self) = @_;
27              
28 1 50       10 if (length $self->data) {
29 1 50       12 $self->parser->parse($self->data, 'data_section')
30             or die "Parse TestML data section failed";
31             }
32              
33 1         6 $self->{function} = $self->parser->receiver->function;
34             }
35              
36             # TODO This can be moved to the AST some day.
37             sub fixup_grammar {
38 1     1 0 1 my ($self) = @_;
39              
40 1         5 my $tree = $self->{parser}->grammar->tree;
41              
42 1         7 my $point_lines = $tree->{point_lines}{'.rgx'};
43              
44 1         4 my $block_marker = $self->directives->{BlockMarker};
45 1 50       3 if ($block_marker) {
46 1         4 $block_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g;
47 1         20 $tree->{block_marker}{'.rgx'} = qr/\G$block_marker/;
48 1         6 $point_lines =~ s/===/$block_marker/;
49             }
50              
51 1         4 my $point_marker = $self->directives->{PointMarker};
52 1 50       3 if ($point_marker) {
53 1         8 $point_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g;
54 1         16 $tree->{point_marker}{'.rgx'} = qr/\G$point_marker/;
55 1         4 $point_lines =~ s/\\-\\-\\-/$point_marker/;
56             }
57              
58 1         29 $tree->{point_lines}{'.rgx'} = qr/$point_lines/;
59             }
60              
61             1;