Change 33941 by [EMAIL PROTECTED] on 2008/05/27 22:58:13
Integrate:
[ 33297]
Subject: [PATCH] Read-only variable tests
From: "Jerry D. Hedden" <[EMAIL PROTECTED]>
Date: Fri, 8 Feb 2008 14:06:41 -0500
Message-ID: <[EMAIL PROTECTED]>
with one less TODO test
[ 33311]
Subject: Re: [perl #50706] %^H affecting outside file scopes
From: Rick Delaney <[EMAIL PROTECTED]>
Date: Tue, 12 Feb 2008 14:05:22 -0500
Message-ID: <[EMAIL PROTECTED]>
[ 33312]
Add missing file to MANIFEST, to go with change #33311
[ 33313]
Subject: [PATCH t/op/pat.t] Re: [perl #50496] Bug Report: 'keys %+'
does not return the correct keys.
From: Abigail <[EMAIL PROTECTED]>
Date: Thu, 7 Feb 2008 17:53:30 +0100
Message-ID: <[EMAIL PROTECTED]>
with tweaks (one more test marked TODO)
[ 33317]
Typo catch, by Abigail
[ 33322]
Correctly reference count the hints hash
[ 33323]
Fix macro name in comment
[ 33324]
Fix perlbug 50114 and document what the code does a bit better
[ 33325]
Fix bug 50496 -- regcomp.c=~s/lastcloseparen/lastparen/g
-- lastcloseparen is literally the index of the last paren closed
-- lastparen is index of the highest index paren that has been closed.
In nested parens, they will be completely different.
'ab'=~/(a(b))/ will have: lastparen = 2, lastcloseparen = 1
'ab'=~/(a)(b)/ will have: lastparen = lastcloseparen = 2
[ 33327]
Subject: [ patch ] silence 2 possibly uninitialized vars
From: Jim Cromie <[EMAIL PROTECTED]>
Date: Sat, 16 Feb 2008 18:02:19 -0700
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/maint-5.10/perl/MANIFEST#26 integrate
... //depot/maint-5.10/perl/lib/Internals.t#2 integrate
... //depot/maint-5.10/perl/op.c#10 integrate
... //depot/maint-5.10/perl/pp_ctl.c#14 integrate
... //depot/maint-5.10/perl/regcomp.c#13 integrate
... //depot/maint-5.10/perl/t/lib/Sans_mypragma.pm#1 branch
... //depot/maint-5.10/perl/t/lib/mypragma.t#2 integrate
... //depot/maint-5.10/perl/t/op/pat.t#9 integrate
... //depot/maint-5.10/perl/t/op/re_tests#4 integrate
... //depot/maint-5.10/perl/toke.c#6 integrate
Differences ...
==== //depot/maint-5.10/perl/MANIFEST#26 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#25~33921~ 2008-05-24 09:32:36.000000000 -0700
+++ perl/MANIFEST 2008-05-27 15:58:13.000000000 -0700
@@ -3582,6 +3582,7 @@
t/lib/sample-tests/too_many Test data for Test::Harness
t/lib/sample-tests/vms_nit Test data for Test::Harness
t/lib/sample-tests/with_comments Test data for Test::Harness
+t/lib/Sans_mypragma.pm Test module for t/lib/mypragma.t
t/lib/strict/refs Tests of "use strict 'refs'" for strict.t
t/lib/strict/subs Tests of "use strict 'subs'" for strict.t
t/lib/strict/vars Tests of "use strict 'vars'" for strict.t
==== //depot/maint-5.10/perl/lib/Internals.t#2 (text) ====
Index: perl/lib/Internals.t
--- perl/lib/Internals.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/lib/Internals.t 2008-05-27 15:58:13.000000000 -0700
@@ -7,39 +7,146 @@
}
}
-use Test::More tests => 33;
+use Test::More tests => 74;
+my $ro_err = qr/^Modification of a read-only value attempted/;
+
+### Read-only scalar
my $foo;
-my @foo;
-my %foo;
ok( !Internals::SvREADONLY $foo );
+$foo = 3;
+is($foo, 3);
+
ok( Internals::SvREADONLY $foo, 1 );
ok( Internals::SvREADONLY $foo );
+eval { $foo = 'foo'; };
+like($@, $ro_err, q/Can't modify read-only scalar/);
+eval { undef($foo); };
+like($@, $ro_err, q/Can't undef read-only scalar/);
+is($foo, 3);
+
ok( !Internals::SvREADONLY $foo, 0 );
ok( !Internals::SvREADONLY $foo );
+$foo = 'foo';
+is($foo, 'foo');
+
+### Read-only array
+my @foo;
ok( !Internals::SvREADONLY @foo );
[EMAIL PROTECTED] = (1..3);
+is(scalar(@foo), 3);
+is($foo[2], 3);
+
ok( Internals::SvREADONLY @foo, 1 );
ok( Internals::SvREADONLY @foo );
+eval { undef(@foo); };
+like($@, $ro_err, q/Can't undef read-only array/);
+eval { delete($foo[2]); };
+like($@, $ro_err, q/Can't delete from read-only array/);
+eval { shift(@foo); };
+like($@, $ro_err, q/Can't shift read-only array/);
+eval { push(@foo, 'bork'); };
+like($@, $ro_err, q/Can't push onto read-only array/);
+eval { @foo = qw/foo bar/; };
+like($@, $ro_err, q/Can't reassign read-only array/);
+
ok( !Internals::SvREADONLY @foo, 0 );
ok( !Internals::SvREADONLY @foo );
+eval { @foo = qw/foo bar/; };
+is(scalar(@foo), 2);
+is($foo[1], 'bar');
+
+### Read-only array element
ok( !Internals::SvREADONLY $foo[2] );
+$foo[2] = 'baz';
+is($foo[2], 'baz');
+
ok( Internals::SvREADONLY $foo[2], 1 );
ok( Internals::SvREADONLY $foo[2] );
+
+$foo[0] = 99;
+is($foo[0], 99, 'Rest of array still modifiable');
+
+shift(@foo);
+ok( Internals::SvREADONLY $foo[1] );
+eval { $foo[1] = 'bork'; };
+like($@, $ro_err, 'Read-only array element moved');
+is($foo[1], 'baz');
+
+ok( !Internals::SvREADONLY $foo[2] );
+$foo[2] = 'qux';
+is($foo[2], 'qux');
+
+unshift(@foo, 'foo');
+ok( !Internals::SvREADONLY $foo[1] );
+ok( Internals::SvREADONLY $foo[2] );
+
+eval { $foo[2] = 86; };
+like($@, $ro_err, q/Can't modify read-only array element/);
+eval { undef($foo[2]); };
+like($@, $ro_err, q/Can't undef read-only array element/);
+TODO: {
+ local $TODO = 'Due to restricted hashes implementation';
+ eval { delete($foo[2]); };
+ like($@, $ro_err, q/Can't delete read-only array element/);
+}
+
ok( !Internals::SvREADONLY $foo[2], 0 );
ok( !Internals::SvREADONLY $foo[2] );
+$foo[2] = 'xyzzy';
+is($foo[2], 'xyzzy');
+
+### Read-only hash
+my %foo;
ok( !Internals::SvREADONLY %foo );
+%foo = ('foo' => 1, 2 => 'bar');
+is(scalar(keys(%foo)), 2);
+is($foo{'foo'}, 1);
+
ok( Internals::SvREADONLY %foo, 1 );
ok( Internals::SvREADONLY %foo );
+eval { undef(%foo); };
+like($@, $ro_err, q/Can't undef read-only hash/);
+TODO: {
+ local $TODO = 'Due to restricted hashes implementation';
+ eval { %foo = ('ping' => 'pong'); };
+ like($@, $ro_err, q/Can't modify read-only hash/);
+}
+eval { $foo{'baz'} = 123; };
+like($@, qr/Attempt to access disallowed key/, q/Can't add to a read-only
hash/);
+
+# These ops are allow for Hash::Util functionality
+$foo{2} = 'qux';
+is($foo{2}, 'qux', 'Can modify elements in a read-only hash');
+my $qux = delete($foo{2});
+ok(! exists($foo{2}), 'Can delete keys from a read-only hash');
+is($qux, 'qux');
+$foo{2} = 2;
+is($foo{2}, 2, 'Can add back deleted keys in a read-only hash');
+
ok( !Internals::SvREADONLY %foo, 0 );
ok( !Internals::SvREADONLY %foo );
+### Read-only hash values
+
ok( !Internals::SvREADONLY $foo{foo} );
+$foo{'foo'} = 'bar';
+is($foo{'foo'}, 'bar');
+
ok( Internals::SvREADONLY $foo{foo}, 1 );
ok( Internals::SvREADONLY $foo{foo} );
+eval { $foo{'foo'} = 88; };
+like($@, $ro_err, q/Can't modify a read-only hash value/);
+eval { undef($foo{'foo'}); };
+like($@, $ro_err, q/Can't undef a read-only hash value/);
+my $bar = delete($foo{'foo'});
+ok(! exists($foo{'foo'}), 'Can delete a read-only hash value');
+is($bar, 'bar');
+
ok( !Internals::SvREADONLY $foo{foo}, 0 );
ok( !Internals::SvREADONLY $foo{foo} );
==== //depot/maint-5.10/perl/op.c#10 (text) ====
Index: perl/op.c
--- perl/op.c#9~33895~ 2008-05-21 00:11:50.000000000 -0700
+++ perl/op.c 2008-05-27 15:58:13.000000000 -0700
@@ -90,7 +90,7 @@
magic type 'H'. This magic (itself) does nothing, but its presence causes
the values to gain magic type 'h', which has entries for set and clear.
C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
- record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
+ record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
it will be correctly restored when any inner compiling scope is exited.
*/
==== //depot/maint-5.10/perl/pp_ctl.c#14 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#13~33857~ 2008-05-18 12:29:48.000000000 -0700
+++ perl/pp_ctl.c 2008-05-27 15:58:13.000000000 -0700
@@ -3485,6 +3485,11 @@
SAVEHINTS();
PL_hints = 0;
+ if (PL_compiling.cop_hints_hash) {
+ Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+ PL_compiling.cop_hints_hash = NULL;
+ }
+
SAVECOMPILEWARNINGS();
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = pWARN_ALL ;
==== //depot/maint-5.10/perl/regcomp.c#13 (text) ====
Index: perl/regcomp.c
--- perl/regcomp.c#12~33884~ 2008-05-20 08:07:58.000000000 -0700
+++ perl/regcomp.c 2008-05-27 15:58:13.000000000 -0700
@@ -4422,7 +4422,17 @@
regnode *first= scan;
regnode *first_next= regnext(first);
- /* Skip introductions and multiplicators >= 1. */
+ /*
+ * Skip introductions and multiplicators >= 1
+ * so that we can extract the 'meat' of the pattern that must
+ * match in the large if() sequence following.
+ * NOTE that EXACT is NOT covered here, as it is normally
+ * picked up by the optimiser separately.
+ *
+ * This is unfortunate as the optimiser isnt handling lookahead
+ * properly currently.
+ *
+ */
while ((OP(first) == OPEN && (sawopen = 1)) ||
/* An OR of *one* alternative - should not happen now. */
(OP(first) == BRANCH && OP(first_next) != BRANCH) ||
@@ -4434,16 +4444,17 @@
(PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
(OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
{
-
+ /*
+ * the only op that could be a regnode is PLUS, all the rest
+ * will be regnode_1 or regnode_2.
+ *
+ */
if (OP(first) == PLUS)
sawplus = 1;
else
first += regarglen[OP(first)];
- if (OP(first) == IFMATCH) {
- first = NEXTOPER(first);
- first += EXTRA_STEP_2ARGS;
- } else /* XXX possible optimisation for /(?=)/ */
- first = NEXTOPER(first);
+
+ first = NEXTOPER(first);
first_next= regnext(first);
}
@@ -4974,6 +4985,8 @@
SV*
Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, const U32 flags)
{
+ GET_RE_DEBUG_FLAGS_DECL;
+
if (rx && RXp_PAREN_NAMES(rx)) {
HV *hv = RXp_PAREN_NAMES(rx);
HE *temphe;
@@ -4983,7 +4996,7 @@
SV* sv_dat = HeVAL(temphe);
I32 *nums = (I32*)SvPVX(sv_dat);
for ( i = 0; i < SvIVX(sv_dat); i++ ) {
- if ((I32)(rx->lastcloseparen) >= nums[i] &&
+ if ((I32)(rx->lastparen) >= nums[i] &&
rx->offs[nums[i]].start != -1 &&
rx->offs[nums[i]].end != -1)
{
@@ -5037,7 +5050,7 @@
SV* sv_dat = HeVAL(temphe);
I32 *nums = (I32*)SvPVX(sv_dat);
for ( i = 0; i < SvIVX(sv_dat); i++ ) {
- if ((I32)(rx->lastcloseparen) >= nums[i] &&
+ if ((I32)(rx->lastparen) >= nums[i] &&
rx->offs[nums[i]].start != -1 &&
rx->offs[nums[i]].end != -1)
{
==== //depot/maint-5.10/perl/t/lib/Sans_mypragma.pm#1 (text) ====
Index: perl/t/lib/Sans_mypragma.pm
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/t/lib/Sans_mypragma.pm 2008-05-27 15:58:13.000000000 -0700
@@ -0,0 +1,7 @@
+package Sans_mypragma;
+
+sub affected {
+ mypragma::in_effect();
+}
+
+1;
==== //depot/maint-5.10/perl/t/lib/mypragma.t#2 (text) ====
Index: perl/t/lib/mypragma.t
--- perl/t/lib/mypragma.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/lib/mypragma.t 2008-05-27 15:58:13.000000000 -0700
@@ -7,7 +7,7 @@
use strict;
use warnings;
-use Test::More tests => 13;
+use Test::More tests => 14;
use mypragma (); # don't enable this pragma yet
@@ -22,7 +22,10 @@
or die $@;
use mypragma;
+ use Sans_mypragma;
is(mypragma::in_effect(), 42, "pragma is in effect within this block");
+ is(Sans_mypragma::affected(), undef,
+ "pragma not in effect outside this file");
eval qq{is(mypragma::in_effect(), 42,
"pragma is in effect within this eval"); 1} or die $@;
==== //depot/maint-5.10/perl/t/op/pat.t#9 (xtext) ====
Index: perl/t/op/pat.t
--- perl/t/op/pat.t#8~33920~ 2008-05-24 09:04:48.000000000 -0700
+++ perl/t/op/pat.t 2008-05-27 15:58:13.000000000 -0700
@@ -3787,6 +3787,45 @@
ok(!$@,'lvalue $+{...} should not throw an exception');
}
{
+ #
+ # Almost the same as the block above, except that the capture is nested.
+ #
+ my $s = 'foo bar baz';
+ my (@k,@v,@fetch,$res);
+ my $count = 0;
+ my @names = qw($+{A} $+{B} $+{C} $+{D});
+ if ($s =~ /(?<D>(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz))/) {
+ while (my ($k,$v) = each(%+)) {
+ $count++;
+ }
+ @k = sort keys(%+);
+ @v = sort values(%+);
+ $res = 1;
+ push @fetch,
+ [ "$+{A}", "$2" ],
+ [ "$+{B}", "$3" ],
+ [ "$+{C}", "$4" ],
+ [ "$+{D}", $1 ],
+ ;
+ }
+ foreach (0..3) {
+ if ($fetch[$_]) {
+ iseq($fetch[$_][0],$fetch[$_][1],$names[$_]);
+ } else {
+ ok(0, $names[$_]);
+ }
+ }
+ iseq($res,1,"$s~=/(?<D>(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz))/");
+ iseq($count,4,"Got 4 keys in %+ via each -- bug 50496");
+ iseq([EMAIL PROTECTED], 4, 'Got 4 keys in %+ via keys -- bug 50496');
+ iseq("@k","A B C D", "Got expected keys -- bug 50496");
+ iseq("@v","bar baz foo foo bar baz", "Got expected values -- bug = 50496");
+ eval'
+ print for $+{this_key_doesnt_exist};
+ ';
+ ok(!$@,'lvalue $+{...} should not throw an exception');
+}
+{
my $s='foo bar baz';
my @res;
if ('1234'=~/(?<A>1)(?<B>2)(?<A>3)(?<B>4)/) {
@@ -4679,7 +4718,7 @@
# Don't forget to update this!
BEGIN {
- $::TestCount = 4024;
+ $::TestCount = 4034;
print "1..$::TestCount\n";
}
==== //depot/maint-5.10/perl/t/op/re_tests#4 (text) ====
Index: perl/t/op/re_tests
--- perl/t/op/re_tests#3~33920~ 2008-05-24 09:04:48.000000000 -0700
+++ perl/t/op/re_tests 2008-05-27 15:58:13.000000000 -0700
@@ -1341,3 +1341,6 @@
.*\z foo\n y - -
^(?:(\d)x)?\d$ 1 y ${\(defined($1)?1:0)} 0
.*?(?:(\w)|(\w))x abx y $1-$2 b-
+
+0{50} 000000000000000000000000000000000000000000000000000 y -
-
+
==== //depot/maint-5.10/perl/toke.c#6 (text) ====
Index: perl/toke.c
--- perl/toke.c#5~33940~ 2008-05-27 13:57:19.000000000 -0700
+++ perl/toke.c 2008-05-27 15:58:13.000000000 -0700
@@ -6614,7 +6614,7 @@
(*s == ':' && s[1] == ':'))
{
#ifdef PERL_MAD
- SV *nametoke;
+ SV *nametoke = NULL;
#endif
PL_expect = XBLOCK;
@@ -12290,8 +12290,8 @@
bool eofmt = FALSE;
#ifdef PERL_MAD
char *tokenstart = s;
- SV* savewhite;
-
+ SV* savewhite = NULL;
+
if (PL_madskills) {
savewhite = PL_thiswhite;
PL_thiswhite = 0;
End of Patch.
