New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Segfault in debugger with tr// and UTF8 #9606
Comments
From @clintongormleyCreated by @clintongormleyThis is a bug report for perl from clint@traveljury.com, ----------------------------------------------------------------- The offending line appears to be: tr[aAbB\x{142}][]cd; But only when it is invoked by string eval'ed code, or via I will upload a script which demonstrates the bug. Normally, under Assertion ((svtype)((hv)->sv_flags & 0xff)) == SVt_PVHV failed: file Also, I managed to trigger the following error: panic: swash_fetch got swatch of unexpected bit width Unfortunately, I can't recreate the combination of code I had when that The attached code works fine under the debugger in 5.8.8 (32 bit) Perl Info
|
From @clintongormley |
From @iabynOn Fri, Dec 19, 2008 at 05:47:50AM -0800, Clinton Gormley wrote:
I can confirm this bug is still present in bleed, but not in 5.8.8, 5.8.9 -- |
The RT System itself - Status changed from 'new' to 'open' |
From p5p@spam.wizbit.be
A binary search with -Dusethreads and -DDEBUGGING: (-Dusethreads is First change: segfault ----Program---- $ENV{PERLDB_OPTS} = "NonStop"; ----Output of .../poonaNK/perl-5.9.4@29764/bin/perl---- ----EOF ($?='0')---- ----EOF ($?='1536')---- http://public.activestate.com/cgi-bin/perlbrowse/p/29765 make tr/// threadsafe by moving swash into pad Second change: failed assertion ----Program---- $ENV{PERLDB_OPTS} = "NonStop"; ----Output of .../pDUJMDT/perl-5.9.5@31921/bin/perl---- ----EOF ($?='1536')---- ----EOF ($?='0')---- http://public.activestate.com/cgi-bin/perlbrowse/p/31922 assert that what is passed into the hash functions is really an Kind regards, Bram |
From @schwernI've reduced this problem down to a lot less code which hopefully will #!/usr/bin/perl my $sub_ref = sub { # panic in the debugger If you put the map back in it segfaults. #!/usr/bin/perl my $sub_ref = sub { # segfault in the debugger |
From @schwernTODO tests for this can be had from git://github.com/schwern/perl.git in The clean up patch is not strictly necessary, but it wasn't clear what |
From @schwern0002-TODO-tests-for-61520.patchFrom e4aebee28b9f0c42dc886df170d40519efb16dfc Mon Sep 17 00:00:00 2001
From: Michael G. Schwern <schwern@pobox.com>
Date: Sat, 11 Jul 2009 00:39:46 -0700
Subject: [PATCH 2/2] TODO tests for 61520
---
t/op/sort.t | 30 +++++++++++++++++++++++++++++-
1 files changed, 29 insertions(+), 1 deletions(-)
diff --git a/t/op/sort.t b/t/op/sort.t
index cbb27a7..ce4fc36 100644
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -6,7 +6,7 @@ BEGIN {
require 'test.pl';
}
use warnings;
-plan( tests => 144 );
+plan( tests => 146 );
# these shouldn't hang
{
@@ -801,3 +801,31 @@ ok("@b", "10 9 8 7 6 5 4 3 2 1", "return with SVs on stack");
sub ret_with_stacked { $_ = ($a<=>$b) + do {return $b <=> $a} }
@b = sort ret_with_stacked 1..10;
ok("@b", "10 9 8 7 6 5 4 3 2 1", "return with SVs on stack");
+
+
+
+# rt.cpan.org 61520
+# tr/// with utf8 inside a sort in a sub ref or eval'd sub panics and/or segfaults.
+TODO: {
+ local $TODO = "rt.cpan.org 61520";
+
+ # Make the debugger just run
+ local $ENV{PERLDB_OPTS} = "NonStop";
+
+ # This causes a panic
+ fresh_perl_is(<<'CODE', "abc", { switches => ["-d"] }, "tr/// with utf8 inside sort in a sub ref");
+my $sub_ref = sub {
+ return sort { $a =~ tr[\x{142}][]; } qw(a b c);
+};
+print $sub_ref->();
+CODE
+
+ # With the map its a segfault
+ fresh_perl_is(<<'CODE', "abc", { switches => ["-d"] }, "tr/// with utf8 inside sort in a sub ref");
+my $sub_ref = sub {
+ return sort { $a =~ tr[\x{142}][]; } map { $_ } qw(a b c);
+};
+print $sub_ref->();
+CODE
+
+}
--
1.6.2.4
|
From @schwern0001-Clean-up-t-op-sort.t-to-constrain-tests-which-use-a.patchFrom f16e51bbb75c3ec4578fe2b4adae61935f32e5ee Mon Sep 17 00:00:00 2001
From: Michael G. Schwern <schwern@pobox.com>
Date: Sat, 11 Jul 2009 00:34:31 -0700
Subject: [PATCH 1/2] Clean up t/op/sort.t to constrain tests which use a particular package.
Also make use of is() instead of a home rolled conflicting Test.pm style ok().
---
t/op/sort.t | 313 +++++++++++++++++++++++++++++------------------------------
1 files changed, 153 insertions(+), 160 deletions(-)
diff --git a/t/op/sort.t b/t/op/sort.t
index 4473c32..cbb27a7 100644
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -2,7 +2,8 @@
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib); require 'test.pl';
+ @INC = qw(. ../lib);
+ require 'test.pl';
}
use warnings;
plan( tests => 144 );
@@ -260,48 +261,43 @@ $x = join('', sort { $a <=> $b } 3, 1, 2);
cmp_ok($x,'eq','123',q(optimized-away comparison block doesn't take any other arguments away with it));
# test sorting in non-main package
-package Foo;
-@a = ( 5, 19, 1996, 255, 90 );
-@b = sort { $b <=> $a } @a;
-main::cmp_ok("@b",'eq','1996 255 90 19 5','not in main:: 1');
-
-
-@b = sort main::Backwards_stacked @a;
-main::cmp_ok("@b",'eq','90 5 255 1996 19','not in main:: 2');
-
-
-# check if context for sort arguments is handled right
-
-
-sub test_if_list {
- my $gimme = wantarray;
- main::is($gimme,1,'wantarray 1');
-
-
-}
-my $m = sub { $a <=> $b };
-
-sub cxt_one { sort $m test_if_list() }
-cxt_one();
-sub cxt_two { sort { $a <=> $b } test_if_list() }
-cxt_two();
-sub cxt_three { sort &test_if_list() }
-cxt_three();
+{
+ package Foo;
+ @a = ( 5, 19, 1996, 255, 90 );
+ @b = sort { $b <=> $a } @a;
+ ::cmp_ok("@b",'eq','1996 255 90 19 5','not in main:: 1');
-sub test_if_scalar {
- my $gimme = wantarray;
- main::is(!($gimme or !defined($gimme)),1,'wantarray 2');
+ @b = sort ::Backwards_stacked @a;
+ ::cmp_ok("@b",'eq','90 5 255 1996 19','not in main:: 2');
+ # check if context for sort arguments is handled right
+ sub test_if_list {
+ my $gimme = wantarray;
+ ::is($gimme,1,'wantarray 1');
+ }
+ my $m = sub { $a <=> $b };
+
+ sub cxt_one { sort $m test_if_list() }
+ cxt_one();
+ sub cxt_two { sort { $a <=> $b } test_if_list() }
+ cxt_two();
+ sub cxt_three { sort &test_if_list() }
+ cxt_three();
+
+ sub test_if_scalar {
+ my $gimme = wantarray;
+ ::is(!($gimme or !defined($gimme)),1,'wantarray 2');
+ }
+ $m = \&test_if_scalar;
+ sub cxt_four { sort $m 1,2 }
+ @x = cxt_four();
+ sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 }
+ @x = cxt_five();
+ sub cxt_six { sort test_if_scalar 1,2 }
+ @x = cxt_six();
}
-$m = \&test_if_scalar;
-sub cxt_four { sort $m 1,2 }
-@x = cxt_four();
-sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 }
-@x = cxt_five();
-sub cxt_six { sort test_if_scalar 1,2 }
-@x = cxt_six();
# test against a reentrancy bug
{
@@ -316,89 +312,81 @@ sub cxt_six { sort test_if_scalar 1,2 }
Bar::reenter() unless $init++;
$a <=> $b
} qw/4 3 1 2/;
- main::cmp_ok("@b",'eq','1 2 3 4','reenter 1');
+ cmp_ok("@b",'eq','1 2 3 4','reenter 1');
- main::ok(!$def,'reenter 2');
+ ok(!$def,'reenter 2');
}
{
sub routine { "one", "two" };
@a = sort(routine(1));
- main::cmp_ok("@a",'eq',"one two",'bug id 19991001.003');
+ cmp_ok("@a",'eq',"one two",'bug id 19991001.003');
}
-#my $test = 59;
-sub ok { main::cmp_ok($_[0],'eq',$_[1],$_[2]);
-# print "not " unless $_[0] eq $_[1];
-# print "ok $test - $_[2]\n";
-# print "#[$_[0]] ne [$_[1]]\n" unless $_[0] eq $_[1];
-# $test++;
-}
-
# check for in-place optimisation of @a = sort @a
{
my ($r1,$r2,@a);
our @g;
@g = (3,2,1); $r1 = \$g[2]; @g = sort @g; $r2 = \$g[0];
- ok "$r1-@g", "$r2-1 2 3", "inplace sort of global";
+ is "$r1-@g", "$r2-1 2 3", "inplace sort of global";
@a = qw(b a c); $r1 = \$a[1]; @a = sort @a; $r2 = \$a[0];
- ok "$r1-@a", "$r2-a b c", "inplace sort of lexical";
+ is "$r1-@a", "$r2-a b c", "inplace sort of lexical";
@g = (2,3,1); $r1 = \$g[1]; @g = sort { $b <=> $a } @g; $r2 = \$g[0];
- ok "$r1-@g", "$r2-3 2 1", "inplace reversed sort of global";
+ is "$r1-@g", "$r2-3 2 1", "inplace reversed sort of global";
@g = (2,3,1);
$r1 = \$g[1]; @g = sort { $a<$b?1:$a>$b?-1:0 } @g; $r2 = \$g[0];
- ok "$r1-@g", "$r2-3 2 1", "inplace custom sort of global";
+ is "$r1-@g", "$r2-3 2 1", "inplace custom sort of global";
sub mysort { $b cmp $a };
@a = qw(b c a); $r1 = \$a[1]; @a = sort mysort @a; $r2 = \$a[0];
- ok "$r1-@a", "$r2-c b a", "inplace sort with function of lexical";
+ is "$r1-@a", "$r2-c b a", "inplace sort with function of lexical";
use Tie::Array;
my @t;
tie @t, 'Tie::StdArray';
@t = qw(b c a); @t = sort @t;
- ok "@t", "a b c", "inplace sort of tied array";
+ is "@t", "a b c", "inplace sort of tied array";
@t = qw(b c a); @t = sort mysort @t;
- ok "@t", "c b a", "inplace sort of tied array with function";
+ is "@t", "c b a", "inplace sort of tied array with function";
# [perl #29790] don't optimise @a = ('a', sort @a) !
@g = (3,2,1); @g = ('0', sort @g);
- ok "@g", "0 1 2 3", "un-inplace sort of global";
+ is "@g", "0 1 2 3", "un-inplace sort of global";
@g = (3,2,1); @g = (sort(@g),'4');
- ok "@g", "1 2 3 4", "un-inplace sort of global 2";
+ is "@g", "1 2 3 4", "un-inplace sort of global 2";
@a = qw(b a c); @a = ('x', sort @a);
- ok "@a", "x a b c", "un-inplace sort of lexical";
+ is "@a", "x a b c", "un-inplace sort of lexical";
@a = qw(b a c); @a = ((sort @a), 'x');
- ok "@a", "a b c x", "un-inplace sort of lexical 2";
+ is "@a", "a b c x", "un-inplace sort of lexical 2";
@g = (2,3,1); @g = ('0', sort { $b <=> $a } @g);
- ok "@g", "0 3 2 1", "un-inplace reversed sort of global";
+ is "@g", "0 3 2 1", "un-inplace reversed sort of global";
@g = (2,3,1); @g = ((sort { $b <=> $a } @g),'4');
- ok "@g", "3 2 1 4", "un-inplace reversed sort of global 2";
+ is "@g", "3 2 1 4", "un-inplace reversed sort of global 2";
@g = (2,3,1); @g = ('0', sort { $a<$b?1:$a>$b?-1:0 } @g);
- ok "@g", "0 3 2 1", "un-inplace custom sort of global";
+ is "@g", "0 3 2 1", "un-inplace custom sort of global";
@g = (2,3,1); @g = ((sort { $a<$b?1:$a>$b?-1:0 } @g),'4');
- ok "@g", "3 2 1 4", "un-inplace custom sort of global 2";
+ is "@g", "3 2 1 4", "un-inplace custom sort of global 2";
@a = qw(b c a); @a = ('x', sort mysort @a);
- ok "@a", "x c b a", "un-inplace sort with function of lexical";
+ is "@a", "x c b a", "un-inplace sort with function of lexical";
@a = qw(b c a); @a = ((sort mysort @a),'x');
- ok "@a", "c b a x", "un-inplace sort with function of lexical 2";
+ is "@a", "c b a x", "un-inplace sort with function of lexical 2";
# RT#54758. Git 62b40d2474e7487e6909e1872b6bccdf812c6818
no warnings 'void';
my @m; push @m, 0 for 1 .. 1024; $#m; @m = sort @m;
- main::pass("in-place sorting segfault");
+ ::pass("in-place sorting segfault");
}
# Test optimisations of reversed sorts. As we now guarantee stability by
@@ -424,77 +412,77 @@ sub generate {
my @input = &generate;
my @output = sort @input;
-ok join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", "Simple stable sort";
+is join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", "Simple stable sort";
@input = &generate;
@input = sort @input;
-ok join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8",
+is join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8",
"Simple stable in place sort";
# This won't be very interesting
@input = &generate;
@output = sort {$a <=> $b} @input;
-ok "@output", "A A A B B B C C C", 'stable $a <=> $b sort';
+is "@output", "A A A B B B C C C", 'stable $a <=> $b sort';
@input = &generate;
@output = sort {$a cmp $b} @input;
-ok join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", 'stable $a cmp $b sort';
+is join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", 'stable $a cmp $b sort';
@input = &generate;
@input = sort {$a cmp $b} @input;
-ok join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8",
+is join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8",
'stable $a cmp $b in place sort';
@input = &generate;
@output = sort {$b cmp $a} @input;
-ok join(" ", map {0+$_} @output), "6 7 8 3 4 5 0 1 2", 'stable $b cmp $a sort';
+is join(" ", map {0+$_} @output), "6 7 8 3 4 5 0 1 2", 'stable $b cmp $a sort';
@input = &generate;
@input = sort {$b cmp $a} @input;
-ok join(" ", map {0+$_} @input), "6 7 8 3 4 5 0 1 2",
+is join(" ", map {0+$_} @input), "6 7 8 3 4 5 0 1 2",
'stable $b cmp $a in place sort';
@input = &generate;
@output = reverse sort @input;
-ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", "Reversed stable sort";
+is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", "Reversed stable sort";
@input = &generate;
@input = reverse sort @input;
-ok join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
"Reversed stable in place sort";
@input = &generate;
my $output = reverse sort @input;
-ok $output, "CCCBBBAAA", "Reversed stable sort in scalar context";
+is $output, "CCCBBBAAA", "Reversed stable sort in scalar context";
@input = &generate;
@output = reverse sort {$a cmp $b} @input;
-ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable $a cmp $b sort';
@input = &generate;
@input = reverse sort {$a cmp $b} @input;
-ok join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
'revesed stable $a cmp $b in place sort';
@input = &generate;
$output = reverse sort {$a cmp $b} @input;
-ok $output, "CCCBBBAAA", 'Reversed stable $a cmp $b sort in scalar context';
+is $output, "CCCBBBAAA", 'Reversed stable $a cmp $b sort in scalar context';
@input = &generate;
@output = reverse sort {$b cmp $a} @input;
-ok join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6",
+is join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6",
'reversed stable $b cmp $a sort';
@input = &generate;
@input = reverse sort {$b cmp $a} @input;
-ok join(" ", map {0+$_} @input), "2 1 0 5 4 3 8 7 6",
+is join(" ", map {0+$_} @input), "2 1 0 5 4 3 8 7 6",
'revesed stable $b cmp $a in place sort';
@input = &generate;
$output = reverse sort {$b cmp $a} @input;
-ok $output, "AAABBBCCC", 'Reversed stable $b cmp $a sort in scalar context';
+is $output, "AAABBBCCC", 'Reversed stable $b cmp $a sort in scalar context';
sub stuff {
# Something complex enough to defeat any constant folding optimiser
@@ -503,27 +491,27 @@ sub stuff {
@input = &generate;
@output = reverse sort {stuff || $a cmp $b} @input;
-ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable complex sort';
@input = &generate;
@input = reverse sort {stuff || $a cmp $b} @input;
-ok join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
'revesed stable complex in place sort';
@input = &generate;
$output = reverse sort {stuff || $a cmp $b } @input;
-ok $output, "CCCBBBAAA", 'Reversed stable complex sort in scalar context';
+is $output, "CCCBBBAAA", 'Reversed stable complex sort in scalar context';
sub sortr {
reverse sort @_;
}
@output = sortr &generate;
-ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable sort return list context';
$output = sortr &generate;
-ok $output, "CCCBBBAAA",
+is $output, "CCCBBBAAA",
'reversed stable sort return scalar context';
sub sortcmpr {
@@ -531,10 +519,10 @@ sub sortcmpr {
}
@output = sortcmpr &generate;
-ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable $a cmp $b sort return list context';
$output = sortcmpr &generate;
-ok $output, "CCCBBBAAA",
+is $output, "CCCBBBAAA",
'reversed stable $a cmp $b sort return scalar context';
sub sortcmprba {
@@ -542,10 +530,10 @@ sub sortcmprba {
}
@output = sortcmprba &generate;
-ok join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6",
+is join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6",
'reversed stable $b cmp $a sort return list context';
$output = sortcmprba &generate;
-ok $output, "AAABBBCCC",
+is $output, "AAABBBCCC",
'reversed stable $b cmp $a sort return scalar context';
sub sortcmprq {
@@ -553,10 +541,10 @@ sub sortcmprq {
}
@output = sortcmpr &generate;
-ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable complex sort return list context';
$output = sortcmpr &generate;
-ok $output, "CCCBBBAAA",
+is $output, "CCCBBBAAA",
'reversed stable complex sort return scalar context';
# And now with numbers
@@ -569,148 +557,148 @@ sub generate1 {
# This won't be very interesting
@input = &generate1;
@output = sort {$a cmp $b} @input;
-ok "@output", "A B C D E F G H I", 'stable $a cmp $b sort';
+is "@output", "A B C D E F G H I", 'stable $a cmp $b sort';
@input = &generate1;
@output = sort {$a <=> $b} @input;
-ok "@output", "A B C D E F G H I", 'stable $a <=> $b sort';
+is "@output", "A B C D E F G H I", 'stable $a <=> $b sort';
@input = &generate1;
@input = sort {$a <=> $b} @input;
-ok "@input", "A B C D E F G H I", 'stable $a <=> $b in place sort';
+is "@input", "A B C D E F G H I", 'stable $a <=> $b in place sort';
@input = &generate1;
@output = sort {$b <=> $a} @input;
-ok "@output", "G H I D E F A B C", 'stable $b <=> $a sort';
+is "@output", "G H I D E F A B C", 'stable $b <=> $a sort';
@input = &generate1;
@input = sort {$b <=> $a} @input;
-ok "@input", "G H I D E F A B C", 'stable $b <=> $a in place sort';
+is "@input", "G H I D E F A B C", 'stable $b <=> $a in place sort';
# test that optimized {$b cmp $a} and {$b <=> $a} remain stable
# (new in 5.9) without overloading
{ no warnings;
@b = sort { $b <=> $a } @input = qw/5first 6first 5second 6second/;
-ok "@b" , "6first 6second 5first 5second", "optimized {$b <=> $a} without overloading" ;
+is "@b" , "6first 6second 5first 5second", "optimized {$b <=> $a} without overloading" ;
@input = sort {$b <=> $a} @input;
-ok "@input" , "6first 6second 5first 5second","inline optimized {$b <=> $a} without overloading" ;
+is "@input" , "6first 6second 5first 5second","inline optimized {$b <=> $a} without overloading" ;
};
# These two are actually doing string cmp on 0 1 and 2
@input = &generate1;
@output = reverse sort @input;
-ok "@output", "I H G F E D C B A", "Reversed stable sort";
+is "@output", "I H G F E D C B A", "Reversed stable sort";
@input = &generate1;
@input = reverse sort @input;
-ok "@input", "I H G F E D C B A", "Reversed stable in place sort";
+is "@input", "I H G F E D C B A", "Reversed stable in place sort";
@input = &generate1;
$output = reverse sort @input;
-ok $output, "IHGFEDCBA", "Reversed stable sort in scalar context";
+is $output, "IHGFEDCBA", "Reversed stable sort in scalar context";
@input = &generate1;
@output = reverse sort {$a <=> $b} @input;
-ok "@output", "I H G F E D C B A", 'reversed stable $a <=> $b sort';
+is "@output", "I H G F E D C B A", 'reversed stable $a <=> $b sort';
@input = &generate1;
@input = reverse sort {$a <=> $b} @input;
-ok "@input", "I H G F E D C B A", 'revesed stable $a <=> $b in place sort';
+is "@input", "I H G F E D C B A", 'revesed stable $a <=> $b in place sort';
@input = &generate1;
$output = reverse sort {$a <=> $b} @input;
-ok $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort in scalar context';
+is $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort in scalar context';
@input = &generate1;
@output = reverse sort {$b <=> $a} @input;
-ok "@output", "C B A F E D I H G", 'reversed stable $b <=> $a sort';
+is "@output", "C B A F E D I H G", 'reversed stable $b <=> $a sort';
@input = &generate1;
@input = reverse sort {$b <=> $a} @input;
-ok "@input", "C B A F E D I H G", 'revesed stable $b <=> $a in place sort';
+is "@input", "C B A F E D I H G", 'revesed stable $b <=> $a in place sort';
@input = &generate1;
$output = reverse sort {$b <=> $a} @input;
-ok $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort in scalar context';
+is $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort in scalar context';
@input = &generate1;
@output = reverse sort {stuff || $a <=> $b} @input;
-ok "@output", "I H G F E D C B A", 'reversed stable complex sort';
+is "@output", "I H G F E D C B A", 'reversed stable complex sort';
@input = &generate1;
@input = reverse sort {stuff || $a <=> $b} @input;
-ok "@input", "I H G F E D C B A", 'revesed stable complex in place sort';
+is "@input", "I H G F E D C B A", 'revesed stable complex in place sort';
@input = &generate1;
$output = reverse sort {stuff || $a <=> $b} @input;
-ok $output, "IHGFEDCBA", 'reversed stable complex sort in scalar context';
+is $output, "IHGFEDCBA", 'reversed stable complex sort in scalar context';
sub sortnumr {
reverse sort {$a <=> $b} @_;
}
@output = sortnumr &generate1;
-ok "@output", "I H G F E D C B A",
+is "@output", "I H G F E D C B A",
'reversed stable $a <=> $b sort return list context';
$output = sortnumr &generate1;
-ok $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort return scalar context';
+is $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort return scalar context';
sub sortnumrba {
reverse sort {$b <=> $a} @_;
}
@output = sortnumrba &generate1;
-ok "@output", "C B A F E D I H G",
+is "@output", "C B A F E D I H G",
'reversed stable $b <=> $a sort return list context';
$output = sortnumrba &generate1;
-ok $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort return scalar context';
+is $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort return scalar context';
sub sortnumrq {
reverse sort {stuff || $a <=> $b} @_;
}
@output = sortnumrq &generate1;
-ok "@output", "I H G F E D C B A",
+is "@output", "I H G F E D C B A",
'reversed stable complex sort return list context';
$output = sortnumrq &generate1;
-ok $output, "IHGFEDCBA", 'reversed stable complex sort return scalar context';
+is $output, "IHGFEDCBA", 'reversed stable complex sort return scalar context';
@output = reverse (sort(qw(C A B)), 0);
-ok "@output", "0 C B A", 'reversed sort with trailing argument';
+is "@output", "0 C B A", 'reversed sort with trailing argument';
@output = reverse (0, sort(qw(C A B)));
-ok "@output", "C B A 0", 'reversed sort with leading argument';
+is "@output", "C B A 0", 'reversed sort with leading argument';
eval { @output = sort {goto sub {}} 1,2; };
$fail_msg = q(Can't goto subroutine outside a subroutine);
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr outside subr');
+cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr outside subr');
sub goto_sub {goto sub{}}
eval { @output = sort goto_sub 1,2; };
$fail_msg = q(Can't goto subroutine from a sort sub);
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr from a sort sub');
+cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr from a sort sub');
eval { @output = sort {goto label} 1,2; };
$fail_msg = q(Can't "goto" out of a pseudo block);
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 1');
+cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 1');
sub goto_label {goto label}
label: eval { @output = sort goto_label 1,2; };
$fail_msg = q(Can't "goto" out of a pseudo block);
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 2');
+cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 2');
sub self_immolate {undef &self_immolate; $a<=>$b}
eval { @output = sort self_immolate 1,2,3 };
$fail_msg = q(Can't undef active subroutine);
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'undef active subr');
+cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'undef active subr');
@@ -729,13 +717,12 @@ main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'undef active subr');
}
rec(1);
- main::ok(!$failed, "sort from active sub");
+ ok(!$failed, "sort from active sub");
}
# $a and $b are set in the package the sort() is called from,
# *not* the package the sort sub is in. This is longstanding
# de facto behaviour that shouldn't be broken.
-package main;
my $answer = "good";
() = sort OtherPack::foo 1,2,3,4;
@@ -749,50 +736,56 @@ my $answer = "good";
}
}
-main::cmp_ok($answer,'eq','good','sort subr called from other package');
+cmp_ok($answer,'eq','good','sort subr called from other package');
# Bug 36430 - sort called in package2 while a
# sort in package1 is active should set $package2::a/b.
-
-$answer = "good";
-my @list = sort { A::min(@$a) <=> A::min(@$b) }
- [3, 1, 5], [2, 4], [0];
-
-main::cmp_ok($answer,'eq','good','bug 36430');
-
-package A;
-sub min {
- my @list = sort {
- $answer = '$a and/or $b are not defined ' if !defined($a) || !defined($b);
- $a <=> $b;
- } @_;
- $list[0];
+{
+ my $answer = "good";
+ my @list = sort { A::min(@$a) <=> A::min(@$b) }
+ [3, 1, 5], [2, 4], [0];
+
+ cmp_ok($answer,'eq','good','bug 36430');
+
+ package A;
+ sub min {
+ my @list = sort {
+ $answer = '$a and/or $b are not defined ' if !defined($a) || !defined($b);
+ $a <=> $b;
+ } @_;
+ $list[0];
+ }
}
+
# Bug 7567 - an array shouldn't be modifiable while it's being
# sorted in-place.
-eval { @a=(1..8); @a = sort { @a = (0) } @a; };
-
-$fail_msg = q(Modification of a read-only value attempted);
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'bug 7567');
+{
+ eval { @a=(1..8); @a = sort { @a = (0) } @a; };
+ $fail_msg = q(Modification of a read-only value attempted);
+ cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'bug 7567');
+}
# Sorting shouldn't increase the refcount of a sub
-sub foo {(1+$a) <=> (1+$b)}
-my $refcnt = &Internals::SvREFCNT(\&foo);
-@output = sort foo 3,7,9;
-package Foo;
-ok($refcnt, &Internals::SvREFCNT(\&foo), "sort sub refcnt");
-$fail_msg = q(Modification of a read-only value attempted);
-# Sorting a read-only array in-place shouldn't be allowed
-my @readonly = (1..10);
-Internals::SvREADONLY(@readonly, 1);
-eval { @readonly = sort @readonly; };
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'in-place sort of read-only array');
-
-
+{
+ sub foo {(1+$a) <=> (1+$b)}
+ my $refcnt = &Internals::SvREFCNT(\&foo);
+ @output = sort foo 3,7,9;
+
+ {
+ package Foo;
+ ::is($refcnt, &Internals::SvREFCNT(\&foo), "sort sub refcnt");
+ $fail_msg = q(Modification of a read-only value attempted);
+ # Sorting a read-only array in-place shouldn't be allowed
+ my @readonly = (1..10);
+ Internals::SvREADONLY(@readonly, 1);
+ eval { @readonly = sort @readonly; };
+ ::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'in-place sort of read-only array');
+ }
+}
# Using return() should be okay even in a deeper context
--
1.6.2.4
|
From @iabynOn Sat, Jul 11, 2009 at 12:43:11AM -0700, Michael G Schwern via RT wrote:
Thanks for this. However, I've now fixed the bug (spurred on by the The bug affected any utf-8 tr// used within an anonymous sub that gets
I tried applying that, but it appears to give spurious output when run # return with SVs on stack so I've left it for someone else to (hopefully) sort out. -- |
From @schwernDave Mitchell wrote:
Woo!
I'll have a look. -- |
From @schwernMichael G Schwern wrote:
Ok, fixed. The old code had a home rolled Test.pm style ok() that I got rid Fixed in the branch (force a pull) and also attached. -- |
From @schwern0001-Clean-up-t-op-sort.t-to-constrain-tests-which-use-a.patchFrom cddbb0bf24f54a63f1db426b2f0636051a1c43ae Mon Sep 17 00:00:00 2001
From: Michael G. Schwern <schwern@pobox.com>
Date: Sat, 11 Jul 2009 00:34:31 -0700
Subject: [PATCH] Clean up t/op/sort.t to constrain tests which use a particular package.
Also make use of is() instead of a home rolled conflicting Test.pm style ok().
---
t/op/sort.t | 319 +++++++++++++++++++++++++++++------------------------------
1 files changed, 156 insertions(+), 163 deletions(-)
diff --git a/t/op/sort.t b/t/op/sort.t
index 4473c32..616761a 100644
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -2,7 +2,8 @@
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib); require 'test.pl';
+ @INC = qw(. ../lib);
+ require 'test.pl';
}
use warnings;
plan( tests => 144 );
@@ -260,48 +261,43 @@ $x = join('', sort { $a <=> $b } 3, 1, 2);
cmp_ok($x,'eq','123',q(optimized-away comparison block doesn't take any other arguments away with it));
# test sorting in non-main package
-package Foo;
-@a = ( 5, 19, 1996, 255, 90 );
-@b = sort { $b <=> $a } @a;
-main::cmp_ok("@b",'eq','1996 255 90 19 5','not in main:: 1');
-
-
-@b = sort main::Backwards_stacked @a;
-main::cmp_ok("@b",'eq','90 5 255 1996 19','not in main:: 2');
-
-
-# check if context for sort arguments is handled right
-
-
-sub test_if_list {
- my $gimme = wantarray;
- main::is($gimme,1,'wantarray 1');
-
-
-}
-my $m = sub { $a <=> $b };
-
-sub cxt_one { sort $m test_if_list() }
-cxt_one();
-sub cxt_two { sort { $a <=> $b } test_if_list() }
-cxt_two();
-sub cxt_three { sort &test_if_list() }
-cxt_three();
+{
+ package Foo;
+ @a = ( 5, 19, 1996, 255, 90 );
+ @b = sort { $b <=> $a } @a;
+ ::cmp_ok("@b",'eq','1996 255 90 19 5','not in main:: 1');
-sub test_if_scalar {
- my $gimme = wantarray;
- main::is(!($gimme or !defined($gimme)),1,'wantarray 2');
+ @b = sort ::Backwards_stacked @a;
+ ::cmp_ok("@b",'eq','90 5 255 1996 19','not in main:: 2');
+ # check if context for sort arguments is handled right
+ sub test_if_list {
+ my $gimme = wantarray;
+ ::is($gimme,1,'wantarray 1');
+ }
+ my $m = sub { $a <=> $b };
+
+ sub cxt_one { sort $m test_if_list() }
+ cxt_one();
+ sub cxt_two { sort { $a <=> $b } test_if_list() }
+ cxt_two();
+ sub cxt_three { sort &test_if_list() }
+ cxt_three();
+
+ sub test_if_scalar {
+ my $gimme = wantarray;
+ ::is(!($gimme or !defined($gimme)),1,'wantarray 2');
+ }
+ $m = \&test_if_scalar;
+ sub cxt_four { sort $m 1,2 }
+ @x = cxt_four();
+ sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 }
+ @x = cxt_five();
+ sub cxt_six { sort test_if_scalar 1,2 }
+ @x = cxt_six();
}
-$m = \&test_if_scalar;
-sub cxt_four { sort $m 1,2 }
-@x = cxt_four();
-sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 }
-@x = cxt_five();
-sub cxt_six { sort test_if_scalar 1,2 }
-@x = cxt_six();
# test against a reentrancy bug
{
@@ -316,89 +312,81 @@ sub cxt_six { sort test_if_scalar 1,2 }
Bar::reenter() unless $init++;
$a <=> $b
} qw/4 3 1 2/;
- main::cmp_ok("@b",'eq','1 2 3 4','reenter 1');
+ cmp_ok("@b",'eq','1 2 3 4','reenter 1');
- main::ok(!$def,'reenter 2');
+ ok(!$def,'reenter 2');
}
{
sub routine { "one", "two" };
@a = sort(routine(1));
- main::cmp_ok("@a",'eq',"one two",'bug id 19991001.003');
+ cmp_ok("@a",'eq',"one two",'bug id 19991001.003');
}
-#my $test = 59;
-sub ok { main::cmp_ok($_[0],'eq',$_[1],$_[2]);
-# print "not " unless $_[0] eq $_[1];
-# print "ok $test - $_[2]\n";
-# print "#[$_[0]] ne [$_[1]]\n" unless $_[0] eq $_[1];
-# $test++;
-}
-
# check for in-place optimisation of @a = sort @a
{
my ($r1,$r2,@a);
our @g;
@g = (3,2,1); $r1 = \$g[2]; @g = sort @g; $r2 = \$g[0];
- ok "$r1-@g", "$r2-1 2 3", "inplace sort of global";
+ is "$r1-@g", "$r2-1 2 3", "inplace sort of global";
@a = qw(b a c); $r1 = \$a[1]; @a = sort @a; $r2 = \$a[0];
- ok "$r1-@a", "$r2-a b c", "inplace sort of lexical";
+ is "$r1-@a", "$r2-a b c", "inplace sort of lexical";
@g = (2,3,1); $r1 = \$g[1]; @g = sort { $b <=> $a } @g; $r2 = \$g[0];
- ok "$r1-@g", "$r2-3 2 1", "inplace reversed sort of global";
+ is "$r1-@g", "$r2-3 2 1", "inplace reversed sort of global";
@g = (2,3,1);
$r1 = \$g[1]; @g = sort { $a<$b?1:$a>$b?-1:0 } @g; $r2 = \$g[0];
- ok "$r1-@g", "$r2-3 2 1", "inplace custom sort of global";
+ is "$r1-@g", "$r2-3 2 1", "inplace custom sort of global";
sub mysort { $b cmp $a };
@a = qw(b c a); $r1 = \$a[1]; @a = sort mysort @a; $r2 = \$a[0];
- ok "$r1-@a", "$r2-c b a", "inplace sort with function of lexical";
+ is "$r1-@a", "$r2-c b a", "inplace sort with function of lexical";
use Tie::Array;
my @t;
tie @t, 'Tie::StdArray';
@t = qw(b c a); @t = sort @t;
- ok "@t", "a b c", "inplace sort of tied array";
+ is "@t", "a b c", "inplace sort of tied array";
@t = qw(b c a); @t = sort mysort @t;
- ok "@t", "c b a", "inplace sort of tied array with function";
+ is "@t", "c b a", "inplace sort of tied array with function";
# [perl #29790] don't optimise @a = ('a', sort @a) !
@g = (3,2,1); @g = ('0', sort @g);
- ok "@g", "0 1 2 3", "un-inplace sort of global";
+ is "@g", "0 1 2 3", "un-inplace sort of global";
@g = (3,2,1); @g = (sort(@g),'4');
- ok "@g", "1 2 3 4", "un-inplace sort of global 2";
+ is "@g", "1 2 3 4", "un-inplace sort of global 2";
@a = qw(b a c); @a = ('x', sort @a);
- ok "@a", "x a b c", "un-inplace sort of lexical";
+ is "@a", "x a b c", "un-inplace sort of lexical";
@a = qw(b a c); @a = ((sort @a), 'x');
- ok "@a", "a b c x", "un-inplace sort of lexical 2";
+ is "@a", "a b c x", "un-inplace sort of lexical 2";
@g = (2,3,1); @g = ('0', sort { $b <=> $a } @g);
- ok "@g", "0 3 2 1", "un-inplace reversed sort of global";
+ is "@g", "0 3 2 1", "un-inplace reversed sort of global";
@g = (2,3,1); @g = ((sort { $b <=> $a } @g),'4');
- ok "@g", "3 2 1 4", "un-inplace reversed sort of global 2";
+ is "@g", "3 2 1 4", "un-inplace reversed sort of global 2";
@g = (2,3,1); @g = ('0', sort { $a<$b?1:$a>$b?-1:0 } @g);
- ok "@g", "0 3 2 1", "un-inplace custom sort of global";
+ is "@g", "0 3 2 1", "un-inplace custom sort of global";
@g = (2,3,1); @g = ((sort { $a<$b?1:$a>$b?-1:0 } @g),'4');
- ok "@g", "3 2 1 4", "un-inplace custom sort of global 2";
+ is "@g", "3 2 1 4", "un-inplace custom sort of global 2";
@a = qw(b c a); @a = ('x', sort mysort @a);
- ok "@a", "x c b a", "un-inplace sort with function of lexical";
+ is "@a", "x c b a", "un-inplace sort with function of lexical";
@a = qw(b c a); @a = ((sort mysort @a),'x');
- ok "@a", "c b a x", "un-inplace sort with function of lexical 2";
+ is "@a", "c b a x", "un-inplace sort with function of lexical 2";
# RT#54758. Git 62b40d2474e7487e6909e1872b6bccdf812c6818
no warnings 'void';
my @m; push @m, 0 for 1 .. 1024; $#m; @m = sort @m;
- main::pass("in-place sorting segfault");
+ ::pass("in-place sorting segfault");
}
# Test optimisations of reversed sorts. As we now guarantee stability by
@@ -424,77 +412,77 @@ sub generate {
my @input = &generate;
my @output = sort @input;
-ok join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", "Simple stable sort";
+is join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", "Simple stable sort";
@input = &generate;
@input = sort @input;
-ok join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8",
+is join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8",
"Simple stable in place sort";
# This won't be very interesting
@input = &generate;
@output = sort {$a <=> $b} @input;
-ok "@output", "A A A B B B C C C", 'stable $a <=> $b sort';
+is "@output", "A A A B B B C C C", 'stable $a <=> $b sort';
@input = &generate;
@output = sort {$a cmp $b} @input;
-ok join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", 'stable $a cmp $b sort';
+is join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", 'stable $a cmp $b sort';
@input = &generate;
@input = sort {$a cmp $b} @input;
-ok join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8",
+is join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8",
'stable $a cmp $b in place sort';
@input = &generate;
@output = sort {$b cmp $a} @input;
-ok join(" ", map {0+$_} @output), "6 7 8 3 4 5 0 1 2", 'stable $b cmp $a sort';
+is join(" ", map {0+$_} @output), "6 7 8 3 4 5 0 1 2", 'stable $b cmp $a sort';
@input = &generate;
@input = sort {$b cmp $a} @input;
-ok join(" ", map {0+$_} @input), "6 7 8 3 4 5 0 1 2",
+is join(" ", map {0+$_} @input), "6 7 8 3 4 5 0 1 2",
'stable $b cmp $a in place sort';
@input = &generate;
@output = reverse sort @input;
-ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", "Reversed stable sort";
+is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", "Reversed stable sort";
@input = &generate;
@input = reverse sort @input;
-ok join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
"Reversed stable in place sort";
@input = &generate;
my $output = reverse sort @input;
-ok $output, "CCCBBBAAA", "Reversed stable sort in scalar context";
+is $output, "CCCBBBAAA", "Reversed stable sort in scalar context";
@input = &generate;
@output = reverse sort {$a cmp $b} @input;
-ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable $a cmp $b sort';
@input = &generate;
@input = reverse sort {$a cmp $b} @input;
-ok join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
'revesed stable $a cmp $b in place sort';
@input = &generate;
$output = reverse sort {$a cmp $b} @input;
-ok $output, "CCCBBBAAA", 'Reversed stable $a cmp $b sort in scalar context';
+is $output, "CCCBBBAAA", 'Reversed stable $a cmp $b sort in scalar context';
@input = &generate;
@output = reverse sort {$b cmp $a} @input;
-ok join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6",
+is join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6",
'reversed stable $b cmp $a sort';
@input = &generate;
@input = reverse sort {$b cmp $a} @input;
-ok join(" ", map {0+$_} @input), "2 1 0 5 4 3 8 7 6",
+is join(" ", map {0+$_} @input), "2 1 0 5 4 3 8 7 6",
'revesed stable $b cmp $a in place sort';
@input = &generate;
$output = reverse sort {$b cmp $a} @input;
-ok $output, "AAABBBCCC", 'Reversed stable $b cmp $a sort in scalar context';
+is $output, "AAABBBCCC", 'Reversed stable $b cmp $a sort in scalar context';
sub stuff {
# Something complex enough to defeat any constant folding optimiser
@@ -503,27 +491,27 @@ sub stuff {
@input = &generate;
@output = reverse sort {stuff || $a cmp $b} @input;
-ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable complex sort';
@input = &generate;
@input = reverse sort {stuff || $a cmp $b} @input;
-ok join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
'revesed stable complex in place sort';
@input = &generate;
$output = reverse sort {stuff || $a cmp $b } @input;
-ok $output, "CCCBBBAAA", 'Reversed stable complex sort in scalar context';
+is $output, "CCCBBBAAA", 'Reversed stable complex sort in scalar context';
sub sortr {
reverse sort @_;
}
@output = sortr &generate;
-ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable sort return list context';
$output = sortr &generate;
-ok $output, "CCCBBBAAA",
+is $output, "CCCBBBAAA",
'reversed stable sort return scalar context';
sub sortcmpr {
@@ -531,10 +519,10 @@ sub sortcmpr {
}
@output = sortcmpr &generate;
-ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable $a cmp $b sort return list context';
$output = sortcmpr &generate;
-ok $output, "CCCBBBAAA",
+is $output, "CCCBBBAAA",
'reversed stable $a cmp $b sort return scalar context';
sub sortcmprba {
@@ -542,10 +530,10 @@ sub sortcmprba {
}
@output = sortcmprba &generate;
-ok join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6",
+is join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6",
'reversed stable $b cmp $a sort return list context';
$output = sortcmprba &generate;
-ok $output, "AAABBBCCC",
+is $output, "AAABBBCCC",
'reversed stable $b cmp $a sort return scalar context';
sub sortcmprq {
@@ -553,10 +541,10 @@ sub sortcmprq {
}
@output = sortcmpr &generate;
-ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
+is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable complex sort return list context';
$output = sortcmpr &generate;
-ok $output, "CCCBBBAAA",
+is $output, "CCCBBBAAA",
'reversed stable complex sort return scalar context';
# And now with numbers
@@ -569,148 +557,148 @@ sub generate1 {
# This won't be very interesting
@input = &generate1;
@output = sort {$a cmp $b} @input;
-ok "@output", "A B C D E F G H I", 'stable $a cmp $b sort';
+is "@output", "A B C D E F G H I", 'stable $a cmp $b sort';
@input = &generate1;
@output = sort {$a <=> $b} @input;
-ok "@output", "A B C D E F G H I", 'stable $a <=> $b sort';
+is "@output", "A B C D E F G H I", 'stable $a <=> $b sort';
@input = &generate1;
@input = sort {$a <=> $b} @input;
-ok "@input", "A B C D E F G H I", 'stable $a <=> $b in place sort';
+is "@input", "A B C D E F G H I", 'stable $a <=> $b in place sort';
@input = &generate1;
@output = sort {$b <=> $a} @input;
-ok "@output", "G H I D E F A B C", 'stable $b <=> $a sort';
+is "@output", "G H I D E F A B C", 'stable $b <=> $a sort';
@input = &generate1;
@input = sort {$b <=> $a} @input;
-ok "@input", "G H I D E F A B C", 'stable $b <=> $a in place sort';
+is "@input", "G H I D E F A B C", 'stable $b <=> $a in place sort';
# test that optimized {$b cmp $a} and {$b <=> $a} remain stable
# (new in 5.9) without overloading
{ no warnings;
@b = sort { $b <=> $a } @input = qw/5first 6first 5second 6second/;
-ok "@b" , "6first 6second 5first 5second", "optimized {$b <=> $a} without overloading" ;
+is "@b" , "6first 6second 5first 5second", "optimized {$b <=> $a} without overloading" ;
@input = sort {$b <=> $a} @input;
-ok "@input" , "6first 6second 5first 5second","inline optimized {$b <=> $a} without overloading" ;
+is "@input" , "6first 6second 5first 5second","inline optimized {$b <=> $a} without overloading" ;
};
# These two are actually doing string cmp on 0 1 and 2
@input = &generate1;
@output = reverse sort @input;
-ok "@output", "I H G F E D C B A", "Reversed stable sort";
+is "@output", "I H G F E D C B A", "Reversed stable sort";
@input = &generate1;
@input = reverse sort @input;
-ok "@input", "I H G F E D C B A", "Reversed stable in place sort";
+is "@input", "I H G F E D C B A", "Reversed stable in place sort";
@input = &generate1;
$output = reverse sort @input;
-ok $output, "IHGFEDCBA", "Reversed stable sort in scalar context";
+is $output, "IHGFEDCBA", "Reversed stable sort in scalar context";
@input = &generate1;
@output = reverse sort {$a <=> $b} @input;
-ok "@output", "I H G F E D C B A", 'reversed stable $a <=> $b sort';
+is "@output", "I H G F E D C B A", 'reversed stable $a <=> $b sort';
@input = &generate1;
@input = reverse sort {$a <=> $b} @input;
-ok "@input", "I H G F E D C B A", 'revesed stable $a <=> $b in place sort';
+is "@input", "I H G F E D C B A", 'revesed stable $a <=> $b in place sort';
@input = &generate1;
$output = reverse sort {$a <=> $b} @input;
-ok $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort in scalar context';
+is $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort in scalar context';
@input = &generate1;
@output = reverse sort {$b <=> $a} @input;
-ok "@output", "C B A F E D I H G", 'reversed stable $b <=> $a sort';
+is "@output", "C B A F E D I H G", 'reversed stable $b <=> $a sort';
@input = &generate1;
@input = reverse sort {$b <=> $a} @input;
-ok "@input", "C B A F E D I H G", 'revesed stable $b <=> $a in place sort';
+is "@input", "C B A F E D I H G", 'revesed stable $b <=> $a in place sort';
@input = &generate1;
$output = reverse sort {$b <=> $a} @input;
-ok $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort in scalar context';
+is $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort in scalar context';
@input = &generate1;
@output = reverse sort {stuff || $a <=> $b} @input;
-ok "@output", "I H G F E D C B A", 'reversed stable complex sort';
+is "@output", "I H G F E D C B A", 'reversed stable complex sort';
@input = &generate1;
@input = reverse sort {stuff || $a <=> $b} @input;
-ok "@input", "I H G F E D C B A", 'revesed stable complex in place sort';
+is "@input", "I H G F E D C B A", 'revesed stable complex in place sort';
@input = &generate1;
$output = reverse sort {stuff || $a <=> $b} @input;
-ok $output, "IHGFEDCBA", 'reversed stable complex sort in scalar context';
+is $output, "IHGFEDCBA", 'reversed stable complex sort in scalar context';
sub sortnumr {
reverse sort {$a <=> $b} @_;
}
@output = sortnumr &generate1;
-ok "@output", "I H G F E D C B A",
+is "@output", "I H G F E D C B A",
'reversed stable $a <=> $b sort return list context';
$output = sortnumr &generate1;
-ok $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort return scalar context';
+is $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort return scalar context';
sub sortnumrba {
reverse sort {$b <=> $a} @_;
}
@output = sortnumrba &generate1;
-ok "@output", "C B A F E D I H G",
+is "@output", "C B A F E D I H G",
'reversed stable $b <=> $a sort return list context';
$output = sortnumrba &generate1;
-ok $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort return scalar context';
+is $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort return scalar context';
sub sortnumrq {
reverse sort {stuff || $a <=> $b} @_;
}
@output = sortnumrq &generate1;
-ok "@output", "I H G F E D C B A",
+is "@output", "I H G F E D C B A",
'reversed stable complex sort return list context';
$output = sortnumrq &generate1;
-ok $output, "IHGFEDCBA", 'reversed stable complex sort return scalar context';
+is $output, "IHGFEDCBA", 'reversed stable complex sort return scalar context';
@output = reverse (sort(qw(C A B)), 0);
-ok "@output", "0 C B A", 'reversed sort with trailing argument';
+is "@output", "0 C B A", 'reversed sort with trailing argument';
@output = reverse (0, sort(qw(C A B)));
-ok "@output", "C B A 0", 'reversed sort with leading argument';
+is "@output", "C B A 0", 'reversed sort with leading argument';
eval { @output = sort {goto sub {}} 1,2; };
$fail_msg = q(Can't goto subroutine outside a subroutine);
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr outside subr');
+cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr outside subr');
sub goto_sub {goto sub{}}
eval { @output = sort goto_sub 1,2; };
$fail_msg = q(Can't goto subroutine from a sort sub);
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr from a sort sub');
+cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr from a sort sub');
eval { @output = sort {goto label} 1,2; };
$fail_msg = q(Can't "goto" out of a pseudo block);
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 1');
+cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 1');
sub goto_label {goto label}
label: eval { @output = sort goto_label 1,2; };
$fail_msg = q(Can't "goto" out of a pseudo block);
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 2');
+cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 2');
sub self_immolate {undef &self_immolate; $a<=>$b}
eval { @output = sort self_immolate 1,2,3 };
$fail_msg = q(Can't undef active subroutine);
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'undef active subr');
+cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'undef active subr');
@@ -729,13 +717,12 @@ main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'undef active subr');
}
rec(1);
- main::ok(!$failed, "sort from active sub");
+ ok(!$failed, "sort from active sub");
}
# $a and $b are set in the package the sort() is called from,
# *not* the package the sort sub is in. This is longstanding
# de facto behaviour that shouldn't be broken.
-package main;
my $answer = "good";
() = sort OtherPack::foo 1,2,3,4;
@@ -749,62 +736,68 @@ my $answer = "good";
}
}
-main::cmp_ok($answer,'eq','good','sort subr called from other package');
+cmp_ok($answer,'eq','good','sort subr called from other package');
# Bug 36430 - sort called in package2 while a
# sort in package1 is active should set $package2::a/b.
-
-$answer = "good";
-my @list = sort { A::min(@$a) <=> A::min(@$b) }
- [3, 1, 5], [2, 4], [0];
-
-main::cmp_ok($answer,'eq','good','bug 36430');
-
-package A;
-sub min {
- my @list = sort {
- $answer = '$a and/or $b are not defined ' if !defined($a) || !defined($b);
- $a <=> $b;
- } @_;
- $list[0];
+{
+ my $answer = "good";
+ my @list = sort { A::min(@$a) <=> A::min(@$b) }
+ [3, 1, 5], [2, 4], [0];
+
+ cmp_ok($answer,'eq','good','bug 36430');
+
+ package A;
+ sub min {
+ my @list = sort {
+ $answer = '$a and/or $b are not defined ' if !defined($a) || !defined($b);
+ $a <=> $b;
+ } @_;
+ $list[0];
+ }
}
+
# Bug 7567 - an array shouldn't be modifiable while it's being
# sorted in-place.
-eval { @a=(1..8); @a = sort { @a = (0) } @a; };
-
-$fail_msg = q(Modification of a read-only value attempted);
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'bug 7567');
+{
+ eval { @a=(1..8); @a = sort { @a = (0) } @a; };
+ $fail_msg = q(Modification of a read-only value attempted);
+ cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'bug 7567');
+}
# Sorting shouldn't increase the refcount of a sub
-sub foo {(1+$a) <=> (1+$b)}
-my $refcnt = &Internals::SvREFCNT(\&foo);
-@output = sort foo 3,7,9;
-package Foo;
-ok($refcnt, &Internals::SvREFCNT(\&foo), "sort sub refcnt");
-$fail_msg = q(Modification of a read-only value attempted);
-# Sorting a read-only array in-place shouldn't be allowed
-my @readonly = (1..10);
-Internals::SvREADONLY(@readonly, 1);
-eval { @readonly = sort @readonly; };
-main::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'in-place sort of read-only array');
-
-
+{
+ sub foo {(1+$a) <=> (1+$b)}
+ my $refcnt = &Internals::SvREFCNT(\&foo);
+ @output = sort foo 3,7,9;
+
+ {
+ package Foo;
+ ::is($refcnt, &Internals::SvREFCNT(\&foo), "sort sub refcnt");
+ $fail_msg = q(Modification of a read-only value attempted);
+ # Sorting a read-only array in-place shouldn't be allowed
+ my @readonly = (1..10);
+ Internals::SvREADONLY(@readonly, 1);
+ eval { @readonly = sort @readonly; };
+ ::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'in-place sort of read-only array');
+ }
+}
# Using return() should be okay even in a deeper context
@b = sort {while (1) {return ($a <=> $b)} } 1..10;
-ok("@b", "1 2 3 4 5 6 7 8 9 10", "return within loop");
+is("@b", "1 2 3 4 5 6 7 8 9 10", "return within loop");
# Using return() should be okay even if there are other items
# on the stack at the time.
@b = sort {$_ = ($a<=>$b) + do{return $b<=> $a}} 1..10;
-ok("@b", "10 9 8 7 6 5 4 3 2 1", "return with SVs on stack");
+is("@b", "10 9 8 7 6 5 4 3 2 1", "return with SVs on stack");
# As above, but with a sort sub rather than a sort block.
sub ret_with_stacked { $_ = ($a<=>$b) + do {return $b <=> $a} }
@b = sort ret_with_stacked 1..10;
-ok("@b", "10 9 8 7 6 5 4 3 2 1", "return with SVs on stack");
+is("@b", "10 9 8 7 6 5 4 3 2 1", "return with SVs on stack");
--
1.6.2.4
|
From @chipdudeOn Sat, Jul 11, 2009 at 06:06:51PM +0100, Dave Mitchell wrote:
Having read the patch description, I get it now... The pad started as lexical variables only but has morphed into something PS: I'm not sure which was scarier, the bug description or that I understood it |
From @schwernShall we call this resolved then? |
From @rgs2009/7/12 Michael G Schwern <schwern@pobox.com>:
Thanks, applied. |
From @clintongormley
Thanks, guys, for putting up with a bad bug report, and for fixing it. I did spend several hours trying to come up with something reproducible, thanks Clint
|
@iabyn - Status changed from 'open' to 'resolved' |
From @iabynOn Sat, Jul 11, 2009 at 06:11:35PM -0700, Chip Salzenberg wrote:
Yes, any SVs that used to be attached to ops were moved into the pad to -- |
Migrated from rt.perl.org#61520 (status was 'resolved')
Searchable as RT61520$
The text was updated successfully, but these errors were encountered: