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