8 use Sort::Maker qw( :all ) ;
14 my( $sort_tests, $sort_styles, $default_sizes ) = @_ ;
18 benchmark_driver( $sort_tests, $sort_styles, $default_sizes ) ;
22 test_driver( $sort_tests, $sort_styles ) ;
27 my( $sort_tests, $default_styles ) = @_ ;
29 $default_styles ||= [] ;
31 my $total_tests = count_tests( $sort_tests, $default_styles ) ;
33 plan tests => $total_tests ;
35 foreach my $test ( @{$sort_tests} ) {
37 if ( $test->{skip} ) {
40 skip( "sort of $test->{name}\n",
46 make_test_sorters( $test, $default_styles ) ;
48 if ( $test->{error} ) {
50 handle_errors( $test ) ;
54 $test->{data} ||= generate_data( $test ) ;
56 #print Dumper $test->{data} ;
66 foreach my $sort_name ( sort test_name_cmp keys %{$test->{sorters}} ) {
68 #print "NAME $sort_name\n" ;
69 if ( my $error = $test->{make_error}{$sort_name} ) {
71 if ( $test->{error} && $error =~ /$test->{error}/ ) {
73 ok( 1, "$sort_name sort of $test->{name}" ) ;
77 ok( 0, "$sort_name sort of $test->{name}" ) ;
78 print "unexpected error:\n$@\n" ;
88 my $input = $test->{data} ;
90 my @gold_sorted = sort { $test->{gold}->() } @{$input} ;
92 foreach my $sort_name ( sort test_name_cmp keys %{$test->{sorters}} ) {
94 my @sorter_in = $sort_name =~ /ref_in/ ? $input : @{$input} ;
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/ ;
100 my $ok = eq_array( \@gold_sorted, \@test_sorted ) ;
102 print "TEST [@test_sorted]\n" unless $ok ;
103 print "GOLD [@gold_sorted]\n" unless $ok ;
105 ok( $ok, "$sort_name sort of $test->{name}" ) ;
111 my @a = split /_/, $a ;
112 my @b = split /_/, $b ;
114 lc $a[0] cmp lc $b[0]
116 lc $a[1] cmp lc $b[1]
118 lc $a[2] cmp lc $b[2]
121 sub benchmark_driver {
123 my( $sort_tests, $default_styles, $default_sizes ) = @_ ;
125 my $duration = shift @ARGV || -2 ;
127 foreach my $test ( @{$sort_tests} ) {
129 next if $test->{skip} ;
131 $test->{input_sets} = [generate_data( $test, $default_sizes )] ;
133 make_test_sorters( $test, $default_styles ) ;
135 run_benchmarks( $test, $duration ) ;
141 my( $test, $duration ) = @_ ;
143 my( %entries, @input, $in_ref ) ;
145 while( my( $name, $sorter ) = each %{$test->{sorters}} ) {
147 $entries{ $name } = $name =~ /ref_in/ ?
148 sub { my @sorted = $sorter->( $in_ref ) } :
149 sub { my @sorted = $sorter->( @input ) } ;
153 sub { my @sorted = sort { $test->{gold}->() } @input } ;
155 foreach my $input_set ( @{$test->{input_sets}} ) {
157 my $size = @{$input_set} ;
159 print "Sorting $size elements of '$test->{name}'\n" ;
161 @input = @{$input_set} ;
162 $in_ref = $input_set ;
164 timethese( $duration, \%entries ) ;
170 my( $test, $default_sizes ) = @_ ;
172 my $gen_code = $test->{gen} ;
173 $gen_code or die "no 'gen' code for test $test->{name}" ;
175 my @sizes = @{ $test->{sizes} || $default_sizes || [100] } ;
177 # return a single data set when called in scalar context (from test_driver)
179 return [ map $gen_code->(), 1 .. shift @sizes ] unless wantarray ;
181 # return multiple data sets when called in list context (from benchmark_driver)
183 return map [ map $gen_code->(), 1 .. $_ ], @sizes ;
186 sub make_test_sorters {
188 my( $test, $default_styles ) = @_ ;
190 my $styles = $test->{styles} || $default_styles ;
192 # if no styles, we need a dummy style just to force the style loop
194 $styles = [ qw(NO_STYLE) ] unless @{$styles} ;
196 my $suffix = ( $test->{ref_in} ? '_RI' : '' ) .
197 ( $test->{ref_out} ? '_RO' : '' ) ;
199 my $args = $test->{args} or die "$test->{name} has no args\n" ;
200 my $arg_sets = ( ref $args eq 'HASH' ) ? $args : { '' => $args } ;
202 foreach my $arg_name ( sort keys %{$arg_sets} ) {
204 my $test_args = $arg_sets->{$arg_name} ;
206 foreach my $style ( @{$styles} ) {
208 my $sort_name = $arg_name ?
209 "${style}_$arg_name" : "$style$suffix" ;
211 # if no real styles, use an empty list for them
213 my @style_args = $style eq 'NO_STYLE' ? () : $style ;
215 my $sorter = make_sorter( @style_args, @{$test_args} ) ;
217 #print "sorter [$sorter]\n" ;
218 #print sorter_source( $sorter ) ;
221 #print "SOURCE $test->{source}\n" ;
225 #print "SORT $sort_name [$@]\n" ;
227 $test->{make_error}{$sort_name} = $@ ;
228 $test->{sorters}{$sort_name} = 'NONE' ;
232 print "Source of $sort_name $test->{name} is:\n",
233 sorter_source( $sorter ) if $test->{source} ;
235 $test->{sorters}{$sort_name} = $sorter ;
239 # all sorters built ok
246 my( $tests, $default_styles ) = @_ ;
250 foreach my $test ( @{$tests} ) {
252 my $style_count = @{ $test->{styles} || $default_styles } || 1 ;
254 my $arg_sets_count = ref $test->{args} eq 'ARRAY' ?
255 1 : keys %{$test->{args}} ;
257 my $test_count = $style_count * $arg_sets_count ;
258 $test->{count} = $test_count ;
260 $sum += $test_count ;
266 my @alpha_digit = ( 'a' .. 'z', 'A' .. 'Z', '0' .. '9' ) ;
267 my @alpha = ( 'a' .. 'z', 'A' .. 'Z' ) ;
268 my @bytes = ( "\x00" .. "\xff" ) ;
272 rand_string( \@alpha_digit, @_ ) ;
277 rand_string( \@alpha, @_ ) ;
282 rand_string( \@bytes, @_ ) ;
287 my( $char_set, $min_len, $max_len ) = @_ ;
290 $max_len ||= $min_len ;
292 my $length = $min_len + int rand( $max_len - $min_len + 1 ) ;
294 return join '', map $char_set->[rand @{$char_set}], 1 .. $length ;
299 my( $lo_range, $hi_range ) = @_ ;
301 ( $lo_range, $hi_range ) = ( 0, $lo_range ) unless $hi_range ;
303 my $range = $hi_range - $lo_range ;
305 return rand( $range ) + $lo_range ;