File Coverage

inc/TestML/Compiler.pm
Criterion Covered Total %
statement 41 59 69.4
branch 15 38 39.4
condition 2 6 33.3
subroutine 4 4 100.0
pod 0 2 0.0
total 62 109 56.8


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