build-tests.pl

   1 #-------------------------------------------------------------------------------
   2 # Generates perl unit tests from the toml/json files in BurntSush/toml-test
   3 # without having to add special casing to TOML::Tiny to conform to their
   4 # annotated JSON format.
   5 #-------------------------------------------------------------------------------
   6 use strict;
   7 use warnings;
   8 no warnings 'experimental';
   9 use v5.18;
  10
  11 use Data::Dumper;
  12 use JSON::PP;
  13
  14 # We want to read unicde as characters from toml-test source files. That makes
  15 # things simpler for us when we parse them and generate perl source in the
  16 # generated test file.
  17 binmode STDIN,  ':encoding(UTF-8)';
  18 binmode STDOUT, ':encoding(UTF-8)';
  19
  20 sub slurp{
  21   open my $fh, '<', $_[0] or die $!;
  22   local $/;
  23   <$fh>;
  24 }
  25
  26 # Removes type annotations from BurntSushi/toml-test JSON files and returns the
  27 # cleaned up data structure to which the associated TOML file should be parsed.
  28 sub deturd_json{
  29   state $json = JSON::PP->new->utf8(1);
  30   my $annotated = $json->decode(slurp(shift));
  31   my $cleanish = deannotate($annotated);
  32
  33   local $Data::Dumper::Varname = 'expected';
  34   local $Data::Dumper::Deparse = 1;
  35   return Dumper($cleanish);
  36 }
  37
  38 # Recursively deannotates and inflates values from toml-test JSON data
  39 # structures into a format more in line with TOML::Tiny's parser outout. For
  40 # integer and float values, a Test2::Tools::Compare validator is generated to
  41 # compare using Math::Big(Int|Float)->beq, since TOML's float and int types are
  42 # 64 bits. Datetimes are converted to a common, normalized string format.
  43 sub deannotate{
  44   my $data = shift;
  45
  46   for (ref $data) {
  47     when ('HASH') {
  48       if (exists $data->{type} && exists $data->{value} && keys(%$data) == 2) {
  49         for ($data->{type}) {
  50           return $data->{value} eq 'true' ? 1 : 0             when /bool/;
  51           return [ map{ deannotate($_) } @{$data->{value}} ]  when /array/;
  52
  53           when (/datetime/) {
  54             my $src = qq{
  55               use Test2::Tools::Compare qw(validator);
  56               validator(sub{
  57                 use DateTime;
  58                 use DateTime::Format::RFC3339;
  59                 my \$exp = DateTime::Format::RFC3339->parse_datetime("$data->{value}");
  60                 my \$got = DateTime::Format::RFC3339->parse_datetime(\$_);
  61                 \$exp->set_time_zone('UTC');
  62                 \$got->set_time_zone('UTC');
  63                 return DateTime->compare(\$got, \$exp) == 0;
  64               });
  65             };
  66
  67             my $result = eval $src;
  68             $@ && die $@;
  69
  70             return $result;
  71           }
  72
  73           when (/integer/) {
  74             my $src = qq{
  75               use Test2::Tools::Compare qw(validator);
  76               validator(sub{
  77                 require Math::BigInt;
  78                 Math::BigInt->new("$data->{value}")->beq(\$_);
  79               });
  80             };
  81
  82             my $result = eval $src;
  83             $@ && die $@;
  84
  85             return $result;
  86           }
  87
  88           when (/float/) {
  89             my $src = qq{
  90               use Test2::Tools::Compare qw(validator);
  91               validator(sub{
  92                 require Math::BigFloat;
  93                 Math::BigFloat->new("$data->{value}")->beq(\$_);
  94               });
  95             };
  96
  97             my $result = eval $src;
  98             $@ && die $@;
  99
 100             return $result;
 101           }
 102
 103           default{ return $data->{value} }
 104         }
 105       }
 106
 107       my %object;
 108       $object{$_} = deannotate($data->{$_}) for keys %$data;
 109       return \%object;
 110     }
 111
 112     when ('ARRAY') {
 113       return [ map{ deannotate($_) } @$data ];
 114     }
 115
 116     default{
 117       return $data;
 118     }
 119   }
 120 }
 121
 122 sub build_pospath_test_files{
 123   my $src  = shift;
 124   my $dest = shift;
 125
 126   $src = "$src/tests/valid";
 127   $dest = "$dest/t/toml-test/valid";
 128
 129   print "Generating positive path tests from $src\n";
 130
 131   unless (-d $dest) {
 132     system('mkdir', '-p', $dest) == 0 || die $?;
 133   }
 134
 135   my %TOML;
 136   my %JSON;
 137
 138   opendir my $dh, $src or die $!;
 139
 140   while (my $file = readdir $dh) {
 141     my $path = "$src/$file";
 142     my ($test, $ext) = $file =~ /^(.*)\.([^\.]+)$/;
 143
 144     for ($ext) {
 145       next unless defined;
 146       $TOML{$test} = $path when /toml/;
 147       $JSON{$test} = $path when /json/;
 148     }
 149   }
 150
 151   closedir $dh;
 152
 153   for (sort keys %TOML) {
 154     my $data = deturd_json($JSON{$_});
 155
 156     my $toml = slurp($TOML{$_});
 157     $toml =~ s/\\/\\\\/g;
 158
 159     open my $fh, '>', "$dest/$_.t" or die $!;
 160
 161     print $fh qq{# File automatically generated from BurntSushi/toml-test
 162 use utf8;
 163 use Test2::V0;
 164 use Data::Dumper;
 165 use TOML::Tiny;
 166
 167 binmode STDIN,  ':encoding(UTF-8)';
 168 binmode STDOUT, ':encoding(UTF-8)';
 169
 170 my $data
 171
 172 my \$actual = from_toml(q{$toml});
 173
 174 is(\$actual, \$expected1, '$_ - from_toml') or do{
 175   diag 'EXPECTED:';
 176   diag Dumper(\$expected1);
 177
 178   diag 'ACTUAL:';
 179   diag Dumper(\$actual);
 180 };
 181
 182 is(eval{ from_toml(to_toml(\$actual)) }, \$actual, '$_ - to_toml') or do{
 183   diag 'INPUT:';
 184   diag Dumper(\$actual);
 185
 186   diag 'TOML OUTPUT:';
 187   diag to_toml(\$actual);
 188
 189   diag 'REPARSED OUTPUT:';
 190   diag Dumper(from_toml(to_toml(\$actual)));
 191 };
 192
 193 done_testing;};
 194
 195     close $fh;
 196   }
 197 }
 198
 199 sub build_negpath_test_files{
 200   my $src  = shift;
 201   my $dest = shift;
 202
 203   $src = "$src/tests/invalid";
 204   $dest = "$dest/t/toml-test/invalid";
 205
 206   print "Generating negative path tests from $src\n";
 207
 208   unless (-d $dest) {
 209     system('mkdir', '-p', $dest) == 0 || die $?;
 210   }
 211
 212   my %TOML;
 213
 214   opendir my $dh, $src or die $!;
 215
 216   while (my $file = readdir $dh) {
 217     my $path = "$src/$file";
 218     my ($test, $ext) = $file =~ /^(.*)\.([^\.]+)$/;
 219
 220     if ($ext && $ext eq 'toml') {
 221       $TOML{$test} = $path;
 222     }
 223   }
 224
 225   closedir $dh;
 226
 227   for (sort keys %TOML) {
 228     my $toml = slurp($TOML{$_});
 229     $toml =~ s/\\/\\\\/g;
 230
 231     open my $fh, '>', "$dest/$_.t" or die $!;
 232
 233     print $fh qq{# File automatically generated from BurntSushi/toml-test
 234 use utf8;
 235 use Test2::V0;
 236 use TOML::Tiny;
 237
 238 binmode STDIN,  ':encoding(UTF-8)';
 239 binmode STDOUT, ':encoding(UTF-8)';
 240
 241 ok dies(sub{
 242   from_toml(q{
 243 $toml
 244   }, strict_arrays => 1);
 245 }), 'strict_mode dies on $_';
 246
 247 done_testing;};
 248
 249     close $fh;
 250   }
 251 }
 252
 253 my $usage = "usage: build-tests \$toml-test-repo-path \$toml-tiny-repo-path\n";
 254 my $toml_test_path = shift @ARGV || die $usage;
 255 my $toml_tiny_path = shift @ARGV || die $usage;
 256
 257 -d $toml_test_path          || die "invalid path to BurntSush/toml-test: $toml_test_path\n";
 258 -d "$toml_test_path/tests"  || die "invalid path to BurntSush/toml-test: $toml_test_path\n";
 259 -d $toml_tiny_path          || die "invalid path to TOML::Tiny repo: $toml_tiny_path\n";
 260 -d "$toml_tiny_path/t"      || die "invalid path to TOML::Tiny repo: $toml_tiny_path\n";
 261
 262 build_pospath_test_files($toml_test_path, $toml_tiny_path);
 263 build_negpath_test_files($toml_test_path, $toml_tiny_path);