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 DateTime;
 166 use DateTime::Format::RFC3339;
 167 use Math::BigInt;
 168 use Math::BigFloat;
 169 use TOML::Tiny;
 170
 171 binmode STDIN,  ':encoding(UTF-8)';
 172 binmode STDOUT, ':encoding(UTF-8)';
 173
 174 my $data
 175
 176 my \$actual = from_toml(q{$toml});
 177
 178 is(\$actual, \$expected1, '$_ - from_toml') or do{
 179   diag 'EXPECTED:';
 180   diag Dumper(\$expected1);
 181
 182   diag 'ACTUAL:';
 183   diag Dumper(\$actual);
 184 };
 185
 186 is(eval{ from_toml(to_toml(\$actual)) }, \$actual, '$_ - to_toml') or do{
 187   diag 'INPUT:';
 188   diag Dumper(\$actual);
 189
 190   diag 'TOML OUTPUT:';
 191   diag to_toml(\$actual);
 192
 193   diag 'REPARSED OUTPUT:';
 194   diag Dumper(from_toml(to_toml(\$actual)));
 195 };
 196
 197 done_testing;};
 198
 199     close $fh;
 200   }
 201 }
 202
 203 sub build_negpath_test_files{
 204   my $src  = shift;
 205   my $dest = shift;
 206
 207   $src = "$src/tests/invalid";
 208   $dest = "$dest/t/toml-test/invalid";
 209
 210   print "Generating negative path tests from $src\n";
 211
 212   unless (-d $dest) {
 213     system('mkdir', '-p', $dest) == 0 || die $?;
 214   }
 215
 216   my %TOML;
 217
 218   opendir my $dh, $src or die $!;
 219
 220   while (my $file = readdir $dh) {
 221     my $path = "$src/$file";
 222     my ($test, $ext) = $file =~ /^(.*)\.([^\.]+)$/;
 223
 224     if ($ext && $ext eq 'toml') {
 225       $TOML{$test} = $path;
 226     }
 227   }
 228
 229   closedir $dh;
 230
 231   for (sort keys %TOML) {
 232     my $toml = slurp($TOML{$_});
 233     $toml =~ s/\\/\\\\/g;
 234
 235     open my $fh, '>', "$dest/$_.t" or die $!;
 236
 237     print $fh qq{# File automatically generated from BurntSushi/toml-test
 238 use utf8;
 239 use Test2::V0;
 240 use TOML::Tiny;
 241
 242 binmode STDIN,  ':encoding(UTF-8)';
 243 binmode STDOUT, ':encoding(UTF-8)';
 244
 245 ok dies(sub{
 246   from_toml(q{
 247 $toml
 248   }, strict_arrays => 1);
 249 }), 'strict_mode dies on $_';
 250
 251 done_testing;};
 252
 253     close $fh;
 254   }
 255 }
 256
 257 my $usage = "usage: build-tests \$toml-test-repo-path \$toml-tiny-repo-path\n";
 258 my $toml_test_path = shift @ARGV || die $usage;
 259 my $toml_tiny_path = shift @ARGV || die $usage;
 260
 261 -d $toml_test_path          || die "invalid path to BurntSush/toml-test: $toml_test_path\n";
 262 -d "$toml_test_path/tests"  || die "invalid path to BurntSush/toml-test: $toml_test_path\n";
 263 -d $toml_tiny_path          || die "invalid path to TOML::Tiny repo: $toml_tiny_path\n";
 264 -d "$toml_tiny_path/t"      || die "invalid path to TOML::Tiny repo: $toml_tiny_path\n";
 265
 266 build_pospath_test_files($toml_test_path, $toml_tiny_path);
 267 build_negpath_test_files($toml_test_path, $toml_tiny_path);