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