Change 30026 by [EMAIL PROTECTED] on 2007/01/27 11:02:43
Integrate:
[ 28093]
Subject: [PATCH] t/op/list.t using test.pl
From: David Landgren <[EMAIL PROTECTED]>
Date: Wed, 03 May 2006 19:40:40 +0200
Message-ID: <[EMAIL PROTECTED]>
[ 28649]
Subject: [PATCH blead] Re: [perl #39733] $AUTOLOAD is never tainted
From: Rick Delaney <[EMAIL PROTECTED]>
Date: Sun, 9 Jul 2006 15:01:50 -0400
Message-ID: <[EMAIL PROTECTED]>
Plus a note in perldelta
[ 28657]
Subject: [PATCH blead] Re: [perl #39882] inconsistent list slice
behaviour
From: Rick Delaney <[EMAIL PROTECTED]>
Date: Thu, 3 Aug 2006 21:48:07 -0400
Message-ID: <[EMAIL PROTECTED]>
[ 28684]
Subject: Re: [perl #37731] junk and uninit'ed values in tied scalars
From: Yitzchak Scott-Thoennes <[EMAIL PROTECTED]>
Date: Mon, 28 Nov 2005 01:26:31 -0800
Message-ID: <[EMAIL PROTECTED]>
plus a regression test
[ 28690]
lstat on *GLOB{IO} with warnings on would segfault
(noticed by Andrew Dougherty)
[ 28827]
Disable study() for utf-8 strings
Subject: Re: Re: [Fwd: Smoke [5.9.4] 28821 FAIL(XF) OSF1 V5.1 (EV6/4
cpu)]
From: demerphq <[EMAIL PROTECTED]>
Date: Tue, 12 Sep 2006 17:08:55 +0200
Message-ID: <[EMAIL PROTECTED]>
[ 28875]
Deliver SIGILL, SIGBUS and SIGSEGV always in an "unsafe" manner.
Subject: Safe signals and SIGSEGV
From: Rafael Garcia-Suarez <[EMAIL PROTECTED]>
Date: Fri, 8 Sep 2006 17:43:41 +0200
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/maint-5.8/perl/gv.c#95 integrate
... //depot/maint-5.8/perl/mg.c#140 integrate
... //depot/maint-5.8/perl/pp.c#131 integrate
... //depot/maint-5.8/perl/pp_sys.c#136 integrate
... //depot/maint-5.8/perl/sv.c#325 integrate
... //depot/maint-5.8/perl/t/op/list.t#4 integrate
... //depot/maint-5.8/perl/t/op/taint.t#17 integrate
... //depot/maint-5.8/perl/t/op/tie.t#16 integrate
Differences ...
==== //depot/maint-5.8/perl/gv.c#95 (text) ====
Index: perl/gv.c
--- perl/gv.c#94~29997~ 2007-01-26 02:30:23.000000000 -0800
+++ perl/gv.c 2007-01-27 03:02:43.000000000 -0800
@@ -648,7 +648,6 @@
sv_setpv(varsv, packname);
sv_catpvs(varsv, "::");
sv_catpvn(varsv, name, len);
- SvTAINTED_off(varsv);
return gv;
}
==== //depot/maint-5.8/perl/mg.c#140 (text) ====
Index: perl/mg.c
--- perl/mg.c#139~30023~ 2007-01-26 13:52:35.000000000 -0800
+++ perl/mg.c 2007-01-27 03:02:43.000000000 -0800
@@ -1323,7 +1323,17 @@
exit(1);
#endif
#endif
- if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+ if (
+#ifdef SIGILL
+ sig == SIGILL ||
+#endif
+#ifdef SIGBUS
+ sig == SIGBUS ||
+#endif
+#ifdef SIGSEGV
+ sig == SIGSEGV ||
+#endif
+ (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
/* Call the perl level handler now--
* with risk we may be in malloc() etc. */
(*PL_sighandlerp)(sig);
==== //depot/maint-5.8/perl/pp.c#131 (text) ====
Index: perl/pp.c
--- perl/pp.c#130~30011~ 2007-01-26 06:31:27.000000000 -0800
+++ perl/pp.c 2007-01-27 03:02:43.000000000 -0800
@@ -635,7 +635,7 @@
}
s = (unsigned char*)(SvPV(sv, len));
pos = len;
- if (pos <= 0 || !SvPOK(sv)) {
+ if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
/* No point in studying a zero length string, and not safe to study
anything that doesn't appear to be a simple scalar (and hence might
change between now and when the regexp engine runs without our set
@@ -4073,7 +4073,7 @@
SV ** const firstlelem = PL_stack_base + POPMARK + 1;
register SV ** const firstrelem = lastlelem + 1;
const I32 arybase = CopARYBASE_get(PL_curcop);
- I32 is_something_there = PL_op->op_flags & OPf_MOD;
+ I32 is_something_there = FALSE;
register const I32 max = lastrelem - lastlelem;
register SV **lelem;
==== //depot/maint-5.8/perl/pp_sys.c#136 (text) ====
Index: perl/pp_sys.c
--- perl/pp_sys.c#135~30023~ 2007-01-26 13:52:35.000000000 -0800
+++ perl/pp_sys.c 2007-01-27 03:02:43.000000000 -0800
@@ -2780,7 +2780,7 @@
do_fstat_warning_check:
if (ckWARN(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO),
- "lstat() on filehandle %s", GvENAME(gv));
+ "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
} else if (PL_laststype != OP_LSTAT)
Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
}
==== //depot/maint-5.8/perl/sv.c#325 (text) ====
Index: perl/sv.c
--- perl/sv.c#324~30006~ 2007-01-26 04:19:35.000000000 -0800
+++ perl/sv.c 2007-01-27 03:02:43.000000000 -0800
@@ -5365,8 +5365,16 @@
pv1 = "";
cur1 = 0;
}
- else
+ else {
+ /* if pv1 and pv2 are the same, second SvPV_const call may
+ * invalidate pv1, so we may need to make a copy */
+ if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
+ pv1 = SvPV_const(sv1, cur1);
+ sv1 = sv_2mortal(newSVpvn(pv1, cur1));
+ if (SvUTF8(sv2)) SvUTF8_on(sv1);
+ }
pv1 = SvPV_const(sv1, cur1);
+ }
if (!sv2){
pv2 = "";
==== //depot/maint-5.8/perl/t/op/list.t#4 (xtext) ====
Index: perl/t/op/list.t
--- perl/t/op/list.t#3~26697~ 2006-01-07 05:18:30.000000000 -0800
+++ perl/t/op/list.t 2007-01-27 03:02:43.000000000 -0800
@@ -1,102 +1,163 @@
#!./perl
-print "1..31\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw(. ../lib);
+}
+
+require "test.pl";
+plan( tests => 57 );
@foo = (1, 2, 3, 4);
-if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";}
+cmp_ok($foo[0], '==', 1, 'first elem');
+cmp_ok($foo[3], '==', 4, 'last elem');
$_ = join(':',@foo);
-if ($_ eq '1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
+cmp_ok($_, 'eq', '1:2:3:4', 'join list');
($a,$b,$c,$d) = (1,2,3,4);
-if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 3\n";} else {print "not ok 3\n";}
+cmp_ok("$a;$b;$c;$d", 'eq', '1;2;3;4', 'list assign');
($c,$b,$a) = split(/ /,"111 222 333");
-if ("$a;$b;$c" eq '333;222;111') {print "ok 4\n";} else {print "not ok 4\n";}
+cmp_ok("$a;$b;$c",'eq','333;222;111','list split on space');
($a,$b,$c) = ($c,$b,$a);
-if ("$a;$b;$c" eq '111;222;333') {print "ok 5\n";} else {print "not ok 5
$a;$b;$c\n";}
+cmp_ok("$a;$b;$c",'eq','111;222;333','trio rotate');
($a, $b) = ($b, $a);
-if ("$a;$b;$c" eq '222;111;333') {print "ok 6\n";} else {print "not ok 6\n";}
+cmp_ok("$a-$b",'eq','222-111','duo swap');
+
+($a, $b) = ($b, $a) = ($a, $b);
+cmp_ok("$a-$b",'eq','222-111','duo swap swap');
($a, $b[1], $c{2}, $d) = (1, 2, 3, 4);
-if ($a eq 1) {print "ok 7\n";} else {print "not ok 7\n";}
-if ($b[1] eq 2) {print "ok 8\n";} else {print "not ok 8\n";}
-if ($c{2} eq 3) {print "ok 9\n";} else {print "not ok 9\n";}
-if ($d eq 4) {print "ok 10\n";} else {print "not ok 10\n";}
+cmp_ok($a,'==',1,'assign scalar in list');
+cmp_ok($b[1],'==',2,'assign aelem in list');
+cmp_ok($c{2},'==',3,'assign helem in list');
+cmp_ok($d,'==',4,'assign last scalar in list');
@foo = (1,2,3,4,5,6,7,8);
($a, $b, $c, $d) = @foo;
-print "#11 $a;$b;$c;$d eq 1;2;3;4\n";
-if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 11\n";} else {print "not ok 11\n";}
+cmp_ok("$a/$b/$c/$d",'eq','1/2/3/4','long list assign');
+
[EMAIL PROTECTED] = (1,2);
+($a, $b, $c, $d) = @foo;
+cmp_ok($a,'==',1,'short list 1 defined');
+cmp_ok($b,'==',2,'short list 2 defined');
+ok(!defined($c),'short list 3 undef');
+ok(!defined($d),'short list 4 undef');
@foo = @bar = (1);
-if (join(':',@foo,@bar) eq '1:1') {print "ok 12\n";} else {print "not ok
12\n";}
+cmp_ok(join(':',@foo,@bar),'eq','1:1','list reassign');
+
[EMAIL PROTECTED] = @bar = (2,3);
+cmp_ok(join(':',join('+',@foo),join('-',@bar)),'eq','2+3:2-3','long list
reassign');
@foo = ();
@foo = 1+2+3;
-if (join(':',@foo) eq '6') {print "ok 13\n";} else {print "not ok 13\n";}
+cmp_ok(join(':',@foo),'eq','6','scalar assign to array');
-for ($x = 0; $x < 3; $x++) {
- ($a, $b, $c) =
- $x == 0?
- ('ok ', 14, "\n"):
- $x == 1?
- ('ok ', 15, "\n"):
- # default
- ('ok ', 16, "\n");
+{
+ my ($a, $b, $c);
+ for ($x = 0; $x < 3; $x = $x + 1) {
+ ($a, $b, $c) =
+ $x == 0 ? ('a','b','c')
+ : $x == 1 ? ('d','e','f')
+ : ('g','h','i')
+ ;
+ if ($x == 0) {
+ cmp_ok($a,'eq','a','ternary for a 1');
+ cmp_ok($b,'eq','b','ternary for b 1');
+ cmp_ok($c,'eq','c','ternary for c 1');
+ }
+ if ($x == 1) {
+ cmp_ok($a,'eq','d','ternary for a 2');
+ cmp_ok($b,'eq','e','ternary for b 2');
+ cmp_ok($c,'eq','f','ternary for c 2');
+ }
+ if ($x == 2) {
+ cmp_ok($a,'eq','g','ternary for a 3');
+ cmp_ok($b,'eq','h','ternary for b 3');
+ cmp_ok($c,'eq','i','ternary for c 3');
+ }
+ }
+}
- print $a,$b,$c;
+{
+ my ($a, $b, $c);
+ for ($x = 0; $x < 3; $x = $x + 1) {
+ ($a, $b, $c) = do {
+ if ($x == 0) {
+ ('a','b','c');
+ }
+ elsif ($x == 1) {
+ ('d','e','f');
+ }
+ else {
+ ('g','h','i');
+ }
+ };
+ if ($x == 0) {
+ cmp_ok($a,'eq','a','block for a 1');
+ cmp_ok($b,'eq','b','block for b 1');
+ cmp_ok($c,'eq','c','block for c 1');
+ }
+ if ($x == 1) {
+ cmp_ok($a,'eq','d','block for a 2');
+ cmp_ok($b,'eq','e','block for b 2');
+ cmp_ok($c,'eq','f','block for c 2');
+ }
+ if ($x == 2) {
+ cmp_ok($a,'eq','g','block for a 3');
+ cmp_ok($b,'eq','h','block for b 3');
+ cmp_ok($c,'eq','i','block for c 3');
+ }
+ }
}
+$x = 666;
@a = ($x == 12345 || (1,2,3));
-if (join('',@a) eq '123') {print "ok 17\n";} else {print "not ok 17\n";}
+cmp_ok(join('*',@a),'eq','1*2*3','logical or f');
@a = ($x == $x || (4,5,6));
-if (join('',@a) eq '1') {print "ok 18\n";} else {print "not ok 18\n";}
-
-if (join('',1,2,(3,4,5)) eq '12345'){print "ok 19\n";}else{print "not ok
19\n";}
-if (join('',(1,2,3,4,5)) eq '12345'){print "ok 20\n";}else{print "not ok
20\n";}
-if (join('',(1,2,3,4),5) eq '12345'){print "ok 21\n";}else{print "not ok
21\n";}
-if (join('',1,(2,3,4),5) eq '12345'){print "ok 22\n";}else{print "not ok
22\n";}
-if (join('',1,2,(3,4),5) eq '12345'){print "ok 23\n";}else{print "not ok
23\n";}
-if (join('',1,2,3,(4),5) eq '12345'){print "ok 24\n";}else{print "not ok
24\n";}
-
-for ($x = 0; $x < 3; $x++) {
- ($a, $b, $c) = do {
- if ($x == 0) {
- ('ok ', 25, "\n");
- }
- elsif ($x == 1) {
- ('ok ', 26, "\n");
- }
- else {
- ('ok ', 27, "\n");
- }
- };
+cmp_ok(join('*',@a),'eq','1','logical or t');
- print $a,$b,$c;
-}
+cmp_ok(join('',1,2,(3,4,5)),'eq','12345','list ..(...)');
+cmp_ok(join('',(1,2,3,4,5)),'eq','12345','list (.....)');
+cmp_ok(join('',(1,2,3,4),5),'eq','12345','list (....).');
+cmp_ok(join('',1,(2,3,4),5),'eq','12345','list .(...).');
+cmp_ok(join('',1,2,(3,4),5),'eq','12345','list ..(..).');
+cmp_ok(join('',1,2,3,(4),5),'eq','12345','list ...(.).');
+cmp_ok(join('',(1,2),3,(4,5)),'eq','12345','list (..).(..)');
-# slices
{
my @a = (0, undef, undef, 3);
my @b = @a[1,2];
my @c = (0, undef, undef, 3)[1, 2];
- print "not " unless @b == @c and @c == 2;
- print "ok 28\n";
+ cmp_ok(scalar(@b),'==',scalar(@c),'slice and slice');
+ cmp_ok(scalar(@c),'==',2,'slice len');
@b = (29, scalar @c[()]);
- print "not " if join(':',@b) ne '29:';
- print "ok 29\n";
+ cmp_ok(join(':',@b),'eq','29:','slice ary nil');
my %h = (a => 1);
@b = (30, scalar @h{()});
- print "not " if join(':',@b) ne '30:';
- print "ok 30\n";
+ cmp_ok(join(':',@b),'eq','30:','slice hash nil');
my $size = scalar(()[1..1]);
- print "not " if $size != 0;
- print "ok 31\n";
+ cmp_ok($size,'==','0','size nil');
}
+
+{
+ # perl #39882
+ sub test_zero_args {
+ my $test_name = shift;
+ is(scalar(@_), 0, $test_name);
+ }
+ test_zero_args("simple list slice", (10,11)[2,3]);
+ test_zero_args("grepped list slice", grep(1, (10,11)[2,3]));
+ test_zero_args("sorted list slice", sort((10,11)[2,3]));
+ test_zero_args("assigned list slice", my @tmp = (10,11)[2,3]);
+ test_zero_args("do-returned list slice", do { (10,11)[2,3]; });
+}
+
==== //depot/maint-5.8/perl/t/op/taint.t#17 (xtext) ====
Index: perl/t/op/taint.t
--- perl/t/op/taint.t#16~27928~ 2006-04-20 14:48:52.000000000 -0700
+++ perl/t/op/taint.t 2007-01-27 03:02:43.000000000 -0800
@@ -17,8 +17,7 @@
use File::Spec::Functions;
BEGIN { require './test.pl'; }
-plan tests => 244;
-
+plan tests => 246;
$| = 1;
@@ -1135,3 +1134,22 @@
eval { local $0, eval '1' };
test $@ eq '';
}
+
+{
+ package AUTOLOAD_TAINT;
+ sub AUTOLOAD {
+ our $AUTOLOAD;
+ return if $AUTOLOAD =~ /DESTROY/;
+ if ($AUTOLOAD =~ /untainted/) {
+ main::ok(!main::tainted($AUTOLOAD), '$AUTOLOAD can be untainted');
+ } else {
+ main::ok(main::tainted($AUTOLOAD), '$AUTOLOAD can be tainted');
+ }
+ }
+
+ package main;
+ my $o = bless [], 'AUTOLOAD_TAINT';
+ $o->$TAINT;
+ $o->untainted;
+}
+
==== //depot/maint-5.8/perl/t/op/tie.t#16 (xtext) ====
Index: perl/t/op/tie.t
--- perl/t/op/tie.t#15~27392~ 2006-03-06 12:40:15.000000000 -0800
+++ perl/t/op/tie.t 2007-01-27 03:02:43.000000000 -0800
@@ -547,3 +547,13 @@
print $h,"\n";
EXPECT
3.3
+########
+# Bug 37731
+sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] }
+sub foo::FETCH { $_[0]->{value} }
+tie my $VAR, 'foo', '42';
+foreach my $var ($VAR) {
+ print +($var eq $VAR) ? "yes\n" : "no\n";
+}
+EXPECT
+yes
End of Patch.
