t/common.pm

   1 use strict ;
   2
   3 use Data::Dumper ;
   4
   5 use Test::More ;
   6 use Benchmark ;
   7
   8 use Sort::Maker qw( :all ) ;
   9
  10 use vars '$bench' ;
  11
  12 sub common_driver {
  13
  14         my( $sort_tests, $sort_styles, $default_sizes ) = @_ ;
  15
  16         if ( $bench ) {
  17
  18                 benchmark_driver( $sort_tests, $sort_styles, $default_sizes ) ;
  19                 return ;
  20         }
  21
  22         test_driver( $sort_tests, $sort_styles ) ;
  23 }
  24
  25 sub test_driver {
  26
  27         my( $sort_tests, $default_styles ) = @_ ;
  28
  29         $default_styles ||= [] ;
  30
  31         my $total_tests = count_tests( $sort_tests, $default_styles ) ;
  32
  33         plan tests => $total_tests ;
  34
  35         foreach my $test ( @{$sort_tests} ) {
  36
  37                 if ( $test->{skip} ) {
  38
  39                         SKIP: {
  40                                 skip( "sort of $test->{name}\n",
  41                                         $test->{count} ) ;
  42                         }
  43                         next ;
  44                 }
  45
  46                 make_test_sorters( $test, $default_styles ) ;
  47
  48                 if ( $test->{error} ) {
  49
  50                         handle_errors( $test ) ;
  51                         next ;
  52                 }
  53
  54                 $test->{data} ||= generate_data( $test ) ;
  55
  56 #print Dumper $test->{data} ;
  57
  58                 run_tests( $test ) ;
  59         }
  60 }
  61
  62 sub handle_errors {
  63
  64         my( $test ) = @_ ;
  65
  66         foreach my $sort_name ( sort test_name_cmp keys %{$test->{sorters}} ) {
  67
  68 #print "NAME $sort_name\n" ;
  69                 if ( my $error = $test->{make_error}{$sort_name} ) {
  70
  71                         if ( $test->{error} && $error =~ /$test->{error}/ ) {
  72
  73                                 ok( 1, "$sort_name sort of $test->{name}" ) ;
  74                         }
  75                         else {
  76
  77                                 ok( 0, "$sort_name sort of $test->{name}" ) ;
  78                                 print "unexpected error:\n$@\n" ;
  79                         }
  80                 }
  81         }
  82 }
  83
  84 sub run_tests {
  85
  86         my( $test ) = @_ ;
  87
  88         my $input = $test->{data} ;
  89
  90         my @gold_sorted = sort { $test->{gold}->() } @{$input} ;
  91
  92         foreach my $sort_name ( sort test_name_cmp keys %{$test->{sorters}} ) {
  93
  94                 my @sorter_in = $sort_name =~ /ref_in/ ? $input : @{$input} ;
  95
  96                 my $sorter = $test->{sorters}{$sort_name} ;
  97                 my @test_sorted = $sorter->( @sorter_in ) ;
  98                 @test_sorted = @{$test_sorted[0]} if $sort_name =~ /ref_out/ ;
  99
 100                 my $ok = eq_array( \@gold_sorted, \@test_sorted ) ;
 101
 102 print "TEST [@test_sorted]\n" unless $ok ;
 103 print "GOLD [@gold_sorted]\n" unless $ok ;
 104
 105                 ok( $ok, "$sort_name sort of $test->{name}" ) ;
 106         }
 107 }
 108
 109 sub test_name_cmp {
 110
 111         my @a = split /_/, $a ;
 112         my @b = split /_/, $b ;
 113
 114         lc $a[0] cmp lc $b[0]
 115                 ||
 116         lc $a[1] cmp lc $b[1]
 117                 ||
 118         lc $a[2] cmp lc $b[2]
 119 }
 120
 121 sub benchmark_driver {
 122
 123         my( $sort_tests, $default_styles, $default_sizes ) = @_ ;
 124
 125         my $duration = shift @ARGV || -2 ;
 126
 127         foreach my $test ( @{$sort_tests} ) {
 128
 129                 next if $test->{skip} ;
 130
 131                 $test->{input_sets} = [generate_data( $test, $default_sizes )] ;
 132
 133                 make_test_sorters( $test, $default_styles ) ;
 134
 135                 run_benchmarks( $test, $duration ) ;
 136         }
 137 }
 138
 139 sub run_benchmarks {
 140
 141         my( $test, $duration ) = @_ ;
 142
 143         my( %entries, @input, $in_ref ) ;
 144
 145         while( my( $name, $sorter ) = each %{$test->{sorters}} ) {
 146
 147                 $entries{ $name } = $name =~ /ref_in/ ?
 148                         sub { my @sorted = $sorter->( $in_ref ) } :
 149                         sub { my @sorted = $sorter->( @input ) } ;
 150         }
 151
 152         $entries{ 'gold' } =
 153                 sub { my @sorted = sort { $test->{gold}->() } @input } ;
 154
 155         foreach my $input_set ( @{$test->{input_sets}} ) {
 156
 157                 my $size = @{$input_set} ;
 158
 159                 print "Sorting $size elements of '$test->{name}'\n" ;
 160
 161                 @input = @{$input_set} ;
 162                 $in_ref = $input_set ;
 163
 164                 timethese( $duration, \%entries ) ;
 165         }
 166 }
 167
 168 sub generate_data {
 169
 170         my( $test, $default_sizes ) = @_ ;
 171
 172         my $gen_code = $test->{gen} ;
 173         $gen_code or die "no 'gen' code for test $test->{name}" ;
 174
 175         my @sizes = @{ $test->{sizes} || $default_sizes || [100] } ;
 176
 177 # return a single data set when called in scalar context (from test_driver)
 178
 179         return [ map $gen_code->(), 1 .. shift @sizes ] unless wantarray ;
 180
 181 # return multiple data sets when called in list context (from benchmark_driver)
 182
 183         return map [ map $gen_code->(), 1 .. $_ ], @sizes ;
 184 }
 185
 186 sub make_test_sorters {
 187
 188         my( $test, $default_styles ) = @_ ;
 189
 190         my $styles = $test->{styles} || $default_styles ;
 191
 192 # if no styles, we need a dummy style just to force the style loop
 193
 194         $styles = [ qw(NO_STYLE) ] unless @{$styles} ;
 195
 196         my $suffix = ( $test->{ref_in} ? '_RI' : '' ) .
 197                      ( $test->{ref_out} ? '_RO' : '' ) ;
 198
 199         my $args = $test->{args} or die "$test->{name} has no args\n" ;
 200         my $arg_sets = ( ref $args eq 'HASH' ) ? $args : { '' => $args } ;
 201
 202         foreach my $arg_name ( sort keys %{$arg_sets} ) {
 203
 204                 my $test_args = $arg_sets->{$arg_name} ;
 205
 206                 foreach my $style ( @{$styles} ) {
 207
 208                         my $sort_name = $arg_name ?
 209                                 "${style}_$arg_name" : "$style$suffix" ;
 210
 211 # if no real styles, use an empty list for them
 212
 213                         my @style_args = $style eq 'NO_STYLE' ? () : $style ;
 214
 215                         my $sorter = make_sorter( @style_args, @{$test_args} ) ;
 216
 217 #print "sorter [$sorter]\n" ;
 218 #print sorter_source( $sorter ) ;
 219
 220
 221 #print "SOURCE $test->{source}\n" ;
 222
 223                         unless( $sorter ) {
 224
 225 #print "SORT $sort_name [$@]\n" ;
 226
 227                                 $test->{make_error}{$sort_name} = $@ ;
 228                                 $test->{sorters}{$sort_name} = 'NONE' ;
 229                                 next ;
 230                         }
 231
 232                         print "Source of $sort_name $test->{name} is:\n",
 233                                 sorter_source( $sorter ) if $test->{source} ;
 234
 235                         $test->{sorters}{$sort_name} = $sorter ;
 236                 }
 237         }
 238
 239 # all sorters built ok
 240
 241         return 1 ;
 242 }
 243
 244 sub count_tests {
 245
 246         my( $tests, $default_styles ) = @_ ;
 247
 248         my $sum = 0 ;
 249
 250         foreach my $test ( @{$tests} ) {
 251
 252                 my $style_count = @{ $test->{styles} || $default_styles } || 1 ;
 253
 254                 my $arg_sets_count = ref $test->{args} eq 'ARRAY' ?
 255                         1 : keys %{$test->{args}} ;
 256
 257                 my $test_count = $style_count * $arg_sets_count ;
 258                 $test->{count} = $test_count ;
 259
 260                 $sum += $test_count ;
 261         }
 262
 263         return $sum ;
 264 }
 265
 266 my @alpha_digit = ( 'a' .. 'z', 'A' .. 'Z', '0' .. '9' ) ;
 267 my @alpha = ( 'a' .. 'z', 'A' .. 'Z' ) ;
 268 my @bytes = ( "\x00" .. "\xff" ) ;
 269
 270 sub rand_token {
 271
 272         rand_string( \@alpha_digit, @_ ) ;
 273 }
 274
 275 sub rand_alpha {
 276
 277         rand_string( \@alpha, @_ ) ;
 278 }
 279
 280 sub rand_bytes {
 281
 282         rand_string( \@bytes, @_ ) ;
 283 }
 284
 285 sub rand_string {
 286
 287         my( $char_set, $min_len, $max_len ) = @_ ;
 288
 289         $min_len ||= 8 ;
 290         $max_len ||= $min_len ;
 291
 292         my $length = $min_len + int rand( $max_len - $min_len + 1 ) ;
 293
 294         return join '', map $char_set->[rand @{$char_set}], 1 .. $length ;
 295 }
 296
 297 sub rand_number {
 298
 299         my( $lo_range, $hi_range ) = @_ ;
 300
 301         ( $lo_range, $hi_range ) = ( 0, $lo_range ) unless $hi_range ;
 302
 303         my $range = $hi_range - $lo_range ;
 304
 305         return rand( $range ) + $lo_range ;
 306 }
 307
 308 sub rand_choice {
 309
 310         return @_[rand @_] ;
 311 }
 312
 313 1 ;