1use 5.008001; use strict; use warnings;
2package TestML::Tiny;
3
4; # original $VERSION removed by Doppelgaenger
5
6use Carp();
7use Test::More 0.88 ();
8
9# use XXX;
10
11sub import {
12    strict->import;
13    warnings->import;
14}
15
16sub new {
17    my $self = bless { @_[1..$#_] }, $_[0];
18    my $testml = $self->_get_testml;
19    my $bridge = $self->_get_bridge;
20    $self->{runtime} ||= TestML::Tiny::Runtime->new(
21        bridge => $bridge,
22    );
23    my $compiler = TestML::Tiny::Compiler->new(
24        $self->{version} ? (version => $self->{version}) : (),
25    );
26    $self->{function} = $compiler->compile($testml);
27    return $self;
28}
29
30sub run {
31    my ($self) = @_;
32    my $runtime = $self->{runtime} || '';
33    Carp::croak "Missing or invalid runtime object for TestML::Tiny::run()"
34        unless defined($runtime) and ref($runtime) eq 'TestML::Tiny::Runtime';
35    $runtime->run;
36}
37
38sub _get_testml {
39    my ($self) = @_;
40    my $testml = $self->{testml}
41        or Carp::croak "TestML object requires a testml attribute";
42    $testml = $self->_slurp($testml)
43        if $testml !~ /\n/;
44    return $testml;
45}
46
47sub _get_bridge {
48    my ($self) = @_;
49    my $bridge = $self->{bridge} || 'main';
50    return $bridge if ref $bridge;
51    eval "require $bridge";
52    Carp::croak $@ if $@ and $@ !~ /^Can't locate /;
53    return (
54        defined(&{"${bridge}::new"})
55            ? $bridge->new
56            : bless {}, $bridge
57    );
58}
59
60sub _slurp {
61    open my $fh, "<:raw:encoding(UTF-8)", $_[1]
62        or die "Can't open $_[1] for input";
63    local $/;
64    <$fh>;
65}
66
67#------------------------------------------------------------------------------
68
69package TestML::Tiny::Runtime;
70
71# use XXX;
72
73sub new {
74    my $self = $TestML::Tiny::Runtime::Singleton =
75        bless { @_[1..$#_] }, $_[0];
76};
77
78sub run {
79    Test::More::fail 'not done yet!';
80    Test::More::done_testing;
81}
82
83#------------------------------------------------------------------------------
84package TestML::Tiny::Compiler;
85
86# use XXX;
87
88my $ID = qr/\w+/;
89my $SP = qr/[\ \t]/;
90my $LINE = qr/.*$/m;
91my $DIRECTIVE = qr/^%($ID)$SP+($LINE)/m;
92
93sub new {
94    my $self = bless { @_[1..$#_] }, $_[0];
95}
96
97sub runtime {
98    $TestML::Tiny::Runtime::Singleton;
99}
100
101sub compile {
102    my ($self, $testml) = @_;
103    my $function = $self->{function} = TestML::Tiny::Function->new;
104    $self->{testml} = $testml;
105    $self->preprocess;
106    my $version = $self->check_version;
107    my ($code_syntax, $data_syntax) =
108        @{$self}{qw(code_syntax data_syntax)};
109    my $code_method = "compile_code_${code_syntax}_$version";
110    Carp::croak "Don't know how to compile TestML '$code_syntax' code"
111        unless $self->can($code_method);
112    my $data_method = "compile_data_${data_syntax}_$version";
113    Carp::croak "Don't know how to compile TestML '$data_syntax' data"
114        unless $self->can($data_method);
115    $function->{statements} = $self->$code_method;
116    $function->{data} = $self->$data_method;
117    return $function;
118}
119
120my %directives = (
121    code_syntax => 'tiny',
122    data_syntax => 'testml',
123    data_marker => '===',
124    block_marker => '===',
125    point_marker => '---',
126);
127sub preprocess {
128    my ($self) = @_;
129
130    my $version = $self->{version} || undef;
131    my $testml = $self->{testml};
132    my $directives = [ $testml =~ /$DIRECTIVE/gm ];
133    $testml =~ s/($DIRECTIVE)/#$1/g;
134    while (@$directives) {
135        my ($key, $value) = splice(@$directives, 0, 2);
136        if ($key eq "TestML") {
137            $self->check_not_set_and_set($key, $value, 'version');
138        }
139        elsif ($key eq "BlockMarker") {
140            $self->check_not_set_and_set(
141                'BlockMarker', $value, 'block_marker'
142            );
143            ($self->{block_marker} = $value) =~
144                s/([\*\^\$\+\?\(\)\.])/\\$1/g;
145        }
146        elsif ($key eq "PointMarker") {
147            $self->check_not_set_and_set(
148                'PointMarker', $value, 'point_marker'
149            );
150            ($self->{point_marker} = $value) =~
151                s/([\*\^\$\+\?\(\)\.])/\\$1/g;
152        }
153        elsif ($key eq "CodeSyntax") {
154            die "Untested";
155            $self->check_not_set_and_set(
156                'CodeSyntax', $value, 'code_syntax'
157            );
158            $self->{code_syntax} = $value;
159        }
160        elsif ($key eq "DataSyntax") {
161            die "Untested";
162            $self->check_not_set_and_set(
163                'DataSyntax', $value, 'data_syntax'
164            );
165            $self->{data_syntax} = $value;
166        }
167        else {
168            Carp::croak "Unknown TestML directive: '%$key'";
169        }
170    }
171    $self->{data_marker} = $self->{block_marker}
172        if not($self->{data_marker}) and $self->{block_marker};
173    for my $directive (keys %directives) {
174        $self->{$directive} ||= $directives{$directive};
175    }
176
177    ($self->{code}, $self->{data}) =
178        ($testml =~ /(.*?)(^$self->{data_marker}.*)/msg);
179    $self->{code} ||= '';
180    $self->{data} ||= '';
181}
182
183sub check_not_set_and_set {
184    my ($self, $key, $value, $attr) = @_;
185    if (defined $self->{$attr} and $self->{$attr} ne $value) {
186        Carp::croak "Can't set TestML '$key' directive to '$value'. " .
187            "Already set to '$self->{$attr}'";
188    }
189    $self->{$attr} = $value;
190}
191
192sub check_version {
193    my ($self) = @_;
194    my $version = $self->{version} || undef;
195    Carp::croak "TestML syntax version not defined. Cannot continue"
196        unless defined $version;
197    Carp::croak "Invalid value for TestML version '$version'. Must be 0.1.0"
198        unless $version eq '0.1.0';
199    $version =~ s/\./_/g;
200    return $version;
201}
202
203sub compile_code_tiny_0_1_0 {
204    my ($self) = @_;
205    my $num = 1;
206    [ grep { not /(^#|^\s*$)/ } split /\n/, $self->{code} ];
207}
208
209sub compile_data_testml_0_1_0 {
210    my ($self) = @_;
211
212    my $lines = [ grep { ! /^#/ } split /\n/, $self->{data} ];
213
214    my $blocks = [];
215    my $parse = [];
216    push @$lines, undef; # sentinel
217    while (@$lines) {
218        push @$parse, shift @$lines;
219        if (!defined($lines->[0]) or
220            $lines->[0] =~ /^$self->{block_marker}/
221        ) {
222            my $block = $self->_parse_testml_block($parse);
223            push @$blocks, $block
224                unless exists $block->{SKIP};
225            last if exists $block->{LAST};
226            $parse = []; # clear for next parse
227        }
228        last if !defined($lines->[0]);
229    }
230
231    my $only = [ grep { exists $_->{ONLY} } @$blocks ];
232
233    return @$only ? $only : $blocks;
234}
235
236sub _parse_testml_block {
237    my ($self, $lines) = @_;
238
239    my ($label) = $lines->[0] =~ /^$self->{block_marker}(?:\s+(.*))?$/;
240    shift @$lines until not(@$lines) or
241        $lines->[0] =~ /^$self->{point_marker} +\w+/;
242
243    my $block = $self->_parse_testml_points($lines);
244    $block->{Label} = $label || '';
245
246    return $block;
247}
248
249sub _parse_testml_points {
250    my ($self, $lines) = @_;
251
252    my $block = {};
253
254    while (@$lines) {
255        my $line = shift @$lines;
256        $line =~ /^$self->{point_marker} +(\w+)/
257            or die "Invalid TestML line:\n'$line'";
258        my $point_name = $1;
259        die "$block repeats $point_name"
260            if exists $block->{$point_name};
261        $block->{$point_name} = '';
262        if ($line =~ /^$self->{point_marker} +(\w+): +(.*?) *$/) {
263            ($block->{$1} = $2) =~ s/^ *(.*?) *$/$1/;
264            shift @$lines while @$lines and
265                $lines->[0] !~ /^$self->{point_marker} +(\w)/;
266        }
267        elsif ($line =~ /^$self->{point_marker} +(\w+)$/) {
268            $point_name = $1;
269            while ( @$lines ) {
270                $line = shift @$lines;
271                if ($line =~ /^$self->{point_marker} \w+/) {
272                    unshift @$lines, $line;
273                    last;
274                }
275                $block->{$point_name} .= "$line\n";
276            }
277            $block->{$point_name} =~ s/\n\s*\z/\n/;
278            $block->{$point_name} =~ s/^\\//gm;
279        }
280        else {
281            die "Invalid TestML line:\n'$line'";
282        }
283    }
284    return $block;
285}
286
287#------------------------------------------------------------------------------
288package TestML::Tiny::Function;
289
290sub new {
291    my $self = bless {
292        statements => [],
293        data => [],
294        namespace => {},
295    }, $_[0];
296}
297
298#------------------------------------------------------------------------------
299package TestML::Tiny::Bridge;
300
301sub new {
302    my $self = bless { @_[1..$#_] }, $_[0];
303}
304
305#------------------------------------------------------------------------------
306package TestML::Tiny::Library::Standard;
307
308sub new {
309    my $self = bless { @_[1..$#_] }, $_[0];
310}
311
3121;
313