local-lib5/lib/perl5/Test/YAML.pm

   1 package Test::YAML;
   2
   3 use Test::Base 0.47 -Base;
   4 use lib 'lib';
   5
   6 our $VERSION = '0.70';
   7 our $YAML    = 'YAML';
   8 our @EXPORT  = qw(
   9     no_diff
  10     run_yaml_tests
  11     run_roundtrip_nyn roundtrip_nyn
  12     run_load_passes load_passes
  13     dumper Load Dump LoadFile DumpFile
  14     XXX
  15 );
  16
  17 delimiters('===', '+++');
  18
  19 sub Dump     () { YAML(Dump => @_)     }
  20 sub Load     () { YAML(Load => @_)     }
  21 sub DumpFile () { YAML(DumpFile => @_) }
  22 sub LoadFile () { YAML(LoadFile => @_) }
  23
  24 sub YAML () {
  25     load_yaml_pm();
  26     my $meth = shift;
  27     my $code = $YAML->can($meth) or die "$YAML cannot do $meth";
  28     goto &$code;
  29 }
  30
  31 sub load_yaml_pm {
  32     my $file = "$YAML.pm";
  33     $file =~ s{::}{/}g;
  34     require $file;
  35 }
  36
  37 sub run_yaml_tests() {
  38     run {
  39         my $block = shift;
  40         &{_get_function($block)}($block) unless
  41           _skip_tests_for_now($block) or
  42           _skip_yaml_tests($block);
  43     };
  44 }
  45
  46 sub run_roundtrip_nyn() {
  47     my @options = @_;
  48     run {
  49         my $block = shift;
  50         roundtrip_nyn($block, @options);
  51     };
  52 }
  53
  54 sub roundtrip_nyn() {
  55     my $block = shift;
  56     my $option = shift || '';
  57     die "'perl' data section required"
  58         unless exists $block->{perl};
  59     my @values = eval $block->perl;
  60     die "roundtrip_nyn eval perl error: $@" if $@;
  61     my $config = $block->config || '';
  62     my $result = eval "$config; Dump(\@values)";
  63     die "roundtrip_nyn YAML::Dump error: $@" if $@;
  64     if (exists $block->{yaml}) {
  65         is $result, $block->yaml,
  66             $block->description . ' (n->y)';
  67     }
  68     else {
  69         pass $block->description . ' (n->y)';
  70     }
  71
  72     return if exists $block->{no_round_trip} or
  73         not exists $block->{yaml};
  74
  75     if ($option eq 'dumper') {
  76         is dumper(Load($block->yaml)), dumper(@values),
  77             $block->description . ' (y->n)';
  78     }
  79     else {
  80         is_deeply [Load($block->yaml)], [@values],
  81             $block->description . ' (y->n)';
  82     }
  83 }
  84
  85 sub count_roundtrip_nyn() {
  86     my $block = shift or die "Bad call to count_roundtrip_nyn";
  87     return 1 if exists $block->{skip_this_for_now};
  88     my $count = 0;
  89     $count++ if exists $block->{perl};
  90     $count++ unless exists $block->{no_round_trip} or
  91         not exists $block->{yaml};
  92     die "Invalid test definition" unless $count;
  93     return $count;
  94 }
  95
  96 sub run_load_passes() {
  97     run {
  98         my $block = shift;
  99         my $yaml = $block->yaml;
 100         eval { YAML(Load => $yaml) };
 101         is("$@", "");
 102     };
 103 }
 104
 105 sub load_passes() {
 106     my $block = shift;
 107     my $yaml = $block->yaml;
 108     eval { YAML(Load => $yaml) };
 109     is "$@", "", $block->description;
 110 }
 111
 112 sub count_load_passes() {1}
 113
 114 sub dumper() {
 115     require Data::Dumper;
 116     $Data::Dumper::Sortkeys = 1;
 117     $Data::Dumper::Terse = 1;
 118     $Data::Dumper::Indent = 1;
 119     return Data::Dumper::Dumper(@_);
 120 }
 121
 122 {
 123     no warnings;
 124     sub XXX {
 125         YAML::Base::XXX(@_);
 126     }
 127 }
 128
 129 sub _count_tests() {
 130     my $block = shift or die "Bad call to _count_tests";
 131     no strict 'refs';
 132     &{'count_' . _get_function_name($block)}($block);
 133 }
 134
 135 sub _get_function_name() {
 136     my $block = shift;
 137     return $block->function || 'roundtrip_nyn';
 138 }
 139
 140 sub _get_function() {
 141     my $block = shift;
 142     no strict 'refs';
 143     \ &{_get_function_name($block)};
 144 }
 145
 146 sub _skip_tests_for_now() {
 147     my $block = shift;
 148     if (exists $block->{skip_this_for_now}) {
 149         _skip_test(
 150             $block->description,
 151             _count_tests($block),
 152         );
 153         return 1;
 154     }
 155     return 0;
 156 }
 157
 158 sub _skip_yaml_tests() {
 159     my $block = shift;
 160     if ($block->skip_unless_modules) {
 161         my @modules = split /[\s\,]+/, $block->skip_unless_modules;
 162         for my $module (@modules) {
 163             eval "require $module";
 164             if ($@) {
 165                 _skip_test(
 166                     "This test requires the '$module' module",
 167                     _count_tests($block),
 168                 );
 169                 return 1;
 170             }
 171         }
 172     }
 173     return 0;
 174 }
 175
 176 sub _skip_test() {
 177     my ($message, $count) = @_;
 178     SKIP: {
 179         skip($message, $count);
 180     }
 181 }
 182
 183 #-------------------------------------------------------------------------------
 184 package Test::YAML::Filter;
 185
 186 use Test::Base::Filter ();
 187
 188 our @ISA = 'Test::Base::Filter';
 189
 190 sub yaml_dump {
 191     Test::YAML::Dump(@_);
 192 }
 193
 194 sub yaml_load {
 195     Test::YAML::Load(@_);
 196 }
 197
 198 sub Dump { goto &Test::YAML::Dump }
 199 sub Load { goto &Test::YAML::Load }
 200 sub DumpFile { goto &Test::YAML::DumpFile }
 201 sub LoadFile { goto &Test::YAML::LoadFile }
 202
 203 sub yaml_load_or_fail {
 204     my ($result, $error, $warning) =
 205       $self->_yaml_load_result_error_warning(@_);
 206     return $error || $result;
 207 }
 208
 209 sub yaml_load_error_or_warning {
 210     my ($result, $error, $warning) =
 211       $self->_yaml_load_result_error_warning(@_);
 212     return $error || $warning || '';
 213 }
 214
 215 sub perl_eval_error_or_warning {
 216     my ($result, $error, $warning) =
 217       $self->_perl_eval_result_error_warning(@_);
 218     return $error || $warning || '';
 219 }
 220
 221 sub _yaml_load_result_error_warning {
 222     $self->assert_scalar(@_);
 223     my $yaml = shift;
 224     my $warning = '';
 225     local $SIG{__WARN__} = sub { $warning = join '', @_ };
 226     my $result = eval {
 227         $self->yaml_load($yaml);
 228     };
 229     return ($result, $@, $warning);
 230 }
 231
 232 sub _perl_eval_result_error_warning {
 233     $self->assert_scalar(@_);
 234     my $perl = shift;
 235     my $warning = '';
 236     local $SIG{__WARN__} = sub { $warning = join '', @_ };
 237     my $result = eval $perl;
 238     return ($result, $@, $warning);
 239 }
 240
 241 1;
 242
 243 =head1 NAME
 244
 245 Test::YAML - Testing Module for YAML Implementations
 246
 247 =head1 SYNOPSIS
 248
 249     use Test::YAML tests => 1;
 250
 251     pass;
 252
 253 =head1 DESCRIPTION
 254
 255 Test::YAML is a subclass of Test::Base with YAML specific support.
 256
 257 =head1 AUTHOR
 258
 259 Ingy döt Net <ingy@cpan.org>
 260
 261 =head1 COPYRIGHT
 262
 263 Copyright (c) 2006. Ingy döt Net. All rights reserved.
 264
 265 This program is free software; you can redistribute it and/or modify it
 266 under the same terms as Perl itself.
 267
 268 See L<http://www.perl.com/perl/misc/Artistic.html>
 269
 270 =cut