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.