Change 33135 by [EMAIL PROTECTED] on 2008/01/30 19:50:56
Integrate:
[ 32761]
Fix Perl #49190, tests from Abigail, codefix from me.
[ 32857]
Fix regexec.c so $^N and $+ are correctly updated so that they work
properly inside of (?{...}) blocks as reported by Moritz Lenz in
Subject: Bugs in extended regexp features
From: Moritz Lenz <[EMAIL PROTECTED]>
Date: Sat, 05 Jan 2008 17:14:37 +0100
Message-ID: <[EMAIL PROTECTED]>
[ 32873]
Subject: Re: [perl #49264] say behaves as just print on tied filehandle
From: Michael G Schwern <[EMAIL PROTECTED]>
Date: Wed, 02 Jan 2008 17:08:36 -0800
Message-ID: <[EMAIL PROTECTED]>
[ 32915]
Fix leak introduced by change #32873, thanks to Nicholas
[ 32948]
Subject: Re: [perl #49564] Re: MRO and av_clear
From: Rick Delaney <[EMAIL PROTECTED]>
Date: Wed, 9 Jan 2008 13:36:55 -0500
Message-ID: <[EMAIL PROTECTED]>
[ 33009]
[perl #49522] state variable not available
Svf_PADSTALE means something different for state vars. Make sure
we always handle it correctly
[ 33050]
Comment change from 33009 that was actually in POD, so needs to be
propagated to perlintern.pod
Affected files ...
... //depot/maint-5.10/perl/embed.fnc#4 integrate
... //depot/maint-5.10/perl/embed.h#2 integrate
... //depot/maint-5.10/perl/mg.c#4 integrate
... //depot/maint-5.10/perl/pad.c#3 integrate
... //depot/maint-5.10/perl/perl.h#5 integrate
... //depot/maint-5.10/perl/pod/perlintern.pod#3 integrate
... //depot/maint-5.10/perl/pod/perltie.pod#2 integrate
... //depot/maint-5.10/perl/pp_hot.c#5 integrate
... //depot/maint-5.10/perl/proto.h#2 integrate
... //depot/maint-5.10/perl/regexec.c#4 integrate
... //depot/maint-5.10/perl/t/mro/basic.t#2 integrate
... //depot/maint-5.10/perl/t/op/pat.t#4 integrate
... //depot/maint-5.10/perl/t/op/state.t#2 integrate
... //depot/maint-5.10/perl/t/op/tiehandle.t#2 integrate
Differences ...
==== //depot/maint-5.10/perl/embed.fnc#4 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#3~33133~ 2008-01-30 10:46:51.000000000 -0800
+++ perl/embed.fnc 2008-01-30 11:50:56.000000000 -0800
@@ -429,6 +429,7 @@
p |int |magic_clearenv |NN SV* sv|NN MAGIC* mg
p |int |magic_clear_all_env|NN SV* sv|NN MAGIC* mg
dp |int |magic_clearhint|NN SV* sv|NN MAGIC* mg
+p |int |magic_clearisa |NN SV* sv|NN MAGIC* mg
p |int |magic_clearpack|NN SV* sv|NN MAGIC* mg
p |int |magic_clearsig |NN SV* sv|NN MAGIC* mg
p |int |magic_existspack|NN SV* sv|NN const MAGIC* mg
==== //depot/maint-5.10/perl/embed.h#2 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/embed.h 2008-01-30 11:50:56.000000000 -0800
@@ -401,6 +401,7 @@
#define magic_clearenv Perl_magic_clearenv
#define magic_clear_all_env Perl_magic_clear_all_env
#define magic_clearhint Perl_magic_clearhint
+#define magic_clearisa Perl_magic_clearisa
#define magic_clearpack Perl_magic_clearpack
#define magic_clearsig Perl_magic_clearsig
#define magic_existspack Perl_magic_existspack
@@ -2690,6 +2691,7 @@
#define magic_clearenv(a,b) Perl_magic_clearenv(aTHX_ a,b)
#define magic_clear_all_env(a,b) Perl_magic_clear_all_env(aTHX_ a,b)
#define magic_clearhint(a,b) Perl_magic_clearhint(aTHX_ a,b)
+#define magic_clearisa(a,b) Perl_magic_clearisa(aTHX_ a,b)
#define magic_clearpack(a,b) Perl_magic_clearpack(aTHX_ a,b)
#define magic_clearsig(a,b) Perl_magic_clearsig(aTHX_ a,b)
#define magic_existspack(a,b) Perl_magic_existspack(aTHX_ a,b)
==== //depot/maint-5.10/perl/mg.c#4 (text) ====
Index: perl/mg.c
--- perl/mg.c#3~33132~ 2008-01-30 10:18:00.000000000 -0800
+++ perl/mg.c 2008-01-30 11:50:56.000000000 -0800
@@ -1556,6 +1556,29 @@
}
int
+Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
+{
+ dVAR;
+ HV* stash;
+
+ /* Bail out if destruction is going on */
+ if(PL_dirty) return 0;
+
+ av_clear((AV*)sv);
+
+ /* XXX see comments in magic_setisa */
+ stash = GvSTASH(
+ SvTYPE(mg->mg_obj) == SVt_PVGV
+ ? (GV*)mg->mg_obj
+ : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
+ );
+
+ mro_isa_changed_in(stash);
+
+ return 0;
+}
+
+int
Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
==== //depot/maint-5.10/perl/pad.c#3 (text) ====
Index: perl/pad.c
--- perl/pad.c#2~33132~ 2008-01-30 10:18:00.000000000 -0800
+++ perl/pad.c 2008-01-30 11:50:56.000000000 -0800
@@ -102,6 +102,8 @@
{ my $x = 1; sub f { eval '$x'} } f();
+For state vars, SVf_PADSTALE is overloaded to mean 'not yet initialised'
+
=cut
*/
@@ -768,6 +770,7 @@
else {
int newwarn = warn;
if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
+ && !SvPAD_STATE(name_svp[offset])
&& warn && ckWARN(WARN_CLOSURE)) {
newwarn = 0;
Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
@@ -796,7 +799,9 @@
"Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
PTR2UV(cv), PTR2UV(*out_capture)));
- if (SvPADSTALE(*out_capture)) {
+ if (SvPADSTALE(*out_capture)
+ && !SvPAD_STATE(name_svp[offset]))
+ {
if (ckWARN(WARN_CLOSURE))
Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%s\" is not available", name);
@@ -853,7 +858,7 @@
? SvSTASH(*out_name_sv) : NULL,
SvOURSTASH(*out_name_sv),
1, /* fake */
- 0 /* not a state variable */
+ SvPAD_STATE(*out_name_sv) ? 1 : 0 /* state variable ? */
);
new_namesv = AvARRAY(PL_comppad_name)[new_offset];
@@ -1496,8 +1501,8 @@
assert(sv);
/* formats may have an inactive parent,
while my $x if $false can leave an active var marked as
- stale */
- if (SvPADSTALE(sv)) {
+ stale. And state vars are always available */
+ if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
if (ckWARN(WARN_CLOSURE))
Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%s\" is not available",
SvPVX_const(namesv));
==== //depot/maint-5.10/perl/perl.h#5 (text) ====
Index: perl/perl.h
--- perl/perl.h#4~33130~ 2008-01-30 09:34:11.000000000 -0800
+++ perl/perl.h 2008-01-30 11:50:56.000000000 -0800
@@ -4888,7 +4888,7 @@
0,
MEMBER_TO_FPTR(Perl_magic_setisa),
0,
- MEMBER_TO_FPTR(Perl_magic_setisa),
+ MEMBER_TO_FPTR(Perl_magic_clearisa),
0,
0,
0,
==== //depot/maint-5.10/perl/pod/perlintern.pod#3 (text+w) ====
Index: perl/pod/perlintern.pod
--- perl/pod/perlintern.pod#2~33123~ 2008-01-30 03:45:08.000000000 -0800
+++ perl/pod/perlintern.pod 2008-01-30 11:50:56.000000000 -0800
@@ -597,6 +597,8 @@
{ my $x = 1; sub f { eval '$x'} } f();
+For state vars, SVf_PADSTALE is overloaded to mean 'not yet initialised'
+
AV * CvPADLIST(CV *cv)
=for hackers
==== //depot/maint-5.10/perl/pod/perltie.pod#2 (text) ====
Index: perl/pod/perltie.pod
--- perl/pod/perltie.pod#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/pod/perltie.pod 2008-01-30 11:50:56.000000000 -0800
@@ -900,12 +900,14 @@
X<PRINT>
This method will be triggered every time the tied handle is printed to
-with the C<print()> function.
-Beyond its self reference it also expects the list that was passed to
-the print function.
+with the C<print()> or C<say()> functions. Beyond its self reference
+it also expects the list that was passed to the print function.
sub PRINT { $r = shift; $$r++; print join($,,map(uc($_),@_)),$\ }
+C<say()> acts just like C<print()> except $\ will be localized to C<\n> so
+you need do nothing special to handle C<say()> in C<PRINT()>.
+
=item PRINTF this, LIST
X<PRINTF>
==== //depot/maint-5.10/perl/pp_hot.c#5 (text) ====
Index: perl/pp_hot.c
--- perl/pp_hot.c#4~33132~ 2008-01-30 10:18:00.000000000 -0800
+++ perl/pp_hot.c 2008-01-30 11:50:56.000000000 -0800
@@ -731,6 +731,11 @@
*MARK = SvTIED_obj((SV*)io, mg);
PUTBACK;
ENTER;
+ if( PL_op->op_type == OP_SAY ) {
+ /* local $\ = "\n" */
+ SAVEGENERICSV(PL_ors_sv);
+ PL_ors_sv = newSVpvs("\n");
+ }
call_method("PRINT", G_SCALAR);
LEAVE;
SPAGAIN;
@@ -2034,6 +2039,7 @@
const I32 oldsave = PL_savestack_ix;
STRLEN slen;
bool doutf8 = FALSE;
+ I32 matched;
#ifdef PERL_OLD_COPY_ON_WRITE
bool is_cow;
#endif
@@ -2120,7 +2126,8 @@
/* only replace once? */
once = !(rpm->op_pmflags & PMf_GLOBAL);
-
+ matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
+ r_flags | REXEC_CHECKED);
/* known replacement string? */
if (dstr) {
/* replacement needing upgrading? */
@@ -2152,8 +2159,7 @@
&& (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags &
REXEC_COPY_STR))
&& !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
&& (!doutf8 || SvUTF8(TARG))) {
- if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
- r_flags | REXEC_CHECKED))
+ if (!matched)
{
SPAGAIN;
PUSHs(&PL_sv_no);
@@ -2257,8 +2263,7 @@
RETURN;
}
- if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
- r_flags | REXEC_CHECKED))
+ if (matched)
{
if (force_on_match) {
force_on_match = 0;
==== //depot/maint-5.10/perl/proto.h#2 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/proto.h 2008-01-30 11:50:56.000000000 -0800
@@ -1088,6 +1088,10 @@
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
+PERL_CALLCONV int Perl_magic_clearisa(pTHX_ SV* sv, MAGIC* mg)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+
PERL_CALLCONV int Perl_magic_clearpack(pTHX_ SV* sv, MAGIC* mg)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
==== //depot/maint-5.10/perl/regexec.c#4 (text) ====
Index: perl/regexec.c
--- perl/regexec.c#3~33130~ 2008-01-30 09:34:11.000000000 -0800
+++ perl/regexec.c 2008-01-30 11:50:56.000000000 -0800
@@ -3763,8 +3763,12 @@
PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
- *PL_reglastparen = 0;
- *PL_reglastcloseparen = 0;
+ /* see regtry, specifically PL_reglast(?:close)?paren is a
pointer! (i dont know why) :dmq */
+ PL_reglastparen = &re->lastparen;
+ PL_reglastcloseparen = &re->lastcloseparen;
+ re->lastparen = 0;
+ re->lastcloseparen = 0;
+
PL_reginput = locinput;
PL_regsize = 0;
@@ -3805,6 +3809,10 @@
regcpblow(ST.cp);
cur_eval = ST.prev_eval;
cur_curlyx = ST.prev_curlyx;
+
+ PL_reglastparen = &rex->lastparen;
+ PL_reglastcloseparen = &rex->lastcloseparen;
+
/* XXXX This is too dramatic a measure... */
PL_reg_maxiter = 0;
if ( nochange_depth )
@@ -3818,6 +3826,9 @@
ReREFCNT_dec(rex);
SETREX(rex,ST.prev_rex);
rexi = RXi_GET(rex);
+ PL_reglastparen = &rex->lastparen;
+ PL_reglastcloseparen = &rex->lastcloseparen;
+
PL_reginput = locinput;
REGCP_UNWIND(ST.lastcp);
regcppop(rex);
==== //depot/maint-5.10/perl/t/mro/basic.t#2 (text) ====
Index: perl/t/mro/basic.t
--- perl/t/mro/basic.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/mro/basic.t 2008-01-30 11:50:56.000000000 -0800
@@ -3,7 +3,7 @@
use strict;
use warnings;
-require q(./test.pl); plan(tests => 38);
+require q(./test.pl); plan(tests => 40);
{
package MRO_A;
@@ -173,6 +173,19 @@
ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1/]));
ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2/]));
+
+ # [perl #49564] This is a pretty obscure way of clearing @ISA but
+ # it tests a regression that affects XS code calling av_clear too.
+ {
+ package ISACLEAR3;
+ our @ISA = qw/WW XX/;
+ }
+ ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3 WW XX/]));
+ {
+ package ISACLEAR3;
+ reset 'I';
+ }
+ ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3/]));
}
# Check that recursion bails out "cleanly" in a variety of cases
==== //depot/maint-5.10/perl/t/op/pat.t#4 (xtext) ====
Index: perl/t/op/pat.t
--- perl/t/op/pat.t#3~33133~ 2008-01-30 10:46:51.000000000 -0800
+++ perl/t/op/pat.t 2008-01-30 11:50:56.000000000 -0800
@@ -4511,6 +4511,39 @@
}
}
}
+{
+ local $Message = "\$REGMARK in replacement -- Bug #49190";
+ my $_ = "A";
+ s/(*:B)A/$REGMARK/;
+ iseq $_, "B";
+ $_ = "CCCCBAA";
+ s/(*:X)A+|(*:Y)B+|(*:Z)C+/$REGMARK/g;
+ iseq $_, "ZYX";
+}
+{
+ our @ctl_n=();
+ our @plus=();
+ our $nested_tags;
+ $nested_tags = qr{
+ <
+ (\w+)
+ (?{
+ push @ctl_n,$^N;
+ push @plus,$+;
+ })
+ >
+ (??{$nested_tags})*
+ </\s* \w+ \s*>
+ }x;
+
+ my $match= '<bla><blubb></blubb></bla>' =~ m/^$nested_tags$/;
+ ok($match,'nested construct matches');
+ iseq("@ctl_n","bla blubb",'$^N inside of (?{}) works as expected');
+ iseq("@plus","bla blubb",'$+ inside of (?{}) works as expected');
+}
+
+
+
# Test counter is at bottom of file. Put new tests above here.
#-------------------------------------------------------------------
@@ -4570,6 +4603,6 @@
iseq(0+$::test,$::TestCount,"Got the right number of tests!");
# Don't forget to update this!
BEGIN {
- $::TestCount = 4013;
+ $::TestCount = 4018;
print "1..$::TestCount\n";
}
==== //depot/maint-5.10/perl/t/op/state.t#2 (text) ====
Index: perl/t/op/state.t
--- perl/t/op/state.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/op/state.t 2008-01-30 11:50:56.000000000 -0800
@@ -10,7 +10,7 @@
use strict;
use feature ":5.10";
-plan tests => 123;
+plan tests => 130;
ok( ! defined state $uninit, q(state vars are undef by default) );
@@ -354,6 +354,50 @@
eval $forbidden;
like $@, qr/Initialization of state variables in list context currently
forbidden/, "Currently forbidden: $forbidden";
}
+
+# [perl #49522] state variable not available
+
+{
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, $_[0] };
+
+ eval q{
+ use warnings;
+
+ sub f_49522 {
+ state $s = 88;
+ sub g_49522 { $s }
+ sub { $s };
+ }
+
+ sub h_49522 {
+ state $t = 99;
+ sub i_49522 {
+ sub { $t };
+ }
+ }
+ };
+ is $@, '', "eval f_49522";
+ # shouldn't be any 'not available' or 'not stay shared' warnings
+ ok [EMAIL PROTECTED], "suppress warnings part 1 [EMAIL PROTECTED]";
+
+ @warnings = ();
+ my $f = f_49522();
+ is $f->(), 88, "state var closure 1";
+ is g_49522(), 88, "state var closure 2";
+ ok [EMAIL PROTECTED], "suppress warnings part 2 [EMAIL PROTECTED]";
+
+
+ @warnings = ();
+ $f = i_49522();
+ h_49522(); # initialise $t
+ is $f->(), 99, "state var closure 3";
+ ok [EMAIL PROTECTED], "suppress warnings part 3 [EMAIL PROTECTED]";
+
+
+}
+
+
__DATA__
state ($a) = 1;
(state $a) = 1;
==== //depot/maint-5.10/perl/t/op/tiehandle.t#2 (xtext) ====
Index: perl/t/op/tiehandle.t
--- perl/t/op/tiehandle.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/op/tiehandle.t 2008-01-30 11:50:56.000000000 -0800
@@ -10,9 +10,11 @@
my @data = ();
require './test.pl';
-plan(tests => 41);
+plan(tests => 50);
sub compare {
+ local $Level = $Level + 1;
+
return unless @expect;
return ::fail() unless(@_ == @expect);
@@ -163,6 +165,32 @@
}
{
+ package Bar::Say;
+ use feature 'say';
+ use base qw(Implement);
+
+ my $ors;
+ sub PRINT {
+ $ors = $\;
+ my $self = shift;
+ return $self->SUPER::PRINT(@_);
+ }
+
+ my $fh = Symbol::gensym;
+ @expect = (TIEHANDLE => 'Bar::Say');
+ ::ok( my $obj = tie *$fh, 'Bar::Say' );
+
+ local $\ = 'something';
+ @expect = (PRINT => $obj, "stuff", "and", "things");
+ ::ok( print $fh @expect[2..4] );
+ ::is( $ors, 'something' );
+
+ ::ok( say $fh @expect[2..4] );
+ ::is( $ors, "\n", 'say sets $\ to \n in PRINT' );
+ ::is( $\, "something", " and it's localized" );
+}
+
+{
# Test for change #11536
package Foo;
use strict;
@@ -245,4 +273,3 @@
sub READLINE { "foobar\n" }
}
-
End of Patch.
