File Coverage

inc/TestML/Compiler.pm
Criterion Covered Total %
statement 53 59 89.8
branch 25 38 65.7
condition 3 6 50.0
subroutine 4 4 100.0
pod 0 2 0.0
total 85 109 77.9


line stmt bran cond sub pod time code
1 1     1   4 use TestML::Runtime;
  1         1  
  1         33  
2              
3             package TestML::Compiler;
4              
5 1     1   4 use TestML::Base;
  1         2  
  1         5  
6              
7             has code => ();
8             has data => ();
9             has text => ();
10             has directives => ();
11             has function => ();
12              
13             sub compile {
14 1     1 0 2 my ($self, $input) = @_;
15              
16 1         4 $self->preprocess($input, 'top');
17 1         5 $self->compile_code;
18 1         6 $self->compile_data;
19              
20 1 50       5 if ($self->directives->{DumpAST}) {
21 0         0 XXX($self->function);
22             }
23              
24 1         3 $self->function->namespace->{TestML} = $self->directives->{TestML};
25              
26 1         2 $self->function->outer(TestML::Function->new);
27 1         3 return $self->function;
28             }
29              
30             sub preprocess {
31 2     2 0 6 my ($self, $input, $top) = @_;
32              
33 2         41 my @parts = split /^((?:\%\w+.*|\#.*|\ *)\n)/m, $input;
34 2         10 $input = '';
35              
36 2         13 $self->{directives} = {
37             TestML => '',
38             DataMarker => '',
39             BlockMarker => '===',
40             PointMarker => '---',
41             };
42              
43 2         2 my $order_error = 0;
44 2         4 for my $part (@parts) {
45 28 100       46 next unless length($part);
46 23 100       73 if ($part =~ /^(\#.*|\ *)\n/) {
47 11         9 $input .= "\n";
48 11         15 next;
49             }
50 12 100       31 if ($part =~ /^%(\w+)\s*(.*?)\s*\n/) {
51 3         11 my ($directive, $value) = ($1, $2);
52 3         5 $input .= "\n";
53 3 100       7 if ($directive eq 'TestML') {
54 1 50       4 die "Invalid TestML directive"
55             unless $value =~ /^\d+\.\d+\.\d+$/;
56 1 50       6 die "More than one TestML directive found"
57             if $self->directives->{TestML};
58 1         11 $self->directives->{TestML} =
59             TestML::Str->new(value => $value);
60 1         2 next;
61             }
62 2 100       21 $order_error = 1 unless $self->directives->{TestML};
63 2 100       13 if ($directive eq 'Include') {
    50          
    0          
64 1 50       4 my $runtime = $TestML::Runtime::Singleton
65             or die "Can't process Include. No runtime available";
66 1         5 my $include = ref($self)->new;
67 1         5 $include->preprocess($runtime->read_testml_file($value));
68 1         9 $input .= $include->text;
69 1         4 $self->directives->{DataMarker} =
70             $include->directives->{DataMarker};
71 1         3 $self->directives->{BlockMarker} =
72             $include->directives->{BlockMarker};
73 1         4 $self->directives->{PointMarker} =
74             $include->directives->{PointMarker};
75 1 50       3 die "Can't define %TestML in an Included file"
76             if $include->directives->{TestML};
77             }
78             elsif ($directive =~ /^(DataMarker|BlockMarker|PointMarker)$/) {
79 1         2 $self->directives->{$directive} = $value;
80             }
81             elsif ($directive =~ /^(DebugPegex|DumpAST)$/) {
82 0 0       0 $value = 1 unless length($value);
83 0         0 $self->directives->{$directive} = $value;
84             }
85             else {
86 0         0 die "Unknown TestML directive '$directive'";
87             }
88             }
89             else {
90 9 100 66     27 $order_error = 1 if $input and not $self->directives->{TestML};
91 9         15 $input .= $part;
92             }
93             }
94              
95 2 100       6 if ($top) {
96 1 50       4 die "No TestML directive found"
97             unless $self->directives->{TestML};
98 1 50       8 die "%TestML directive must be the first (non-comment) statement"
99             if $order_error;
100              
101 1   33     14 my $DataMarker =
102             $self->directives->{DataMarker} ||=
103             $self->directives->{BlockMarker};
104 1 50       8 if ((my $split = index($input, "\n$DataMarker")) >= 0) {
105 1         4 $self->{code} = substr($input, 0, $split + 1);
106 1         6 $self->{data} = substr($input, $split + 1);
107             }
108             else {
109 0         0 $self->{code} = $input;
110 0         0 $self->{data} = '';
111             }
112             }
113             else {
114 1         6 $self->{text} = $input;
115             }
116             }
117              
118             1;