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;