1package TestBridge;
2
3use strict;
4use warnings;
5use lib 't/lib';
6use Test::More 0.88;
7use SubtestCompat;
8use TestUtils;
9use TestML::Tiny;
10
11BEGIN {
12    $|  = 1;
13    binmode(Test::More->builder->$_, ":utf8")
14        for qw/output failure_output todo_output/;
15}
16
17use CPAN::Meta::YAML;
18
19use Exporter   ();
20our @ISA    = qw{ Exporter };
21our @EXPORT = qw{
22    run_all_testml_files
23    run_testml_file
24    test_yaml_roundtrip
25    test_perl_to_yaml
26    test_dump_error
27    test_load_error
28    test_load_warning
29    test_yaml_json
30    test_code_point
31    error_like
32    cmp_deeply
33    _testml_has_points
34};
35
36# regular expressions for checking error messages; incomplete, but more
37# can be added as more error messages get test coverage
38my %ERROR = (
39    E_CIRCULAR => qr{\QCPAN::Meta::YAML does not support circular references},
40    E_FEATURE  => qr{\QCPAN::Meta::YAML does not support a feature},
41    E_PLAIN    => qr{\QCPAN::Meta::YAML found illegal characters in plain scalar},
42    E_CLASSIFY => qr{\QCPAN::Meta::YAML failed to classify the line},
43);
44
45my %WARN = (
46    E_DUPKEY   => qr{\QCPAN::Meta::YAML found a duplicate key},
47);
48
49# use XXX -with => 'YAML::XS';
50
51#--------------------------------------------------------------------------#
52# run_all_testml_files
53#
54# Iterate over all .tml files in a directory using a particular test bridge
55# code # reference.  Each file is wrapped in a subtest.
56#--------------------------------------------------------------------------#
57
58sub run_all_testml_files {
59    my ($label, $dir, $bridge, @args) = @_;
60
61    my $code = sub {
62        my ($file, $blocks) = @_;
63        subtest "$label: $file" => sub {
64            $bridge->($_, @args) for @$blocks;
65        };
66    };
67
68    my @files = find_tml_files($dir);
69
70    run_testml_file($_, $code) for sort @files;
71}
72
73sub run_testml_file {
74    my ($file, $code) = @_;
75
76    my $blocks = TestML::Tiny->new(
77        testml => $file,
78        version => '0.1.0',
79    )->{function}{data};
80
81    $code->($file, $blocks);
82}
83
84# retrieves all the keys in @point from the $block hash, returning them in
85# order, along with $block->{Label}.
86# returns false if any keys cannot be found
87sub _testml_has_points {
88    my ($block, @points) = @_;
89    my @values;
90    for my $point (@points) {
91        defined $block->{$point} or return;
92        push @values, $block->{$point};
93    }
94    push @values, $block->{Label};
95    return @values;
96}
97
98#--------------------------------------------------------------------------#
99# test_yaml_roundtrip
100#
101# two blocks: perl, yaml
102#
103# Tests that a YAML string loads to the expected perl data.  Also, tests
104# roundtripping from perl->YAML->perl.
105#
106# We can't compare the YAML for roundtripping because CPAN::Meta::YAML doesn't
107# preserve order and comments.  Therefore, all we can test is that given input
108# YAML we can produce output YAML that produces the same Perl data as the
109# input.
110#
111# The perl must be an array reference of data to serialize:
112#
113# [ $thing1, $thing2, ... ]
114#
115# However, if a test point called 'serializes' exists, the output YAML is
116# expected to match the input YAML and will be checked for equality.
117#--------------------------------------------------------------------------#
118
119sub test_yaml_roundtrip {
120    my ($block) = @_;
121
122    my ($yaml, $perl, $label) =
123      _testml_has_points($block, qw(yaml perl)) or return;
124
125    my %options = ();
126    for (qw(serializes)) {
127        if (defined($block->{$_})) {
128            $options{$_} = 1;
129        }
130    }
131
132    my $expected = eval $perl; die $@ if $@;
133    bless $expected, 'CPAN::Meta::YAML';
134
135    subtest $label, sub {
136        # Does the string parse to the structure
137        my $yaml_copy = $yaml;
138        my $got       = eval { CPAN::Meta::YAML->read_string( $yaml_copy ); };
139        is( $@, '', "CPAN::Meta::YAML parses without error" );
140        is( $yaml_copy, $yaml, "CPAN::Meta::YAML does not modify the input string" );
141        SKIP: {
142            skip( "Shortcutting after failure", 2 ) if $@;
143            isa_ok( $got, 'CPAN::Meta::YAML' );
144            cmp_deeply( $got, $expected, "CPAN::Meta::YAML parses correctly" )
145                or diag "ERROR: $CPAN::Meta::YAML::errstr\n\nYAML:$yaml";
146        }
147
148        # Does the structure serialize to the string.
149        # We can't test this by direct comparison, because any
150        # whitespace or comments would be lost.
151        # So instead we parse back in.
152        my $output = eval { $expected->write_string };
153        is( $@, '', "CPAN::Meta::YAML serializes without error" );
154        SKIP: {
155            skip( "Shortcutting after failure", 5 ) if $@;
156            ok(
157                !!(defined $output and ! ref $output),
158                "CPAN::Meta::YAML serializes to scalar",
159            );
160            my $roundtrip = eval { CPAN::Meta::YAML->read_string( $output ) };
161            is( $@, '', "CPAN::Meta::YAML round-trips without error" );
162            skip( "Shortcutting after failure", 2 ) if $@;
163            isa_ok( $roundtrip, 'CPAN::Meta::YAML' );
164            cmp_deeply( $roundtrip, $expected, "CPAN::Meta::YAML round-trips correctly" );
165
166            # Testing the serialization
167            skip( "Shortcutting perfect serialization tests", 1 ) unless $options{serializes};
168            is( $output, $yaml, 'Serializes ok' );
169        }
170
171    };
172}
173
174#--------------------------------------------------------------------------#
175# test_perl_to_yaml
176#
177# two blocks: perl, yaml
178#
179# Tests that perl references serialize correctly to a specific YAML output
180#
181# The perl must be an array reference of data to serialize:
182#
183# [ $thing1, $thing2, ... ]
184#--------------------------------------------------------------------------#
185
186sub test_perl_to_yaml {
187    my ($block) = @_;
188
189    my ($perl, $yaml, $label) =
190      _testml_has_points($block, qw(perl yaml)) or return;
191
192    my $input = eval "no strict; $perl"; die $@ if $@;
193
194    subtest $label, sub {
195        my $result = eval { CPAN::Meta::YAML->new( @$input )->write_string };
196        is( $@, '', "write_string lives" );
197        is( $result, $yaml, "dumped YAML correct" );
198    };
199}
200
201#--------------------------------------------------------------------------#
202# test_dump_error
203#
204# two blocks: perl, error
205#
206# Tests that perl references result in an error when dumped
207#
208# The perl must be an array reference of data to serialize:
209#
210# [ $thing1, $thing2, ... ]
211#
212# The error must be a key in the %ERROR hash in this file
213#--------------------------------------------------------------------------#
214
215sub test_dump_error {
216    my ($block) = @_;
217
218    my ($perl, $error, $label) =
219      _testml_has_points($block, qw(perl error)) or return;
220
221    my $input = eval "no strict; $perl"; die $@ if $@;
222    chomp $error;
223    my $expected = $ERROR{$error};
224
225    subtest $label, sub {
226        my $result = eval { CPAN::Meta::YAML->new( @$input )->write_string };
227        ok( !$result, "returned false" );
228        error_like( $expected, "Got expected error" );
229    };
230}
231
232#--------------------------------------------------------------------------#
233# test_load_error
234#
235# two blocks: yaml, error
236#
237# Tests that a YAML string results in an error when loaded
238#
239# The error must be a key in the %ERROR hash in this file
240#--------------------------------------------------------------------------#
241
242sub test_load_error {
243    my ($block) = @_;
244
245    my ($yaml, $error, $label) =
246      _testml_has_points($block, qw(yaml error)) or return;
247
248    chomp $error;
249    my $expected = $ERROR{$error};
250
251    subtest $label, sub {
252        my $result = eval { CPAN::Meta::YAML->read_string( $yaml ) };
253        is( $result, undef, 'read_string returns undef' );
254        error_like( $expected, "Got expected error" )
255            or diag "YAML:\n$yaml";
256    };
257}
258
259#--------------------------------------------------------------------------#
260# test_load_warning
261#
262# two blocks: yaml, warning
263#
264# Tests that a YAML string results in warning when loaded
265#
266# The warning must be a key in the %WARN hash in this file
267#--------------------------------------------------------------------------#
268sub test_load_warning {
269    my ($block) = @_;
270
271    my ($yaml, $warning, $label) =
272      _testml_has_points($block, qw(yaml warning)) or return;
273
274    chomp $warning;
275    my $expected = $WARN{$warning};
276
277    subtest $label, sub {
278        # this is not in a sub like warning_like because of the danger of
279        # matching the regex parameter against something earlier in the stack
280        my @warnings;
281        local $SIG{__WARN__} = sub { push @warnings, shift; };
282
283        my $result = eval { CPAN::Meta::YAML->read_string( $yaml ) };
284
285        is(scalar(@warnings), 1, 'got exactly one warning');
286        like(
287            $warnings[0],
288            $expected,
289            'Got expected warning',
290        ) or diag "YAML:\n$yaml\n", 'warning: ', explain(\@warnings);
291    };
292}
293
294#--------------------------------------------------------------------------#
295# test_yaml_json
296#
297# two blocks: yaml, json
298#
299# Tests that a YAML string can be loaded to Perl and dumped to JSON and
300# match an expected JSON output.  The expected JSON is loaded and dumped
301# to ensure similar JSON dump options.
302#--------------------------------------------------------------------------#
303
304sub test_yaml_json {
305    my ($block, $json_lib) = @_;
306    $json_lib ||= do { require JSON::PP; 'JSON::PP' };
307
308    my ($yaml, $json, $label) =
309      _testml_has_points($block, qw(yaml json)) or return;
310
311    subtest "$label", sub {
312        # test YAML Load
313        my $object = eval {
314            CPAN::Meta::YAML::Load($yaml);
315        };
316        my $err = $@;
317        ok !$err, "YAML loads";
318        return if $err;
319
320        # test YAML->Perl->JSON
321        # N.B. round-trip JSON to decode any \uNNNN escapes and get to
322        # characters
323        my $want = $json_lib->new->encode(
324            $json_lib->new->decode($json)
325        );
326        my $got = $json_lib->new->encode($object);
327        is $got, $want, "Load is accurate";
328    };
329}
330
331#--------------------------------------------------------------------------#
332# test_code_point
333#
334# two blocks: code, yaml
335#
336# Tests that a Unicode codepoint is correctly dumped to YAML as both
337# key and value.
338#
339# The code test point must be a non-negative integer
340#
341# The yaml code point is the expected output of { $key => $value } where
342# both key and value are the character represented by the codepoint.
343#--------------------------------------------------------------------------#
344
345sub test_code_point {
346    my ($block) = @_;
347
348    my ($code, $yaml, $label) =
349        _testml_has_points($block, qw(code yaml)) or return;
350
351    subtest "$label - Unicode map key/value test" => sub {
352        my $data = { chr($code) => chr($code) };
353        my $dump = CPAN::Meta::YAML::Dump($data);
354        $dump =~ s/^---\n//;
355        is $dump, $yaml, "Dump key and value of code point char $code";
356
357        my $yny = CPAN::Meta::YAML::Dump(CPAN::Meta::YAML::Load($yaml));
358        $yny =~ s/^---\n//;
359        is $yny, $yaml, "YAML for code point $code YNY roundtrips";
360
361        my $nyn = CPAN::Meta::YAML::Load(CPAN::Meta::YAML::Dump($data));
362        cmp_deeply( $nyn, $data, "YAML for code point $code NYN roundtrips" );
363    }
364}
365
366#--------------------------------------------------------------------------#
367# error_like
368#
369# Test CPAN::Meta::YAML->errstr against a regular expression and clear the
370# errstr afterwards
371#--------------------------------------------------------------------------#
372
373sub error_like {
374    my ($regex, $label) = @_;
375    $label = "Got expected error" unless defined $label;
376    local $Test::Builder::Level = $Test::Builder::Level + 1;
377    my $ok = like( $@, $regex, $label );
378    return $ok;
379}
380
381#--------------------------------------------------------------------------#
382# cmp_deeply
383#
384# is_deeply with some better diagnostics
385#--------------------------------------------------------------------------#
386sub cmp_deeply {
387    my ($got, $want, $label) = @_;
388    local $Test::Builder::Level = $Test::Builder::Level + 1;
389    is_deeply( $got, $want, $label )
390        or diag "GOT:\n", explain($got), "\nWANTED:\n", explain($want);
391}
392
3931;
394