In perl.git, the branch smueller/sort has been updated <http://perl5.git.perl.org/perl.git/commitdiff/e1a9c7394ad3f8115f02969c00f5f468dd8a8e44?hp=a5f38f3d7936fb94d1b97aab22f6e4092fd7e37b>
- Log ----------------------------------------------------------------- commit e1a9c7394ad3f8115f02969c00f5f468dd8a8e44 Author: Steffen Mueller <[email protected]> Date: Thu Nov 24 18:50:35 2011 +0100 FIXME WIP Feeble attempt to improve failure modes M pp_sort.c commit 0ed9a18b326eb4d3dc69b12ed510b9360fe99226 Author: Steffen Mueller <[email protected]> Date: Mon Nov 21 08:04:57 2011 +0100 More brutal sort optimization tests M t/op/sort.t ----------------------------------------------------------------------- Summary of changes: pp_sort.c | 35 ++++++++--- t/op/sort.t | 186 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 211 insertions(+), 10 deletions(-) diff --git a/pp_sort.c b/pp_sort.c index 5217d95..9bd34ad 100644 --- a/pp_sort.c +++ b/pp_sort.c @@ -1990,27 +1990,44 @@ S_amagic_cmp_locale(pTHX_ register SV *const str1, register SV *const str2) return sv_cmp_locale(str1, str2); } +static const char S_no_symref_sv[] = + "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use"; + /* Checks in the following code could be moved to the preprocessing * step in pp_sort. In fact, that might make tons of sense since it * could include moving the inner-magic check out of the O(nlogn) part. */ +#define HAVE_STRICT_REFS (CopHINTS_get(PL_curcop) & HINT_STRICT_REFS) +#define NOT_AN_ARRAY_ERROR(sv) \ + Perl_die(aTHX_ S_no_symref_sv, (sv), \ + (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), \ + "an ARRAY") + #define REUSABLE_DEREF_BODY \ STMT_START { \ SvGETMAGIC(a); /* FIXME check for this outside the */ \ SvGETMAGIC(b); /* sort function somehow */ \ - if (!SvROK(a) || !SvROK(b)) { \ - Perl_croak(aTHX_ "Not an ARRAY reference"); \ - } \ + if (!SvROK(a) && HAVE_STRICT_REFS) \ + NOT_AN_ARRAY_ERROR(a); \ + if (!SvROK(b) && HAVE_STRICT_REFS) \ + NOT_AN_ARRAY_ERROR(b); \ a = SvRV(a); \ b = SvRV(b); \ - if (SvTYPE(a) != SVt_PVAV || SvTYPE(a) != SVt_PVAV) { \ - Perl_croak(aTHX_ "Not an ARRAY reference"); \ + if (SvTYPE(a) == SVt_PVAV) { elem1=NULL;\ + elem1 = Perl_av_fetch(aTHX_ (AV*)a, 0, 0); \ + if (*elem1 == &PL_sv_undef) { \ + mg_get(*elem1); \ + } \ + } \ + else if (HAVE_STRICT_REFS) { \ + NOT_AN_ARRAY_ERROR(a); } \ + else {\ + elem1 = &PL_sv_undef); \ + } \ + if (SvTYPE(a) != SVt_PVAV || SvTYPE(b) != SVt_PVAV) { \ + Perl_die(aTHX_ "Not an ARRAY reference"); \ } \ - elem1 = Perl_av_fetch(aTHX_ (AV*)a, 0, 0); \ elem2 = Perl_av_fetch(aTHX_ (AV*)b, 0, 0); \ - if (*elem1 == &PL_sv_undef) { \ - mg_get(*elem1); \ - } \ if (*elem2 == &PL_sv_undef) { \ mg_get(*elem2); \ } \ diff --git a/t/op/sort.t b/t/op/sort.t index acc3fc4..e8006e0 100644 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -6,7 +6,7 @@ BEGIN { require 'test.pl'; } use warnings; -plan( tests => 198 ); +plan( tests => 206 ); # these shouldn't hang { @@ -1061,3 +1061,187 @@ foreach my $datatype (keys %data_generators) { } } +# The following set of tests is meant to ensure that the optimized +# dereferencing sort functions produce the same warnings and errors as +# the ordinary Perl. + +{ + use warnings; + use strict; + local $| = 1; + my $debug = 1; + + my (@in, @out); + my ($should_be_fatal, $should_warn, + $fatal_result, $warn_result, + $expected_msg, $test_name); + my $clear = sub { + $should_warn = $should_be_fatal + = $fatal_result + = $warn_result + = $expected_msg + = undef; + }; + my $warn_setup_hook = sub { + $expected_msg = $_[0]; + chomp $expected_msg; + print "# Caught warning: '$expected_msg'.\n" if $debug; + $expected_msg =~ s/ at .*? line [0-9]+\.\z//s + or die "Bad warn message: '$expected_msg'"; + $expected_msg = qr/\Q$expected_msg\E/; + $should_warn = 1; + }; + my $warn_test_hook = sub { + my $str = $_[0]; + chomp $str; + print "# Caught warning: '$str'.\n" if $debug; + $warn_result = ($str =~ $expected_msg); + }; + my $die_setup_hook = sub { + $expected_msg = $@ || 'Zombie error'; + chomp $expected_msg; + print "# Caught fatal exception: '$expected_msg'.\n" if $debug; + $expected_msg =~ s/ at .*? line [0-9]+\.\z//s + or die "Bad error message: '$expected_msg'"; + $expected_msg = qr/\Q$expected_msg\E/; + $should_be_fatal = 1; + }; + my $die_test_hook = sub { + my $err = $@ || 'Zombie error'; + chomp $err; + die if $err =~ /^Bad warn message/; # don't choke on our own + print "# Caught fatal exception: '$err'.\n" if $debug; + $fatal_result = $err =~ $expected_msg; + }; + + + # === Failure mode tests start === + + $test_name = 'constant scalars'; + $clear->(); + local $SIG{__WARN__} = $warn_setup_hook; + eval { @out = sort {$a->[1] <=> $b->[0]} qw(123 123); 1} + or $die_setup_hook->(); + + local $SIG{__WARN__} = $warn_test_hook; + eval { @out = sort {$a->[0] <=> $b->[0]} qw(123 123); 1} + or $die_test_hook->(); + ok($should_warn ? $warn_result : !$warn_result, "Expected warning for '$test_name'"); + ok($should_be_fatal ? $fatal_result: !$fatal_result, "Expected exception for '$test_name'"); + + $test_name = 'empty list'; + $clear->(); + local $SIG{__WARN__} = $warn_setup_hook; + eval { @out = sort {$a->[1] <=> $b->[0]} qw(); 1} + or $die_setup_hook->(); + + local $SIG{__WARN__} = $warn_test_hook; + eval { @out = sort {$a->[0] <=> $b->[0]} qw(); 1} + or $die_test_hook->(); + ok($should_warn ? $warn_result : !$warn_result, "Expected warning for '$test_name'"); + ok($should_be_fatal ? $fatal_result : !$fatal_result, "Expected exception for '$test_name'"); + + $test_name = 'empty arrays'; + $clear->(); + local $SIG{__WARN__} = $warn_setup_hook; + eval { @out = sort {$a->[1] <=> $b->[0]} ([], []); 1} + or $die_setup_hook->(); + + local $SIG{__WARN__} = $warn_test_hook; + eval { @out = sort {$a->[0] <=> $b->[0]} ([], []); 1} + or $die_test_hook->(); + ok($should_warn ? $warn_result : !$warn_result, "Expected warning for '$test_name'"); + ok($should_be_fatal ? $fatal_result : !$fatal_result, "Expected exception for '$test_name'"); + + $test_name = 'arrays with undef'; + $clear->(); + local $SIG{__WARN__} = $warn_setup_hook; + eval { @out = sort {$a->[1] <=> $b->[0]} ([undef, undef], [undef, undef]); 1} + or $die_setup_hook->(); + + local $SIG{__WARN__} = $warn_test_hook; + eval { @out = sort {$a->[0] <=> $b->[0]} ([undef, undef], [undef, undef]); 1} + or $die_test_hook->(); + ok($should_warn ? $warn_result : !$warn_result, "Expected warning for '$test_name'"); + ok($should_be_fatal ? $fatal_result : !$fatal_result, "Expected exception for '$test_name'"); + + $test_name = 'hashrefs'; + $clear->(); + local $SIG{__WARN__} = $warn_setup_hook; + eval { @out = sort {$a->[1] <=> $b->[0]} ({}, {}); 1} + or $die_setup_hook->(); + + local $SIG{__WARN__} = $warn_test_hook; + eval { @out = sort {$a->[0] <=> $b->[0]} ({}, {}); 1} + or $die_test_hook->(); + ok($should_warn ? $warn_result : !$warn_result, "Expected warning for '$test_name'"); + ok($should_be_fatal ? $fatal_result : !$fatal_result, "Expected exception for '$test_name'"); + + + # === Failure mode tests without strictures start === + # Note that these tests are exactly the same as above. + # Thus, modify the above set and copy them here. Damn compile-time + # effect of strictures... + no strict; + + $test_name = 'constant scalars'; + $clear->(); + local $SIG{__WARN__} = $warn_setup_hook; + eval { @out = sort {$a->[1] <=> $b->[0]} qw(123 123); 1} + or $die_setup_hook->(); + + local $SIG{__WARN__} = $warn_test_hook; + eval { @out = sort {$a->[0] <=> $b->[0]} qw(123 123); 1} + or $die_test_hook->(); + ok($should_warn ? $warn_result : !$warn_result, "Expected warning for '$test_name'"); + ok($should_be_fatal ? $fatal_result: !$fatal_result, "Expected exception for '$test_name'"); + + $test_name = 'empty list'; + $clear->(); + local $SIG{__WARN__} = $warn_setup_hook; + eval { @out = sort {$a->[1] <=> $b->[0]} qw(); 1} + or $die_setup_hook->(); + + local $SIG{__WARN__} = $warn_test_hook; + eval { @out = sort {$a->[0] <=> $b->[0]} qw(); 1} + or $die_test_hook->(); + ok($should_warn ? $warn_result : !$warn_result, "Expected warning for '$test_name'"); + ok($should_be_fatal ? $fatal_result : !$fatal_result, "Expected exception for '$test_name'"); + + $test_name = 'empty arrays'; + $clear->(); + local $SIG{__WARN__} = $warn_setup_hook; + eval { @out = sort {$a->[1] <=> $b->[0]} ([], []); 1} + or $die_setup_hook->(); + + local $SIG{__WARN__} = $warn_test_hook; + eval { @out = sort {$a->[0] <=> $b->[0]} ([], []); 1} + or $die_test_hook->(); + ok($should_warn ? $warn_result : !$warn_result, "Expected warning for '$test_name'"); + ok($should_be_fatal ? $fatal_result : !$fatal_result, "Expected exception for '$test_name'"); + + $test_name = 'arrays with undef'; + $clear->(); + local $SIG{__WARN__} = $warn_setup_hook; + eval { @out = sort {$a->[1] <=> $b->[0]} ([undef, undef], [undef, undef]); 1} + or $die_setup_hook->(); + + local $SIG{__WARN__} = $warn_test_hook; + eval { @out = sort {$a->[0] <=> $b->[0]} ([undef, undef], [undef, undef]); 1} + or $die_test_hook->(); + ok($should_warn ? $warn_result : !$warn_result, "Expected warning for '$test_name'"); + ok($should_be_fatal ? $fatal_result : !$fatal_result, "Expected exception for '$test_name'"); + + $test_name = 'hashrefs'; + $clear->(); + local $SIG{__WARN__} = $warn_setup_hook; + eval { @out = sort {$a->[1] <=> $b->[0]} ({}, {}); 1} + or $die_setup_hook->(); + + local $SIG{__WARN__} = $warn_test_hook; + eval { @out = sort {$a->[0] <=> $b->[0]} ({}, {}); 1} + or $die_test_hook->(); + ok($should_warn ? $warn_result : !$warn_result, "Expected warning for '$test_name'"); + ok($should_be_fatal ? $fatal_result : !$fatal_result, "Expected exception for '$test_name'"); +} + -- Perl5 Master Repository
