Change 33211 by [EMAIL PROTECTED] on 2008/02/02 20:21:10
Integrate:
[ 33132]
Integrate:
[ 32686]
Subject: mg_free frees data but leaves it accessible
From: Yuval Kogman <[EMAIL PROTECTED]>
Message-ID: <[EMAIL PROTECTED]>
Date: Fri, 21 Dec 2007 00:13:31 +0200
[ 32743]
You can't coerce a typeglob to a string. (Restore the error message -
an assertion failure is not helpful). Test the 3 basic coercion
error messages.
[ 32754]
Silly Nick. There was a bug in change 30757 whereby the precomp of a
dup'd regexp would be pointing somewhere la-la. Probably at the precomp
of the same regexp in the parent thread. (So it is only likely to go
nasal daemon if the parent thread terminates first, or explicitly goes
around freeing up run time generated regexps.)
[ 32779]
Subject: [PATCH] Typo in op.c
From: Vincent Pit <[EMAIL PROTECTED]>
Message-ID: <[EMAIL PROTECTED]>
Date: Tue, 25 Dec 2007 17:12:33 +0100
(And then an update to make the tests in gv.t expect the right thing,
and test the behaviour that my change 26482 was originally supposed to
produce, but didn't until this typo was fixed)
[ 32874]
Subject: [perl #49003] pp_ftrread appears to use the wrong access mode
for -x when using "use filetest 'access';"
From: [EMAIL PROTECTED] (via RT) <[EMAIL PROTECTED]>
Date: Fri, 21 Dec 2007 10:05:15 -0800
Message-ID: <[EMAIL PROTECTED]>
[ 32906]
change #31447 was wrong. Really handle cloning a stale lexical var
[ 32932]
Fix the bug introduced by the bug fix of change 30755.
(Certain regexps could SEGV if cloned).
[ 32935]
Fix bug picked up by printf format warnings - a cast is needed where
UV is larger than U32 for dumping leaking scalars.
[ 32968]
Fix bug whereby length on a tied scalar that returned a UTF-8 value
would not be correct the first time. (And for the more pathological
case, would be incorrect if the UTF-8-ness of the returned value
changed.)
[ 33026]
When changing the op_ppaddr of an op, one must keep its op_type
in sync. That helps writers of alternate runloops.
[ 33033]
In pp_subst, rxtainted is not a boolean, as it stores 2 bits of values.
[but, despite my best efforts at partitioning changes into maint-5.10
into those that were for maint-5.8 and those that weren't, it's still
not correct. So changes 32754 and 32906 aren't in, and only the tests
from change 32743 are in]
Affected files ...
... //depot/maint-5.8/perl/MANIFEST#421 integrate
... //depot/maint-5.8/perl/mg.c#160 integrate
... //depot/maint-5.8/perl/op.c#226 integrate
... //depot/maint-5.8/perl/perl.c#227 integrate
... //depot/maint-5.8/perl/pp_hot.c#142 integrate
... //depot/maint-5.8/perl/pp_sys.c#159 integrate
... //depot/maint-5.8/perl/regcomp.c#116 integrate
... //depot/maint-5.8/perl/t/op/gv.t#11 integrate
... //depot/maint-5.8/perl/t/op/length.t#3 integrate
... //depot/maint-5.8/perl/t/op/pat.t#50 integrate
... //depot/maint-5.8/perl/t/uni/tie.t#1 branch
Differences ...
==== //depot/maint-5.8/perl/MANIFEST#421 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#420~33198~ 2008-02-02 09:34:10.000000000 -0800
+++ perl/MANIFEST 2008-02-02 12:21:10.000000000 -0800
@@ -3227,6 +3227,7 @@
t/uni/write.t See if Unicode formats work
t/win32/system.t See if system works in Win*
t/win32/system_tests Test runner for system.t
+t/uni/tie.t See if Unicode tie works
t/x2p/s2p.t See if s2p/psed work
uconfig.h Configuration header for microperl
uconfig.sh Configuration script for microperl
==== //depot/maint-5.8/perl/mg.c#160 (text) ====
Index: perl/mg.c
--- perl/mg.c#159~33190~ 2008-02-02 08:22:10.000000000 -0800
+++ perl/mg.c 2008-02-02 12:21:10.000000000 -0800
@@ -309,12 +309,15 @@
}
}
- if (DO_UTF8(sv)) {
+ {
+ /* You can't know whether it's UTF-8 until you get the string again...
+ */
const U8 *s = (U8*)SvPV_const(sv, len);
- len = utf8_length((U8*)s, (U8*)s + len);
+
+ if (DO_UTF8(sv)) {
+ len = utf8_length((U8*)s, (U8*)s + len);
+ }
}
- else
- (void)SvPV_const(sv, len);
return len;
}
@@ -497,6 +500,7 @@
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
+ SvMAGIC_set(sv, moremagic);
}
SvMAGIC_set(sv, NULL);
return 0;
==== //depot/maint-5.8/perl/op.c#226 (text) ====
Index: perl/op.c
--- perl/op.c#225~33190~ 2008-02-02 08:22:10.000000000 -0800
+++ perl/op.c 2008-02-02 12:21:10.000000000 -0800
@@ -7329,7 +7329,7 @@
o->op_seq = PL_op_seqmax++;
- if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
+ if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
break;
if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
==== //depot/maint-5.8/perl/perl.c#227 (text) ====
Index: perl/perl.c
--- perl/perl.c#226~33202~ 2008-02-02 09:56:35.000000000 -0800
+++ perl/perl.c 2008-02-02 12:21:10.000000000 -0800
@@ -1298,7 +1298,7 @@
PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
" flags=0x08%"UVxf
" refcnt=%"UVuf pTHX__FORMAT "\n",
- sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE);
+ sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt pTHX__VALUE);
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
Perl_dump_sv_child(aTHX_ sv);
#endif
@@ -2699,7 +2699,9 @@
Zero(&method_op, 1, UNOP);
method_op.op_next = PL_op;
method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
+ method_op.op_type = OP_METHOD;
myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
+ myop.op_type = OP_ENTERSUB;
PL_op = (OP*)&method_op;
}
==== //depot/maint-5.8/perl/pp_hot.c#142 (text) ====
Index: perl/pp_hot.c
--- perl/pp_hot.c#141~32545~ 2007-11-28 15:35:51.000000000 -0800
+++ perl/pp_hot.c 2008-02-02 12:21:10.000000000 -0800
@@ -1992,7 +1992,7 @@
I32 maxiters;
register I32 i;
bool once;
- bool rxtainted;
+ U8 rxtainted;
char *orig;
I32 r_flags;
register REGEXP *rx = PM_GETRE(pm);
==== //depot/maint-5.8/perl/pp_sys.c#159 (text) ====
Index: perl/pp_sys.c
--- perl/pp_sys.c#158~33190~ 2008-02-02 08:22:10.000000000 -0800
+++ perl/pp_sys.c 2008-02-02 12:21:10.000000000 -0800
@@ -2974,10 +2974,9 @@
effective = TRUE;
break;
-
case OP_FTEEXEC:
#ifdef PERL_EFF_ACCESS
- access_mode = W_OK;
+ access_mode = X_OK;
#else
use_access = 0;
#endif
==== //depot/maint-5.8/perl/regcomp.c#116 (text) ====
Index: perl/regcomp.c
--- perl/regcomp.c#115~33175~ 2008-02-01 12:32:00.000000000 -0800
+++ perl/regcomp.c 2008-02-02 12:21:10.000000000 -0800
@@ -4855,7 +4855,9 @@
/* Do it this way to avoid reading from *r after the StructCopy().
That way, if any of the sv_dup_inc()s dislodge *r from the L1
cache, it doesn't matter. */
- const bool anchored = r->check_substr == r->anchored_substr;
+ const bool anchored = r->check_substr
+ ? r->check_substr == r->anchored_substr
+ : r->check_utf8 == r->anchored_utf8;
Newx(ret->substrs, 1, struct reg_substr_data);
StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
@@ -4878,6 +4880,12 @@
ret->check_substr = ret->float_substr;
ret->check_utf8 = ret->float_utf8;
}
+ } else if (ret->check_utf8) {
+ if (anchored) {
+ ret->check_utf8 = ret->anchored_utf8;
+ } else {
+ ret->check_utf8 = ret->float_utf8;
+ }
}
}
==== //depot/maint-5.8/perl/t/op/gv.t#11 (xtext) ====
Index: perl/t/op/gv.t
--- perl/t/op/gv.t#10~32389~ 2007-11-18 00:28:57.000000000 -0800
+++ perl/t/op/gv.t 2008-02-02 12:21:10.000000000 -0800
@@ -12,7 +12,7 @@
use warnings;
require './test.pl';
-plan( tests => 153 );
+plan( tests => 170 );
# type coersion on assignment
$foo = 'foo';
@@ -346,18 +346,15 @@
is (eval 'spritsits', "Value", "Constant has correct value");
is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
-my $result;
# Check that assignment to an existing typeglob works
{
my $w = '';
local $SIG{__WARN__} = sub { $w = $_[0] };
- $result = *{"plunk"} = \&{"oonk"};
+ *{"plunk"} = [];
+ *{"plunk"} = \&{"oonk"};
is($w, '', "Should be no warning");
}
-is (ref \$result, 'GLOB',
- "Non void assignment should still return a typeglob");
-
is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
is (eval 'plunk', "Value", "Constant has correct value");
is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
@@ -367,7 +364,7 @@
{
my $w = '';
local $SIG{__WARN__} = sub { $w = $_[0] };
- $result = *{$gr} = \&{"oonk"};
+ *{$gr} = \&{"oonk"};
is($w, '', "Redefining a constant sub to another constant sub with the same
underlying value should not warn (It's just re-exporting, and that was always
legal)");
}
@@ -375,6 +372,48 @@
is (eval 'plunk', "Value", "Constant has correct value");
is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
+# Non-void context should defeat the optimisation, and will cause the original
+# to be promoted (what change 26482 intended)
+my $result;
+{
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ $result = *{"awkkkkkk"} = \&{"oonk"};
+ is($w, '', "Should be no warning");
+}
+
+is (ref \$result, 'GLOB',
+ "Non void assignment should still return a typeglob");
+
+is (ref \$::{oonk}, 'GLOB', "This export does affect original");
+is (eval 'plunk', "Value", "Constant has correct value");
+is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
+
+delete $::{oonk};
+$::{oonk} = \"Value";
+
+sub non_dangling {
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ *{"zap"} = \&{"oonk"};
+ is($w, '', "Should be no warning");
+}
+
+non_dangling();
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'zap', "Value", "Constant has correct value");
+is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS");
+
+sub dangling {
+ local $SIG{__WARN__} = sub { die $_[0] };
+ *{"biff"} = \&{"oonk"};
+}
+
+dangling();
+is (ref \$::{oonk}, 'GLOB', "This export does affect original");
+is (eval 'biff', "Value", "Constant has correct value");
+is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
+
{
use vars qw($glook $smek $foof);
# Check reference assignment isn't affected by the SV type (bug #38439)
@@ -446,6 +485,30 @@
"Assigment works when glob created midway (bug 45607)"); 1'
or die $@;
}
+
+# For now these tests are here, but they would probably be better in a file for
+# tests for croaks. (And in turn, that probably deserves to be in a different
+# directory. Gerard Goossen has a point about the layout being unclear
+
+sub coerce_integer {
+ no warnings 'numeric';
+ $_[0] |= 0;
+}
+sub coerce_number {
+ no warnings 'numeric';
+ $_[0] += 0;
+}
+sub coerce_string {
+ $_[0] .= '';
+}
+
+foreach my $type (qw(integer number string)) {
+ my $prog = "coerce_$type(*STDERR)";
+ is (scalar eval "$prog; 1", undef, "$prog failed...");
+ like ($@, qr/Can't coerce GLOB to $type in/,
+ "with the correct error message");
+}
+
__END__
Perl
Rules
==== //depot/maint-5.8/perl/t/op/length.t#3 (text) ====
Index: perl/t/op/length.t
--- perl/t/op/length.t#2~19968~ 2003-07-03 12:17:29.000000000 -0700
+++ perl/t/op/length.t 2008-02-02 12:21:10.000000000 -0800
@@ -2,10 +2,11 @@
BEGIN {
chdir 't' if -d 't';
+ require './test.pl';
@INC = '../lib';
}
-print "1..20\n";
+plan (tests => 22);
print "not " unless length("") == 0;
print "ok 1\n";
@@ -148,3 +149,15 @@
substr($a, 0, 1) = '';
print length $a == 998 ? "ok 20\n" : "not ok 20\n";
}
+
+curr_test(21);
+
+require Tie::Scalar;
+
+$u = "ASCII";
+
+tie $u, 'Tie::StdScalar', chr 256;
+
+is(length $u, 1, "Length of a UTF-8 scalar returned from tie");
+is(length $u, 1, "Again! Again!");
+
==== //depot/maint-5.8/perl/t/uni/tie.t#1 (text) ====
Index: perl/t/uni/tie.t
--- /dev/null 2008-02-01 14:47:59.480979692 -0800
+++ perl/t/uni/tie.t 2008-02-02 12:21:10.000000000 -0800
@@ -0,0 +1,49 @@
+#!perl -w
+
+BEGIN {
+ if ($ENV{'PERL_CORE'}){
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+use Test::More tests => 9;
+use strict;
+
+{
+ package UTF8Toggle;
+
+ sub TIESCALAR {
+ my $class = shift;
+ my $value = shift;
+ my $state = shift||0;
+ return bless [$value, $state], $class;
+ }
+
+ sub FETCH {
+ my $self = shift;
+ $self->[1] = ! $self->[1];
+ if ($self->[1]) {
+ utf8::downgrade($self->[0]);
+ } else {
+ utf8::upgrade($self->[0]);
+ }
+ $self->[0];
+ }
+}
+
+foreach my $t ("ASCII", "B\366se") {
+ my $length = length $t;
+
+ my $u;
+ tie $u, 'UTF8Toggle', $t;
+ is (length $u, $length, "length of '$t'");
+ is (length $u, $length, "length of '$t'");
+ is (length $u, $length, "length of '$t'");
+ is (length $u, $length, "length of '$t'");
+}
+
+{
+ local $TODO = "Need more tests!";
+ fail();
+}
End of Patch.
