gentests.pl

use strict;
use warnings;
no warnings 'portable';  # Support for 64-bit ints required
use Math::BigInt;

# Generate IntZip test cases
#
# This is a maintainer script and is not distributed.
# Repository: https://github.com/boethin/intzip
#
# All testdata files are created by this script. 
# This script will not overwrite existing testdata files.
#
use constant TESTS_DIR => 'tests';
use constant TESTDATA_DIR => 'testdata';

sub LOG(@) { printf '[%s] ', __FILE__; printf @_; print "\n"; }

sub sorted { [ sort { $a <=> $b } keys %{ { map { $_ => 1 } @_ } } ] }

sub strip_0x {
  my $hex = shift;
  $hex =~ s/^0x//;
  $hex;
}

sub primes_u16;

my %max = ( u16 => '0xffff', u32 => '0xffffffff', u64 => '0xffffffffffffffff' );

my @at_files;
my @test_files;

# create autotest category
sub at_category($$@) {
  my ($category,$banner) = (shift,shift);

  # init .at test category file
  push @at_files, "$category.at";
  my $at_path = +TESTS_DIR."/$category.at";
  open my $at_fh, '>', $at_path or die $!;
  printf $at_fh "# Tests for the $category category.\n".
    "#\n# - This file was auto-generated by %s -\n#\n".
    "AT_BANNER([[%s.]])\n",$0,$banner;

  # create tests
  foreach my $t ( @_ ) {
    # defaults
    $t->{type} = 'u32' unless defined $t->{type};
    $t->{form} = 'hex' unless defined $t->{form};
    unless ( defined $t->{int_data} ) {
      $t->{int_data} = [ map { Math::BigInt->new($_) } @{$t->{data}} ];
    }
    unless ( defined $t->{name} ) {
      $t->{name} = join ',', map { $_->as_hex } @{$t->{int_data}};
      $t->{setup} = sprintf '[[%s]]', $t->{name} unless defined $t->{setup};
    }
    $t->{setup} = $t->{name} unless defined $t->{setup};
    $t->{setup} .= (sprintf ' %s/%s',$t->{type},$t->{form});
    
    unless ( defined $t->{filename} ) {
      $t->{filename} = lc $t->{name};
      $t->{filename} =~ s/[^a-z0-9]/_/gi;
      $t->{filename} .= ".$t->{type}" if $t->{form} eq 'bin' || $t->{encoded};
      $t->{filename} .= ".$t->{form}";
      $t->{filename} .= '.iz' if $t->{encoded};
      $t->{filename} = join '_', ($category,$t->{filename});
    }
    
    my $path = +TESTDATA_DIR."/$t->{filename}";
    push @test_files, $t->{filename};
    unless ( -f $path ) { # only if not exists
      # create test data
      LOG "create: %s", $path;
      unless ( defined $t->{createfile} ) {
        my $map;
        if ( $t->{form} eq 'hex' ) { # hex
          $map = sub { strip_0x($_[0]->as_hex)."\n" };
        }
        else { # bin
          # 'Q>' only available with 64-bit support
          my $pack = { u16 => 'n', u32 => 'N', u64 => 'Q>' }->{$t->{type}};
          $map = sub { pack $pack, $_[0]->numify };
        }
        
        my $t_fh;
        if ( $t->{encoded} ) {
          my $opt = '--'.$t->{type};
          $opt .= " -b" if $t->{form} eq 'bin';
          open $t_fh, "| src/intzip $opt >$path" or die $!;
        } else {
          open $t_fh, '>', $path or die $!;
        }
        foreach ( @{$t->{int_data}} ) {
          my $d = &$map($_);
          print $t_fh $d;
        }
        close $t_fh or die $!;
      }
      else {
        &{$t->{createfile}}($path);
      }
    }
    
    # add to .at test category file
    unless ( defined $t->{options} ) {
      $t->{options} = sprintf '--%s', $t->{type};
      $t->{options} .= ' --binary' if $t->{form} eq 'bin';
    }
    my $macro = $t->{encoded} ? 'AT_CHECK_DECODE_ENCODE' : 'AT_CHECK_ENCODE_DECODE';
    printf $at_fh "$macro([%s],[%s],[%s])\n", map { $t->{$_} } qw(setup options filename);
    
    # containment tests
    if ( defined $t->{contains} ) {
      foreach ( sort keys %{$t->{contains}} ) {
        my $int = Math::BigInt->new($_);
        printf $at_fh "%s([%s %s %s],[%s],[%s],[%s],[%s])\n",
          ( $t->{encoded} ? 'AT_CHECK_ENCODED_CONTAINS' : 'AT_CHECK_CONTAINS' ),
          $t->{setup},
          ( $t->{contains}{$_} ? 'contains' : 'does not contain' ), $int->as_hex,
          $t->{options},
          $t->{filename},
          strip_0x($int->as_hex),
          ( $t->{contains}{$_} ? 'EXIT_SUCCESS' : 'EXIT_FAILURE');
      }
    }
    
  }
  close $at_fh;
}

# -- tests --

at_category empty => 'Empty List Tests',
  map {
    my $form = $_;
    map {
      my $type = $_;
      { type => $type, form => $form, filename => 'empty.hex', setup => 'Empty',
        data => [], contains => { 0 => 0 } }
    } (qw( u16 u32 u64 ));
  } qw ( hex bin );

at_category io => 'IO Tests',
	map {
		my $form = $_;
		map {
		  my $type = $_;
		  (map {
		    { type => $type, form => $form, data => [ 0,1,2,$_ ] }
		  } (0x100,0x1000,$max{$type}))
		} (qw( u16 u32 u64 ));
	} qw( bin hex );

at_category singleton => 'Singleton List Tests',
  map {
    my $type = $_;
    (map {
      { type => $type, data => [ $_ ], contains => { $_ => 1 } }
    } (0,1,2,$max{$type}))
  } (qw( u16 u32 u64 ));
  
at_category short => 'Short List Tests',
  map {
    my $type = $_;
    (
      (map {
        { type => $type, data => [ 0,$_ ], contains => { 0 => 1, $_ => 1, 3 => 0 } }
      } (1,2,$max{$type})),
      { type => $type, data => [ 1,2,3,5 ],
        contains => { 0 => 0, 1 => 1, 2 => 1, 3 => 1, 4 => 0, 5 => 1, 6 => 0 } },
      { type => $type, data => [ 10,100,1000,10000 ],
        contains => { 0 => 0, 1 => 0, 10 => 1, 99 => 0, 100 => 1, 101 => 0, } },
    )
  } (qw( u16 u32 u64 ));

at_category equidistant => 'Equidistant Interval Tests',
  (map {
    my $type = $_;
    (
      (map {
        my $dist = $_;
        { type => $type, name => "Distance $dist",
          data => [ map { $dist*$_ } ( 0 .. 0x10 ) ], contains => { 0 => 1, $dist*0x10 => 1, 161 => 0 } }
      } (1,2,3,100)),
      { type => $type, name => "Alternating",
        data => [ map { 2*$_ + ($_ % 2) } ( 0 .. 0x100 ) ], 
        contains => { 0 => 1, 1 => 0, 2 => 0, 3 => 1, 4 => 1, 5 => 0, 6 => 0, 7 => 1, 8 => 1, 9 => 0 } },
      { type => $type, name => "Multiple",
        data => [ (0 .. 50), (100 .. 150), (200, 250), (0x1000 .. 0x1100 ) ],
        conatins => { 0 => 1, 51 => 0, 100 => 1, 150 => 1, 152 => 0 } },
      { type => $type, name => "Many small",
        data => [ map { ( 10*$_ .. 10*$_+8 ) } (1 .. 100) ] },
    )
  } (qw( u16 u32 u64 ))),
  {
    type => 'u16', form => 'bin', name => 'Any 16bit', encoded => 1,
    data => [ ( 0 .. 0xffff ) ],
    contains => { 0 => 1, 1 => 1, 0xffff => 1 },
  },
  {
    type => 'u16', form => 'bin', name => 'Any 16bit except some', encoded => 1,
    data => [ ( 1, 3, 7 .. 0x100, 0x102, 0x109 .. 0xfff,
      0x1001 ... 0x2000, 0x2002 .. 0xf001, 0xf00a, 0xf00c .. 0xffff ) ],
    contains => { 0 => 0, 1 => 1, 2 => 0, 3 => 1, 4 => 0, 50 => 1, 0x100 => 1, 0x101 => 0 },
  };

at_category special => 'Special List Tests',
  {
    type => 'u16', form => 'bin', name => 'All 16 bit Primes', encoded => 1,
    createfile => sub {
      my $path = shift;
      open my $fh, "| src/intzip -b --u16 -o '$path'" or die $!;
      print $fh pack('n',$_) foreach primes_u16;
      close $fh;
    },
    contains => { 0 => 0, 1 => 0, 2 => 1, 3 => 1, 4 => 0, 5 => 1, 23 => 1, 24 => 0, 937 => 1, 1000 => 0 },
  },
  {
    type => 'u16', form => 'bin', name => 'All 16 bit Non-Primes', encoded => 1,
    createfile => sub {
      my $path = shift;
      open my $fh, "| src/intzip -b --u16 -o '$path'" or die $!;
      my %p = map { $_ => 1 } primes_u16;
      print $fh pack('n',$_) foreach grep { !exists $p{$_} } ( 0 .. 0xffff );
      close $fh;
    },
    contains => { 0 => 1, 1 => 1, 2 => 0, 3 => 0, 4 => 1, 5 => 0, 23 => 0, 24 => 1, 937 => 0, 1000 => 1 },
  },
  {
    type => 'u32', form => 'bin', name => 'All Unicode', encoded => 1,
    createfile => sub {
      my $path = shift;
      system qq{./unicode.sh | perl -ne 'print pack "N",\$_' | src/intzip -b --u32 >$path};
    },
    contains => { 0 => 1, 1 => 1, 80 => 1, '0xee0' => 0, '0x0530' => 0, '0xffffffff' => 0 },
    
  },
  {
    type => 'u32', form => 'bin', name => 'Odd Unicode', encoded => 1,
    createfile => sub {
      my $path = shift;
      system qq{./unicode.sh | awk 'NR % 2 == 0' | perl -ne 'print pack "N",\$_' | src/intzip -b --u32 >$path};
    }
  },
  {
    type => 'u64', form => 'bin', name => 'Fibonacci', encoded => 1,
    data => [qw(
      0x2 0x3 0x5 0x8 0xd 0x15 0x22 0x37 0x59 0x90 0xe9 0x179 0x262 0x3db 0x63d 0xa18 0x1055
      0x1a6d 0x2ac2 0x452f 0x6ff1 0xb520 0x12511 0x1da31 0x2ff42 0x4d973 0x7d8b5 0xcb228
      0x148add 0x213d05 0x35c7e2 0x5704e7 0x8cccc9 0xe3d1b0 0x1709e79 0x2547029 0x3c50ea2
      0x6197ecb 0x9de8d6d 0xff80c38 0x19d699a5 0x29cea5dd 0x43a53f82 0x6d73e55f 0xb11924e1
      0x11e8d0a40 0x1cfa62f21 0x2ee333961 0x4bdd96882 0x7ac0ca1e3 0xc69e60a65 0x1415f2ac48
      0x207fd8b6ad 0x3495cb62f5 0x5515a419a2 0x89ab6f7c97 0xdec1139639 0x1686c8312d0 0x2472d96a909
      0x3af9a19bbd9 0x5f6c7b064e2 0x9a661ca20bb 0xf9d297a859d 0x19438b44a658 0x28e0b4bf2bf5
      0x42244003d24d 0x6b04f4c2fe42 0xad2934c6d08f 0x1182e2989ced1 0x1c5575e509f60 0x2dd8587da6e31
      0x4a2dce62b0d91 0x780626e057bc2 0xc233f54308953 0x13a3a1c2360515 0x1fc6e116668e68
      0x336a82d89c937d 0x533163ef0321e5 0x869be6c79fb562 0xd9cd4ab6a2d747 0x16069317e428ca9
      0x23a367c34e563f0 0x39a9fadb327f099 0x5d4d629e80d5489 0x96f75d79b354522 0xf444c01834299ab
      0x18b3c1d91e77decd 0x27f80ddaa1ba7878 0x40abcfb3c0325745 0x68a3dd8e61eccfbd 0xa94fad42221f2702
    )],
  };

  

# -- end of tests --

# create autotest include
do {
  my $path = +TESTS_DIR."/gentests.at";
  LOG "create: %s", $path;
  open my $at, '>', $path or die $!;
  printf $at "m4_include([%s])\n", $_ foreach @at_files;
  close $at;
};

# create GENTESTS_AT automake include
do {
  my $path = TESTS_DIR."/gentests.am";
  LOG "create: %s", $path;
  open my $am, '>', $path or die $!;
  printf $am "GENTESTS_AT = %s\n", (join ' ', ('gentests.at', @at_files));
  close $am;
};

# create TESTDATA automake include
do {
  my $path = +TESTS_DIR."/testdata.am";
  LOG "create: %s", $path;
  open my $am, '>', $path or die $!;
  printf $am "TESTDATA = %s\n", (join ' ', map { sprintf "../%s/%s", +TESTDATA_DIR, $_ } @test_files);
  close $am;  
};

# -- utilities --

my @primes_u16;
sub primes_u16 {
  return @primes_u16 if scalar @primes_u16;
  @primes_u16 = ( 2,3,5,7,11,13,17,19,23,29 );
	for (my $p = 31; $p <= 0xffff; $p += 2)	{
		my $is = 1;
		my $s = int sqrt $p;
		foreach ( @primes_u16 ) {
			last if $_ > $s;
			next if  $p % $_;
			undef $is;
			last;
		}
		push @primes_u16, $p if $is
	}
  @primes_u16;
}

__END__