This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update CPAN-Meta-YAML to CPAN version 0.010
[perl5.git] / cpan / CPAN-Meta-YAML / t / lib / Test.pm
1 package t::lib::Test;
2
3 use strict;
4 use warnings;
5
6 use Exporter   ();
7 use File::Spec ();
8 use Test::More ();
9
10 use vars qw{@ISA @EXPORT};
11 BEGIN {
12     @ISA    = qw{ Exporter };
13     @EXPORT = qw{
14         tests  yaml_ok  yaml_error slurp  load_ok
15         test_data_directory
16     };
17 }
18
19 # Do we have the authorative YAML to test against
20 eval {
21     require YAML;
22
23     # This doesn't currently work, but is documented to.
24     # So if it ever turns up, use it.
25     $YAML::UseVersion = 1;
26 };
27 my $HAVE_YAMLPM = !! (
28     $YAML::VERSION
29     and
30     $YAML::VERSION >= 0.66
31 );
32 sub have_yamlpm { $HAVE_YAMLPM }
33
34 # Do we have YAML::Perl to test against?
35 eval {
36     require YAML::Perl;
37 };
38 my $HAVE_YAMLPERL = !! (
39     $YAML::Perl::VERSION
40     and
41     $YAML::Perl::VERSION >= 0.02
42 );
43 sub have_yamlperl { $HAVE_YAMLPERL }
44
45 # Do we have YAML::Syck to test against?
46 eval {
47     require YAML::Syck;
48 };
49 my $HAVE_SYCK = !! (
50     $YAML::Syck::VERSION
51     and
52     $YAML::Syck::VERSION >= 1.05
53 );
54 sub have_syck { $HAVE_SYCK }
55
56 # Do we have YAML::XS to test against?
57 eval {
58     require YAML::XS;
59 };
60 my $HAVE_XS = !! (
61     $YAML::XS::VERSION
62     and
63     $YAML::XS::VERSION >= 0.29
64 );
65 sub have_xs{ $HAVE_XS }
66
67 # 22 tests per call to yaml_ok
68 # 4  tests per call to load_ok
69 sub tests {
70     return ( tests => count(@_) );
71 }
72
73 sub test_data_directory {
74     return File::Spec->catdir( 't', 'data' );
75 }
76
77 sub count {
78     my $yaml_ok = shift || 0;
79     my $load_ok = shift || 0;
80     my $single  = shift || 0;
81     my $count   = $yaml_ok * 38 + $load_ok * 4 + $single;
82     return $count;
83 }
84
85 sub yaml_ok {
86     my $string  = shift;
87     my $object  = shift;
88     my $name    = shift || 'unnamed';
89     my %options = ( @_ );
90     bless $object, 'CPAN::Meta::YAML';
91
92     # If YAML itself is available, test with it
93     SKIP: {
94         unless ( $HAVE_YAMLPM ) {
95             Test::More::skip( "Skipping YAML.pm, not available for testing", 7 );
96         }
97         if ( $options{noyamlpm} ) {
98             Test::More::skip( "Skipping YAML.pm for known-broken feature", 7 );
99         }
100
101         # Test writing with YAML.pm
102         my $yamlpm_out = eval { YAML::Dump( @$object ) };
103         Test::More::is( $@, '', "$name: YAML.pm saves without error" );
104         SKIP: {
105             Test::More::skip( "Shortcutting after failure", 4 ) if $@;
106             Test::More::ok(
107                 !!(defined $yamlpm_out and ! ref $yamlpm_out),
108                 "$name: YAML.pm serializes correctly",
109             );
110             my @yamlpm_round = eval { YAML::Load( $yamlpm_out ) };
111             Test::More::is( $@, '', "$name: YAML.pm round-trips without error" );
112             Test::More::skip( "Shortcutting after failure", 2 ) if $@;
113             my $round = bless [ @yamlpm_round ], 'CPAN::Meta::YAML';
114             Test::More::is_deeply( $round, $object, "$name: YAML.pm round-trips correctly" );
115         }
116
117         # Test reading with YAML.pm
118         my $yamlpm_copy = $string;
119         my @yamlpm_in   = eval { YAML::Load( $yamlpm_copy ) };
120         Test::More::is( $@, '', "$name: YAML.pm loads without error" );
121         Test::More::is( $yamlpm_copy, $string, "$name: YAML.pm does not modify the input string" );
122         SKIP: {
123             Test::More::skip( "Shortcutting after failure", 1 ) if $@;
124             Test::More::is_deeply( \@yamlpm_in, $object, "$name: YAML.pm parses correctly" );
125         }
126     }
127
128     # If YAML::Syck itself is available, test with it
129     SKIP: {
130         unless ( $HAVE_SYCK ) {
131             Test::More::skip( "Skipping YAML::Syck, not available for testing", 7 );
132         }
133         if ( $options{nosyck} ) {
134             Test::More::skip( "Skipping YAML::Syck for known-broken feature", 7 );
135         }
136         unless ( @$object == 1 ) {
137             Test::More::skip( "Skipping YAML::Syck for unsupported feature", 7 );
138         }
139
140         # Test writing with YAML::Syck
141         my $syck_out = eval { YAML::Syck::Dump( @$object ) };
142         Test::More::is( $@, '', "$name: YAML::Syck saves without error" );
143         SKIP: {
144             Test::More::skip( "Shortcutting after failure", 4 ) if $@;
145             Test::More::ok(
146                 !!(defined $syck_out and ! ref $syck_out),
147                 "$name: YAML::Syck serializes correctly",
148             );
149             my @syck_round = eval { YAML::Syck::Load( $syck_out ) };
150             Test::More::is( $@, '', "$name: YAML::Syck round-trips without error" );
151             Test::More::skip( "Shortcutting after failure", 2 ) if $@;
152             my $round = bless [ @syck_round ], 'CPAN::Meta::YAML';
153             Test::More::is_deeply( $round, $object, "$name: YAML::Syck round-trips correctly" );
154         }
155
156         # Test reading with YAML::Syck
157         my $syck_copy = $string;
158         my @syck_in   = eval { YAML::Syck::Load( $syck_copy ) };
159         Test::More::is( $@, '', "$name: YAML::Syck loads without error" );
160         Test::More::is( $syck_copy, $string, "$name: YAML::Syck does not modify the input string" );
161         SKIP: {
162             Test::More::skip( "Shortcutting after failure", 1 ) if $@;
163             Test::More::is_deeply( \@syck_in, $object, "$name: YAML::Syck parses correctly" );
164         }
165     }
166
167     # If YAML::XS itself is available, test with it
168     SKIP: {
169         unless ( $HAVE_XS ) {
170             Test::More::skip( "Skipping YAML::XS, not available for testing", 7 );
171         }
172         if ( $options{noxs} ) {
173             Test::More::skip( "Skipping YAML::XS for known-broken feature", 7 );
174         }
175
176         # Test writing with YAML::XS
177         my $xs_out = eval { YAML::XS::Dump( @$object ) };
178         Test::More::is( $@, '', "$name: YAML::XS saves without error" );
179         SKIP: {
180             Test::More::skip( "Shortcutting after failure", 4 ) if $@;
181             Test::More::ok(
182                 !!(defined $xs_out and ! ref $xs_out),
183                 "$name: YAML::XS serializes correctly",
184             );
185             my @xs_round = eval { YAML::XS::Load( $xs_out ) };
186             Test::More::is( $@, '', "$name: YAML::XS round-trips without error" );
187             Test::More::skip( "Shortcutting after failure", 2 ) if $@;
188             my $round = bless [ @xs_round ], 'CPAN::Meta::YAML';
189             Test::More::is_deeply( $round, $object, "$name: YAML::XS round-trips correctly" );
190         }
191
192         # Test reading with YAML::XS
193         my $xs_copy = $string;
194         my @xs_in   = eval { YAML::XS::Load( $xs_copy ) };
195         Test::More::is( $@, '', "$name: YAML::XS loads without error" );
196         Test::More::is( $xs_copy, $string, "$name: YAML::XS does not modify the input string" );
197         SKIP: {
198             Test::More::skip( "Shortcutting after failure", 1 ) if $@;
199             Test::More::is_deeply( \@xs_in, $object, "$name: YAML::XS parses correctly" );
200         }
201     }
202
203     # If YAML::Perl is available, test with it
204     SKIP: {
205         unless ( $HAVE_YAMLPERL ) {
206             Test::More::skip( "Skipping YAML::Perl, not available for testing", 7 );
207         }
208         if ( $options{noyamlperl} ) {
209             Test::More::skip( "Skipping YAML::Perl for known-broken feature", 7 );
210         }
211
212         # Test writing with YAML.pm
213         my $yamlperl_out = eval { YAML::Perl::Dump( @$object ) };
214         Test::More::is( $@, '', "$name: YAML::Perl saves without error" );
215         SKIP: {
216             Test::More::skip( "Shortcutting after failure", 4 ) if $@;
217             Test::More::ok(
218                 !!(defined $yamlperl_out and ! ref $yamlperl_out),
219                 "$name: YAML::Perl serializes correctly",
220             );
221             my @yamlperl_round = eval { YAML::Perl::Load( $yamlperl_out ) };
222             Test::More::is( $@, '', "$name: YAML::Perl round-trips without error" );
223             Test::More::skip( "Shortcutting after failure", 2 ) if $@;
224             my $round = bless [ @yamlperl_round ], 'CPAN::Meta::YAML';
225             Test::More::is_deeply( $round, $object, "$name: YAML::Perl round-trips correctly" );
226         }
227
228         # Test reading with YAML::Perl
229         my $yamlperl_copy = $string;
230         my @yamlperl_in   = eval { YAML::Perl::Load( $yamlperl_copy ) };
231         Test::More::is( $@, '', "$name: YAML::Perl loads without error" );
232         Test::More::is( $yamlperl_copy, $string, "$name: YAML::Perl does not modify the input string" );
233         SKIP: {
234             Test::More::skip( "Shortcutting after failure", 1 ) if $@;
235             Test::More::is_deeply( \@yamlperl_in, $object, "$name: YAML::Perl parses correctly" );
236         }
237     }
238
239     # Does the string parse to the structure
240     my $yaml_copy = $string;
241     my $yaml      = eval { CPAN::Meta::YAML->read_string( $yaml_copy ); };
242     Test::More::is( $@, '', "$name: CPAN::Meta::YAML parses without error" );
243     Test::More::is( $yaml_copy, $string, "$name: CPAN::Meta::YAML does not modify the input string" );
244     SKIP: {
245         Test::More::skip( "Shortcutting after failure", 2 ) if $@;
246         Test::More::isa_ok( $yaml, 'CPAN::Meta::YAML' );
247         Test::More::is_deeply( $yaml, $object, "$name: CPAN::Meta::YAML parses correctly" );
248     }
249
250     # Does the structure serialize to the string.
251     # We can't test this by direct comparison, because any
252     # whitespace or comments would be lost.
253     # So instead we parse back in.
254     my $output = eval { $object->write_string };
255     Test::More::is( $@, '', "$name: CPAN::Meta::YAML serializes without error" );
256     SKIP: {
257         Test::More::skip( "Shortcutting after failure", 5 ) if $@;
258         Test::More::ok(
259             !!(defined $output and ! ref $output),
260             "$name: CPAN::Meta::YAML serializes correctly",
261         );
262         my $roundtrip = eval { CPAN::Meta::YAML->read_string( $output ) };
263         Test::More::is( $@, '', "$name: CPAN::Meta::YAML round-trips without error" );
264         Test::More::skip( "Shortcutting after failure", 2 ) if $@;
265         Test::More::isa_ok( $roundtrip, 'CPAN::Meta::YAML' );
266         Test::More::is_deeply( $roundtrip, $object, "$name: CPAN::Meta::YAML round-trips correctly" );
267
268         # Testing the serialization
269         Test::More::skip( "Shortcutting perfect serialization tests", 1 ) unless $options{serializes};
270         Test::More::is( $output, $string, 'Serializes ok' );
271     }
272
273     # Return true as a convenience
274     return 1;
275 }
276
277 sub yaml_error {
278     my $string = shift;
279     my $like   = shift;
280     my $yaml   = CPAN::Meta::YAML->read_string( $string );
281     Test::More::is( $yaml, undef, '->read_string returns undef' );
282     Test::More::ok( CPAN::Meta::YAML->errstr =~ /$like/, "Got expected error" );
283     # NOTE: like() gives better diagnostics (but requires 5.005)
284     # Test::More::like( $@, qr/$_[0]/, "CPAN::Meta::YAML throws expected error" );
285 }
286
287 sub slurp {
288     my $file = shift;
289     local $/ = undef;
290     open( FILE, " $file" ) or die "open($file) failed: $!";
291     binmode( FILE, $_[0] ) if @_ > 0 && $] > 5.006;
292     # binmode(FILE); # disable perl's BOM interpretation
293     my $source = <FILE>;
294     close( FILE ) or die "close($file) failed: $!";
295     $source;
296 }
297
298 sub load_ok {
299     my $name = shift;
300     my $file = shift;
301     my $size = shift;
302     Test::More::ok( -f $file, "Found $name" );
303     Test::More::ok( -r $file, "Can read $name" );
304     my $content = slurp( $file );
305     Test::More::ok( (defined $content and ! ref $content), "Loaded $name" );
306     Test::More::ok( ($size < length $content), "Content of $name larger than $size bytes" );
307     return $content;
308 }
309
310 1;